timeslice2.f File Reference

Go to the source code of this file.

Functions/Subroutines
program	__timeslice2.f__
subroutine	slice (mint, maxt, dt)
subroutine	thinning (i1, i2)
subroutine	mvdata (f, j, nc)
subroutine	mvdatai (f, j, nc)
subroutine	mkfiles
subroutine	mkskelfiles
subroutine	mkafile
subroutine	mkaskelfile
subroutine	wtaskel (fno, xa, ya, za, code, chg, np, mulalpha)
subroutine	code2rgb (codei, chgi, r, g, b, alpha)

Function/Subroutine Documentation

__timeslice2.f__()

program __timeslice2.f__

(

)

Definition at line 4 of file timeslice2.f.

References copenfw2(), klena(), mkafile(), mkaskelfile(), mkfiles(), mkskelfiles(), n, slice(), and thinning().

      character*120  tracefile

Here is the call graph for this function:

code2rgb()

subroutine code2rgb	(	integer*2	codei,
		integer*2	chgi,
		real	r,
		real	g,
		real	b,
		real	alpha
	)

Definition at line 395 of file timeslice2.f.

References code, parameter(), and true.

      implicit none
      integer*2  codei, chgi
      real r, g, b, alpha

      integer ncolor, mncolor
      parameter( mncolor = 17 ) 
      type colortab
         integer*2 code
         integer*2 chg
         real      r
         real      g
         real      b
         real      alpha
      end type colortab
      type(colortab):: tab(mncolor)

      character*80 input
      integer i

      integer first
      data first/0/
      save first, ncolor
      
      if(first .eq. 0) then
         input = ' '
         open(13, file='colortab')
         i = 0
         do while(.true.)
           read(12, '(a)',end=10) input
           if(input(1:1) .ne. "#" .and. input .ne. ' ') then
              i = i + 1
              if(i .gt. mncolor)  then
                 write(0,*) ' too many color spec. in colortab'
                 stop 99999
              endif
              read(input,*)
     *          tab(i).code, tab(i).chg, 
     *          tab(i).r, tab(i).g, tab(i).b,
     *          tab(i).alpha
           endif
         enddo
 10      continue
         ncolor = i
         first = 1
         close(13)
      endif

      do  i = 1, ncolor
         if(tab(i).code .eq. codei .and. tab(i).chg .eq. chgi) goto 100
      enddo
      i = ncolor
 100  continue
      r = tab(i).r
      g = tab(i).g
      b = tab(i).b
      alpha = tab(i).alpha

Here is the call graph for this function:

mkafile()

subroutine mkafile

(

)

Definition at line 315 of file timeslice2.f.

References idx(), x, y, and z.

      implicit none
      include "Zprivate2.f"

      integer i, j
      character* 130  filename

      integer filec
      integer klena
      data filec/0/
      save filec

      if( filec .eq. 0 ) then
         filename = dir(1:klena(dir))//"/timesorted.dat"
         open(20, file=filename,
     *            form='formatted')
         filec = 1
      endif

      do j = jmin, jmax
         do i= 1, idx(j)
            write(20,'(3i7, i3,i3)' ) 
     *        x(i, j), y(i,j), z(i,j), codex(i,j), chgx(i,j)
         enddo
         if( idx(j) .gt. 0 ) write(20,*)
      enddo

Here is the call graph for this function:

mkaskelfile()

subroutine mkaskelfile

(

)

Definition at line 342 of file timeslice2.f.

References idx(), wtaskel(), x, y, and z.

      implicit none
      include "Zprivate2.f"

      integer i, j
      character* 130  filename

      integer filec
      integer klena
      data filec/0/
      save filec

      if( filec .eq. 0 ) then
         filename = dir(1:klena(dir))//"/timesorted.skel"
         open(20, file=filename,
     *            form='formatted')
         filec = 1
      endif

      do j = jmin, jmax
         if(idx(j) .gt. 0) then
            write(20,'(a)') "SKEL"
            call wtaskel(20,
     *      x(1, j), y(1,j), z(1,j), codex(1,j), chgx(1,j), idx(j), 
     *      mulalpha)
            write(20,*)
         endif
      enddo

Here is the call graph for this function:

mkfiles()

subroutine mkfiles

(

)

Definition at line 257 of file timeslice2.f.

References idx(), x, y, and z.

      implicit none
      include "Zprivate2.f"

      character* 130  filename

      integer  filec
      integer  klena
      data filec/0/
      save filec

      integer i, j

      do j = jmin, jmax
         if(idx(j) .gt. 0) then
            filec = filec + 1
            write(filename,'(a, a, i5.5,a)') dir(1:klena(dir)),
     *      "/ts", j, ".dat"
!     *      "/ts", filec, ".dat"
            open(20, file=filename, form='formatted')
            do i= 1, idx(j)
               write(20,'(3i7,i3,i3)') 
     *           x(i, j), y(i,j), z(i,j), codex(i,j), chgx(i,j)
            enddo
            close(20)
         endif
      enddo

Here is the call graph for this function:

mkskelfiles()

subroutine mkskelfiles

(

)

Definition at line 286 of file timeslice2.f.

References idx(), wtaskel(), x, y, and z.

      implicit none
      include "Zprivate2.f"

      character* 130  filename

      integer  filec
      integer  klena
      data filec/0/
      save filec

      integer i, j

      do j = jmin, jmax
         if(idx(j) .gt. 0) then
            filec = filec + 1
            write(filename,'(a, a, i5.5, a)') dir(1:klena(dir)),
     *      "/ts", j,  ".skel"
            open(20, file=filename, form='formatted')

            write(20, '(a)') "SKEL"
            call wtaskel(20, x(1,j), y(1,j), z(1,j), 
     *       codex(1,j), chgx(1, j), idx(j), mulalpha)

            close(20)
         endif
      enddo

Here is the call graph for this function:

mvdata()

subroutine mvdata	(	real*4, dimension(maxp, n)	f,
		integer	j,
		integer	nc
	)

Definition at line 206 of file timeslice2.f.

References idx().

      implicit none
      include "Zprivate2.f"

      integer j
      real*4  f(maxp, n)

      real*4 temp(maxp)
      integer i, nc, l

      nc = 0

      do i = 1, idx(j)
         l = si(i)
         if(l .gt. 0 ) then
            nc = nc + 1
            temp(nc) = f(l, j)
         endif
      enddo

      do i = 1, nc
         f(i, j) = temp(i)
      enddo

Here is the call graph for this function:

mvdatai()

subroutine mvdatai	(	integer*2, dimension(maxp, n)	f,
		integer	j,
		integer	nc
	)

Definition at line 232 of file timeslice2.f.

References idx().

      implicit none
      include "Zprivate2.f"
      integer j
      integer*2  f(maxp, n)

      integer*2  temp(maxp)
      integer i, nc, l
      nc = 0

      do i = 1, idx(j)
         l = si(i)
         if(l .gt. 0 ) then
            nc = nc + 1
            temp(nc) = f(l, j)
         endif
      enddo

      do i = 1, nc
         f(i, j) = temp(i)
      enddo

Here is the call graph for this function:

slice()

subroutine slice	(	real*4	mint,
		real*4	maxt,
		real*4	dt
	)

Definition at line 74 of file timeslice2.f.

References idx(), maxp, n, thinning(), true, x, y, and z.

      implicit none
      include "Zprivate2.f"

      real*4  mint, maxt, dt
      integer i, j
      real*4  t,  k
      integer*2 code, chg 
      integer*2 temp
      integer it1, it2
      real*4  xx1, yy1, zz1, time1
      real*4  xx2, yy2, zz2, time2

      character* 120 input

      do j = 1, n
         idx(j) = 0
      enddo
      
      do while (.true.)
         input = ' '
         read(*, '(a)', end=1000 )  input
         if( input .ne. " " ) then
            read(input, * ) xx1, yy1, zz1,  time1, code, chg
            do while( input .ne. " ") 
               read(*, '(a)' )  input
               if( input .ne. " " ) then
                  read(input, * ) xx2, yy2, zz2,  time2, code, chg
                  it1 = (time1- mint)/dt +1
                  it2 = (time2- mint)/dt 
                  if(it1 .lt. 1) goto 900
                  if(it2 .gt. n) goto 900
                  if(time2 .gt. maxt) goto 900
                  jmin = min(jmin, it1)
                  jmax = max(jmax, it2)
                  do  j = it1, it2
                     t = j*dt + mint
                     if( idx(j) .ge. maxp ) then
                        write(0,*)
     *                    'ptcls at time=', t , ' > ',  maxp
                        write(0,*)
     *                    'try to thin ptcls in the same pixel'
                        call thinning(j,j)
                     endif
                     idx(j) = idx(j) + 1
                     if(idx(j) .gt. maxp) then
                        write(0,*) 'ptcls > ',  maxp
                        write(0,*) 'thinning not worked'
                        stop 1234
                     endif
                        
!                           (x2-x1)/(t2-t1) *(t-t1) +x1
                     k = (t - time1) /(time2-time1)
                     temp = (xx2-xx1) * k + xx1
                     if( abs(temp) .gt. max16bit) goto 200
                     x(idx(j), j) =temp
                     temp = (yy2-yy1) * k + yy1
                     if( abs(temp) .gt. max16bit) goto 200
                     y(idx(j), j) = temp
                     temp = (zz2-zz1) * k + zz1
                     if( abs(temp) .gt. max16bit) goto 200
                     z(idx(j), j) = temp
                     codex(idx(j), j) = code
                     chgx(idx(j), j) = chg
                     goto 210
 200                 continue
                     idx(j)= idx(j) -1
 210                 continue
                  enddo   
 900              continue
                  xx1 = xx2
                  yy1 = yy2
                  zz1 = zz2
                  time1 = time2
               endif
            enddo
         endif
      enddo
 1000 continue

Here is the call graph for this function:

thinning()

subroutine thinning	(	integer	i1,
		integer	i2
	)

Definition at line 157 of file timeslice2.f.

References false, idx(), kqsorth(), mvdatai(), true, x, y, and z.

      implicit none
      include "Zprivate2.f"
!        culling overlapping points in a pixel
!           this is very rough thinning
!     sorr each x
      integer i1, i2
      integer nc, j, i, k1, k2, l, nc0
      logical  dothin

      do j = i1, i2
         dothin = .false.
         if( idx(j) .gt. 0) then
            call kqsorth(x(1,j), si, idx(j))
            do i = 1, idx(j)-1
               k1 = si(i)
               if(k1  .lt. 0) goto 20
               do l = i+1,  idx(j)
                  k2 = si(l)
                  if(k2 .lt. 0) goto 10
                  if(abs(x(k1, j)- x(k2,j)) .gt. pixel ) goto 20
!                         since xx is sorted,  we may safe to skip
!                         further check
!
                  if(abs(y(k1, j)- y(k2,j)) .gt. pixel ) goto 10
                  if(abs(z(k1, j)- z(k2,j)) .gt. pixel ) goto 10
!                   remove  k2
                  si(l) = - k2
                  dothin = .true.
 10               continue
               enddo
 20            continue
            enddo
            if(dothin) then
               nc0 = idx(j)
               call mvdatai(x, j, nc)
               call mvdatai(y, j, nc)
               call mvdatai(z, j, nc)
               call mvdatai(codex, j, nc)
               call mvdatai(chgx, j, nc)  
               idx(j) = nc
!///////////// 
               write(0,*) ' thinning ', nc0, "-->", nc
!//////////////
            endif
         endif
      enddo

Here is the call graph for this function:

wtaskel()

subroutine wtaskel	(	integer	fno,
		real*4, dimension(np)	xa,
		real*4, dimension(np)	ya,
		real*4, dimension(np)	za,
		integer*2, dimension(np)	code,
		integer*2, dimension(np)	chg,
		integer	np,
		real*4	mulalpha
	)

Definition at line 373 of file timeslice2.f.

References code2rgb().

!           
      implicit none
      integer fno, np
      real*4 xa(np),   ya(np), za(np)
      real*4 mulalpha
      integer*2 code(np), chg(np) 

      real  r, g, b, alpha
      integer i
      if(np .gt. 0) then
         write(fno, '(2i9)') np, np
         do i = 1, np
            write(fno, '(3i7)' ) xa(i), ya(i), za(i)
         enddo
         do i= 1, np
            call code2rgb(code(i), chg(i), r, g, b, alpha)
            write(fno, '("1 ", i8, 3f5.2,f6.3)')
     *       i-1, r, g, b, alpha*mulalpha
         enddo
      endif

Here is the call graph for this function: