timesliceg77.f File Reference

Go to the source code of this file.

Functions/Subroutines
program	__timesliceg77.f__
subroutine	slice (mint, maxt, dt)
subroutine	thinning (kk, 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

__timesliceg77.f__()

program __timesliceg77.f__

(

)

Definition at line 4 of file timesliceg77.f.

References klena(), maxp, 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 415 of file timesliceg77.f.

References parameter(), and true.

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

      integer ncolor, mncolor
      parameter( mncolor = 17 ) 
!      type colortab
         integer*2 tcode(mncolor)
         integer*2 tchg(mncolor)
         real      tr(mncolor)
         real      tg(mncolor)
         real      tb(mncolor)
         real      talpha(mncolor)
!      end type colortab
!      type(colortab):: tab(mncolor)

      character*80 input
      integer i

      integer first
      data first/0/
      save first, ncolor, tcode, tchg, tr, tg, tb, talpha

      if(first .eq. 0) then
         input = ' '

         open(13, file='colortab')
         i = 0
         do while(.true.)
           read(13,'(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,*)
     *          tcode(i), tchg(i), 
     *          tr(i), tg(i), tb(i),
     *          talpha(i)
           endif
         enddo
 10      continue
         ncolor = i
         first = 1
         close(13)
      endif

      do  i = 1, ncolor
         if(tcode(i) .eq. codei .and. tchg(i) .eq. chgi) goto 100
      enddo
      i = ncolor
 100  continue

      r = tr(i)
      g = tg(i)
      b = tb(i)
      alpha = talpha(i)

Here is the call graph for this function:

mkafile()

subroutine mkafile

(

)

Definition at line 334 of file timesliceg77.f.

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

      implicit none
      include "Zprivate2g77.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,'(3g16.8, 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 361 of file timesliceg77.f.

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

      implicit none
      include "Zprivate2g77.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 285 of file timesliceg77.f.

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

      implicit none
      include "Zprivate2g77.f"

      character* 130  filename

      integer  klena

      integer i, j

      do j = jmin, jmax
         if(idx(j) .gt. 0) then
            write(filename,'(a, a, i5.5,a)') dir(1:klena(dir)),
     *      "/ts", j+offset, ".dat"
            open(20, file=filename, form='formatted')
            do i= 1, idx(j)
               write(20,'(3g16.8,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 309 of file timesliceg77.f.

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

      implicit none
      include "Zprivate2g77.f"

      character* 130  filename


      integer  klena

      integer i, j

      do j = jmin, jmax
         if(idx(j) .gt. 0) then
            write(filename,'(a, a, i5.5, a)') dir(1:klena(dir)),
     *      "/ts", j+offset,  ".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 234 of file timesliceg77.f.

References idx().

      implicit none
      include "Zprivate2g77.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 260 of file timesliceg77.f.

References idx().

      implicit none
      include "Zprivate2g77.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 79 of file timesliceg77.f.

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

      implicit none
      include "Zprivate2g77.f"

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

      character* 120 input
      real*8 linec
      data linec/0.0/
      save linec

      do j = 1, n
         idx(j) = 0
      enddo
      
      do while (.true.)
         input = ' '
         read(11, '(a)', end=1000 )  input
         linec = linec + 1.d0
         if( mod(linec, 1.d7) .eq.  0 ) then
            write(0,*)
     *      ' ------------------------------------linec=',linec
         endif
         if( input .ne. " " ) then
            read(input, * ) xx1, yy1, zz1,  time1, code, chg
            do while( input .ne. " ") 
               read(11, '(a)', end =1000)  input
               linec = linec + 1.d0
               if( mod(linec, 1.d7) .eq.  0 ) then
                  write(0,*)
     *            ' ------------------------------------linec=',
     *            linec
               endif

               if( input .ne. " " ) then
                  read(input, * ) xx2, yy2, zz2,  time2, code, chg
                  xxp = xx2*aax + yy2*aay   ! aaz =0
                  yyp = xx2*bbx + yy2*bby + zz2*bbz
                  if(xxp**2 + yyp**2 .gt. rmax2) goto 900
                  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. maxppt ) then
                        pixel = pixel0
                        write(0,*)
     *                    'ptcls at time=', t , ' > ',  maxppt
                        write(0,*)
     *                    'try to thin ptcls in the same pixel'
                        kk = 0 
                        call thinning(kk, j, j)
                     endif
                     do while (idx(j) .ge. maxppt) 
                        pixel = pixel*pixelinc
                        write(0,*) 'ptcls > ',  maxppt
                        write(0,*) 'thinning not worked'
                        write(0,*)
     *                  'brute thinning is tried by',pixelinc,
     *                  'x  current pixel =', pixel
!                         if kk == 1, don't do sort; kk may be 
!                         reset to 0 inside of  thinning
                        call thinning(kk, j, j)
                     enddo
                     idx(j) = idx(j) + 1
!                           (x2-x1)/(t2-t1) *(t-t1) +x1
                     k = (t - time1) /(time2-time1)
                     x(idx(j), j) = (xx2-xx1) * k + xx1
                     y(idx(j), j) = (yy2-yy1) * k + yy1
                     z(idx(j), j) = (zz2-zz1) * k + zz1
                     codex(idx(j), j) = code
                     chgx(idx(j), j) = chg
                  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	kk,
		integer	i1,
		integer	i2
	)

Definition at line 177 of file timesliceg77.f.

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

      implicit none
      include "Zprivate2g77.f"
!        culling overlapping points in a pixel
!           this is very rough thinning
!     sorr each x
      integer kk  ! in/out.  if 0, sort x before thinning
      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
            if(kk .eq. 0) then
               call kqsortr(x(1,j), si, idx(j))
            endif
            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 mvdata(x, j, nc)
               call mvdata(y, j, nc)
               call mvdata(z, j, nc)
               call mvdatai(codex, j, nc)
               call mvdatai(chgx, j, nc)  
               idx(j) = nc
               write(0,*) ' thinning ', nc0, "-->", nc
            else
               if(i1 .eq. i2) then 
!                sorted data remain the same; so if 
!                thinning is tried with larger pixel
!                we don't need to sort again
                  kk = 1
               endif
            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 392 of file timesliceg77.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, '(3g16.8)' ) 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: