3DRWALK/source/3doutput-block.for

c --------------------------------------------------------------
c - 
c -       RWALK - Random Walk Model. 
c -       (OUTPUT ENCODING ROUTINES)
c - 	  FILE: output.f
c -
c -       University of NSW - Water Research Laboratory.
c -       Brett Miller.
c
c         2019 reworking to simply output a large array in text format
c -
c --------------------------------------------------------------

        SUBROUTINE outputgraphicscodes(ngrid)
c--------------------------------------------------------------------c
        common mtot,npp,ia(1)
        common /dbsys/numa,next,idir,ipp(3)
        integer ngrid
        include '3dgeom.cb'

        WRITE(*,*) 'Outputting...'
        nyy=numY*resXY+1
        nxx=numX*resXY+1
        nzz=numZ*resZ+1
        call locate('nop ',nnop ,mlt,mlt)
        call locate('ityp',nityp,mlt,mlt)
        call locate('cord',ncord,mlt,mlt)
        call locate('prtE',nprtE,mlt,NUMPARTS)
        call locate('prtN',nprtN,mlt,NUMPARTS)
        call locate('prtZ',nprtZ,mlt,NUMPARTS)
        call locate('prtI',nprtI,mlt,NUMPARTS)
        call locate('prtV',nprtV,mlt,NUMPARTS)
        call locate('prtM',nprtM,mlt,NUMPARTS)
        call locate('prtA',nprtA,mlt,NUMPARTS)
        call locate('nply',nnply,mlt,no_poly)
        call locate('nump',nnump,mlt,mlt)
        call locate('no_p',nno_p,mlt,no_poly)
        call locate('ppm ',nppm ,mlt,no_poly)
        call locate('nopt',nnopt,no_poly,mlt)
        call defini('ykup',nykup,1,nyy)
        call defini('tabx',ntabx,1,NUMPARTS)
        call defini('tabz',ntabz,1,NUMPARTS)
        call defini('tabm',ntabm,1,NUMPARTS)
        call defini('tabp',ntabp,1,NUMPARTS)
        call definr('slic',nslic,nxx+2,3*nzz+6)
        nxx4=nxx
        nyy4=nyy
        nzz4=nzz
        call defini('pv  ',npv  ,nxx4,nyy4*2)
        call defini('el  ',nel  ,nyy4,nzz4*2)
        call definr('toly',ntly ,nxx4,nyy4)
        call definr('boly',nbly ,nxx4,nyy4)
        call defini('tpv ',ntpv ,nxx4,nyy4)
        call defini('bpv ',nbpv ,nxx4,nyy4)

        CALL outputplumes(NUMPARTS,nxx,nyy,nzz,ia(nnop),ia(nityp),
     *         ia(ncord),ia(nprtE),ia(nprtN),ia(nprtZ),ia(nprtI),
     *         ia(nprtM),ia(nprtA),ia(nprtV),ia(nykup),ia(ntabx),
     *         ia(ntabz),ia(ntabm),ia(ntabp),ia(nslic),ia(npv),
     *         ia(nel),ia(ntly),ia(nbly),ia(ntpv),ia(nbpv),ia(nnply),
     *         ia(nnump),ia(nno_p),ia(nnopt),ia(nppm),no_poly,ngrid)

        call delete('bpv ')
        call delete('tpv ')
        call delete('boly')
        call delete('toly')
        call delete('el  ')
        call delete('pv  ')
        call delete('slic')
        call delete('tabp')
        call delete('tabm')
        call delete('tabz')
        call delete('tabx')
        call delete('ykup')

        RETURN
        END

c --------------------------------------------------------------

        SUBROUTINE addoutputheader(stream)
        INCLUDE '3dgeom.cb'
        INCLUDE '3dpolls.cb'
        INCLUDE '3dpoints.cb'
        INCLUDE '3duparms.cb'
        INTEGER i, n
        BYTE    bt
        CHARACTER*1 bc
        REAL    gE, gN, a, b
        INTEGER stream

        n=1
        DO 10 i=1,12
                bc=start_stamp(i:i)
                WRITE(stream,REC=n) bc
                n=n+1
10      CONTINUE
        i=outputTS
        CALL out4bytes(i, n, stream)
        bt=poll_type
        WRITE(stream,REC=n) bt
        n=18
        i=NINT(abs(goE))
        CALL out4bytes(i, n, stream)
        i=NINT(abs(goN))
        CALL out4bytes(i, n, stream)
        a=numX
        b=numY
        CALL calc_EN(gE, gN, a, b)
        i=NINT(abs(gE))
        CALL out4bytes(i, n, stream)
        i=NINT(abs(gN))
        CALL out4bytes(i, n, stream)
        i=NINT(numZ*dimZ)
        CALL out4bytes(i, n, stream)
        i=numX*resXY
        CALL out4bytes(i, n, stream)
        i=numY*resXY
        CALL out4bytes(i, n, stream)

        IF (stream.eq.21.or.stream.eq.22) THEN
                i=numZ*resZ
        ELSE
                i=numX*resXY
        END IF
        CALL out4bytes(i, n, stream)

c       add four bytes for negtive values of goE, goN, gE and gN
        n=58
        if(goE.lt.0.0) then
           WRITE(stream,REC=n) 1
        else
           WRITE(stream,REC=n) 0
        endif
        n=n+1
        if(goN.lt.0.0) then
           WRITE(stream,REC=n) 1
        else
           WRITE(stream,REC=n) 0
        endif
        n=n+1
        if(gE.lt.0.0) then
           WRITE(stream,REC=n) 1
        else
           WRITE(stream,REC=n) 0
        endif
        n=n+1
        if(gN.lt.0.0) then
           WRITE(stream,REC=n) 1
        else
           WRITE(stream,REC=n) 0
        endif

        n=50
        CALL out4bytes(numviews, n, stream)
c
c-------Leave some room for numviews and point table offset.	
c
        n=66+4*maxoutputs+1
        WRITE(stream,REC=n) bt
        numviews=0
c
c-------Extra line for recording the last record of the file
c
        n1=62
        call out4bytes(n,n1,stream)

        RETURN
        END

c ------------------------------------------------------------------

        SUBROUTINE addpointers(stream)
        INCLUDE '3dpoints.cb'
        INTEGER	ptoffset, n
        INTEGER stream
cdrc        byte    b
        byte    b,c

c  stream=21 is for the RWD file
c  stream=22 is for the RWC file
c  stream=23 is for the RWZ file

        n=62
c	print*,'Call 1, Stream =',stream
        call in4bytes(n0,n,stream)
c	print*,'After in4bytes, n0=',n0
        read(stream,rec=n0) c
c	print*,'After read'
        INQUIRE(stream, NEXTREC=n0)
        ptoffset=66
        n=66
        CALL out4bytes(viewpoint(stream-20), n+4*(numviews-1), stream)
        n=50
        CALL out4bytes(numviews, n, stream)
        n=54
        CALL out4bytes(ptoffset, n, stream)
        read(stream, rec=n0-1) b
        RETURN
        END
        
c ------------------------------------------------------------------
c ------- Routines to prepare graphics views -----------------------
c ------------------------------------------------------------------

        SUBROUTINE outputplumes(NUMPARTS,MAXXRES,MAXYRES,MAXZRES,nop,
     *        itype,cord,partE,partN,partZ,partI,partM,partA,partV,
     *        ylookup,table_x,table_z,table_M,table_point,slice,pv,el,
     *        toplayer,botlayer,top_pv,bot_pv,nply,nump,no_p,no_p_time,
     *        ppm,no_poly,ngrid)
        INCLUDE '3duparms.cb'
        INCLUDE '3dgeom.cb'
        INCLUDE '3dpoints.cb'

cBMM2019
        character gridfname*100
        integer   gridnumber
        common /bmhack/gridfname,gridnumber
        character fname*100
        
        INTEGER*2 nop(20,1)
        INTEGER itype(1)
        INTEGER partI(1)
        INTEGER ylookup(MAXYRES)
        INTEGER table_x(NUMPARTS)
        INTEGER table_z(NUMPARTS)
        REAL    table_M(NUMPARTS)
        INTEGER table_point(NUMPARTS)
        INTEGER table_next
        INTEGER	point,ngrid

        REAL    partE(1),partN(1),partZ(1),partM(1),partV(1),partA(1)
        REAL    cord(3,1)
        INTEGER nply(2,1),nump(1),no_p(1),ppm(1),no_p_time(no_poly,1)
        REAL    slice(0:MAXXRES, 0:MAXZRES, 3)
        INTEGER	left, centre, right, dummy
        BYTE    pv(MAXXRES,MAXYRES,2)
        BYTE    el(MAXYRES,MAXZRES,2)

        INTEGER	x, y, z, pil, no_poly
        REAL 	mass
        REAL	a, b, c, pel,pnl,pzl,pe,pn,pz,pa,pm
        INTEGER	m, n1
        REAL    toplayer(MAXXRES, MAXYRES)
        REAL	botlayer(MAXXRES, MAXYRES)
        BYTE    top_pv(MAXXRES,MAXYRES)
        BYTE    bot_pv(MAXXRES,MAXYRES)
        BYTE	dilution_scale

cBM2019
        REAL, DIMENSION(:,:,:),allocatable :: grid

        allocate (grid(0:MAXXRES,0:MAXYRES,0:MAXZRES))
        
        do x=1,numX
           do y=1,numY 
                do z=1,numZ
                        grid(x,y,z)=0.0
                enddo
           end do
        end do
        DO 5 m=1, NUMPARTS
                pel=partE(m)
                pnl=partN(m)
                pzl=partZ(m)
                pil=partI(m)
                pa=partA(m)
                pvv=partV(m)
                pm=partM(m)
                call calc_XYZ(nop,cord,itype,pel,pnl,pzl,pil,pe,pn,pz)
                CALL calc_ab(a, b, pe, pn)
                CALL calc_c(c, pz)
                if(a.lt.0.0.or.a.ge.float(numX)) goto 5  
                if(b.lt.0.0.or.b.ge.float(numY)) goto 5 
                if(c.lt.0.0.or.c.ge.float(numY)) goto 5 
                x=INT(a*resXY)+1
                y=INT(b*resXY)+1
                z=INT(c*resXY)+1
                grid(x,y,z)=grid(x,y,z)+pm
5       enddo


        WRITE(fname,'(A,I5.5,A)') gridfname(1:lenstr(gridfname)),
     1                               gridnumber,'.grid'
        OPEN(UNIT=93,file=fname)
        do x=1,numX
           do y=1,numY 
                do z=1,numZ
                     call calc_EN(a,b,float(x),float(y))
                     write(93,'(2F9.0,F6.2,F15.0)') a,b,z*dimZ,
     1                                             grid(x,y,z)
                enddo
           end do
        end do

        CLOSE(93)
        gridnumber=gridnumber+1

        deallocate(grid)
ccc
ccc        n1=50
cccc	print*,'Call 2'
ccc        call in4bytes(numviews,n1,21)
ccc        numviews=numviews+1
ccc        if(p_count.and.ngrid.eq.1) then
ccc           do i=1,no_poly
ccc              no_p(i)=0
ccc              ppm(i)=0.0
ccc              do k=1,tot_dead_age/3600+1
ccc                 no_p_time(i,k)=0
ccc              enddo
ccc           enddo
ccc        endif
cccc    *************************
cccc    STEP 1 - The lookup table
cccc    *************************
ccc
ccc        do x=1,MAXXRES
ccc        	do y=1, MAXYRES
ccc        		toplayer(x,y)=0.0
ccc        		botlayer(x,y)=0.0
ccc        	end do
ccc        end do
ccc
ccc        nn0=0
ccc
ccc        DO 10 y=1, numY*resXY
ccc               ylookup(y)=-1
ccc10	CONTINUE
ccc        table_next=1
cccc	   No need to initialise the table as the list will only point to 
cccc	   used portions.
ccc        DO 20 m=1, NUMPARTS
cccc	    IF (partE(m).ne.-1.) THEN
ccc                pel=partE(m)
ccc                pnl=partN(m)
ccc                pzl=partZ(m)
ccc                pil=partI(m)
ccc                pa=partA(m)
ccc                pvv=partV(m)
ccc                pm=partM(m)
ccc                call calc_XYZ(nop,cord,itype,pel,pnl,pzl,pil,pe,pn,pz)
ccc        	CALL calc_ab(a, b, pe, pn)
ccc                if(a.lt.0.0.or.a.ge.float(numX)) goto 20  !added by Y.C. WANG
ccc                if(b.lt.0.0.or.b.ge.float(numY)) goto 20  !added by Y.C. WANG
cccc
cccc---------------counts particles in the specified areas
cccc
ccc                if(p_count.and.ngrid.eq.1) call particles_c(cord,nply,
ccc     *                    nump,no_p,no_p_time,ppm,no_poly,pe,pn,pa,pm)
ccc
ccc        	CALL calc_c(c, pz)
ccc        	IF (pvv.ne.0.0) THEN
ccc        		IF (partV(m).eq.-9999.0) THEN
ccc        			x=INT(a*resXY)+1
ccc        			y=INT(b*resXY)+1
ccc        			botlayer(x,y)=botlayer(x,y)+partM(m)
ccc        		END IF
ccc        		IF (pz.gt.-0.1.and.pvv.gt.0.0) THEN
ccc        			x=INT(a*resXY)+1
ccc        			y=INT(b*resXY)+1
ccc        			toplayer(x,y)=toplayer(x,y)+partM(m)
ccc                                nn0=nn0+1
ccc        		END IF
ccc        	ELSE
ccc        		IF (c.ge.0.0.and.c.lt.float(numZ)) THEN 
ccc        			x=INT(a*resXY)+1
ccc        			y=INT(b*resXY)+1
ccc        			z=INT(c*resZ)+1
ccc                      		table_x(table_next)=x
ccc                      		table_z(table_next)=z
ccc                      		table_M(table_next)=partM(m)
ccc                      		table_point(table_next)=ylookup(y)
ccc                      		ylookup(y)=table_next
ccc                      		table_next=table_next+1
ccc        		END IF
ccc        	END IF
cccc	    END IF
ccc20	CONTINUE
ccc
cccc      
cccc-------print the proportions of particles in the specified areas
cccc
ccc        if(p_count.and.ngrid.eq.1) then
ccc           write(36,'(/a/)') '       Area    No of Particles'//
ccc     &                       '           %      mass'
ccc           do i=1,no_poly
ccc              if(NUMPARTS.ne.0) then
ccc               write(36,'(2i10,f23.2,e12.3)') i,no_p(i),
ccc     &                                   100.0*no_p(i)/NUMPARTS,ppm(i)
ccc              else
ccc               write(36,'(2i10,f23.2,e12.3)') i,no_p(i),0.0,ppm(i)
ccc              endif
ccc              write(36,'(/a,i10/)') ' Total No of Particles=',NUMPARTS
ccc              write(36,'(a/)') '  Area  Hour  No of Particles'
ccc              do k=1,tot_dead_age/3600
ccc                 write(36,'(2i5,i10)') i,k,no_p_time(i,k)
ccc              enddo
ccc           enddo
ccc           write(*,*)
ccc        endif
ccc
ccc
cccc    ************************
cccc    STEP 2 - Run the slices
cccc    ************************
ccc
ccc        left=1
ccc        centre=2
ccc        right=3
ccc        CALL clearslice(slice,left, MAXXRES, MAXZRES)
ccc        CALL clearslice(slice,centre, MAXXRES, MAXZRES)
ccc        CALL clearslice(slice,right, MAXXRES, MAXZRES)
ccc        y=1
ccc        point=ylookup(y)
ccc        DO 200 WHILE (point.ne.-1)
ccc        	x=table_x(point)
ccc        	z=table_z(point)
ccc        	mass=table_M(point)
ccc        	CALL addyslice(x,y,z,mass,slice,left,centre,right,
ccc     *                                            MAXXRES,MAXZRES)
ccc        	point=table_point(point)
ccc200	END DO
ccc        DO 800 y=2,numY*resXY
ccc        	point=ylookup(y)
ccc        	DO 300 WHILE (point.ne.-1)
ccc        		x=table_x(point)
ccc        		z=table_z(point)
ccc        		mass=table_M(point)
ccc        		CALL addyslice(x,y,z,mass,slice,left,centre,
ccc     *                                        right,MAXXRES,MAXZRES)
ccc        		point=table_point(point)
ccc300		CONTINUE
ccc        	CALL establishview(y-1, pv, el, slice, left, MAXXRES,
ccc     *                                        MAXYRES,MAXZRES,ngrid)
ccc        	dummy=left
ccc        	left=centre
ccc        	centre=right
ccc        	right=dummy
ccc        	CALL clearslice(slice,right, MAXXRES, MAXZRES)
ccc800	CONTINUE
ccc        y=numY*resXY
ccc        CALL establishview(y, pv, el, slice, left, MAXXRES,
ccc     *                                     MAXYRES, MAXZRES,ngrid)
ccc        if(dilution) then
ccc          CALL encodegraphics(21, 1, pv, el, MAXXRES, MAXYRES, MAXZRES)
ccc        endif
ccc        if(concentration) then
ccc          CALL encodegraphics(22, 2, pv, el, MAXXRES, MAXYRES, MAXZRES)
ccc        endif
ccc
ccc
ccc        DO x=1, numX*resXY
ccc        	DO y=1, numY*resXY
ccc        		top_pv(x,y)=dilution_scale(toplayer(x,y))
ccc        		bot_pv(x,y)=dilution_scale(botlayer(x,y))
ccc        	END DO
ccc        END DO
ccc        CALL encodedoublegraphics(23, top_pv, bot_pv, MAXXRES, MAXYRES) 
ccc
ccc        if(fbindump) call fbindumproutine(toplayer, MAXXRES, MAXYRES)
ccc
        print *,'Return from outputting.'
        RETURN 
        END

c ------------------------------------------------------------------

        SUBROUTINE addyslice(xp,yp,zp,mass,slice,lf,cn,rt,MAXXRES,
     *                                                    MAXZRES)
        INCLUDE '3dgeom.cb'
        INTEGER	xp,yp,zp
        REAL	mass
        REAL	slice(0:MAXXRES,0:MAXZRES,3)
        INTEGER	lx,hx,lz,hz
        INTEGER	ymult, divider
        INTEGER	x,z
        INTEGER lf, cn, rt
        
        IF ((yp.eq.numY*resXY).or.(yp.eq.1)) THEN 
        	ymult=2
        ELSE
        	ymult=3
        ENDIF
        lx=-1
        hx=1
        lz=-1
        hz=1
        IF (xp.eq.1) lx=0
        IF (xp.eq.numX*resXY) hx=0
        IF (zp.eq.1) lz=0
        IF (zp.eq.numZ*resZ) hz=0
        divider=(hx-lx+1)*(hz-lz+1)*ymult
        DO 400 x=xp+lx, xp+hx
           DO 300 z=zp+lz,zp+hz
              slice(x,z,cn)=slice(x,z,cn)+mass/divider
              IF (slice(x,z,cn).gt.slice(0,z,cn)) 
     1				slice(0,z,cn)=slice(x,z,cn)
              IF (slice(x,z,cn).gt.slice(x,0,cn)) 
     1				slice(x,0,cn)=slice(x,z,cn)
              IF (yp.ne.1) THEN
        	  slice(x,z,lf)=slice(x,z,lf)+mass/divider
        	  IF (slice(x,z,lf).gt.slice(0,z,lf)) 
     1				slice(0,z,lf)=slice(x,z,lf)
        	  IF (slice(x,z,lf).gt.slice(x,0,lf)) 
     1				slice(x,0,lf)=slice(x,z,lf)
              ENDIF
              IF (yp.ne.numY*resXY) THEN
        	  slice(x,z,rt)=slice(x,z,rt)+mass/divider
        	  IF (slice(x,z,rt).gt.slice(0,z,rt)) 
     1				slice(0,z,rt)=slice(x,z,rt)
        	  IF (slice(x,z,rt).gt.slice(x,0,rt)) 
     1				slice(x,0,rt)=slice(x,z,rt)
              ENDIF
300	   CONTINUE
400	CONTINUE
        RETURN
        END

        SUBROUTINE clearslice(slice, y, MAXXRES, MAXZRES)
        INCLUDE '3dgeom.cb'
        REAL 	slice(0:MAXXRES, 0:MAXZRES, 3)
        INTEGER	x,y,z
        DO 20 x=0,numX*resXY
        	DO 10 z=0,numZ*resZ
        		slice(x,z,y)=0.0
10		CONTINUE
20	CONTINUE
        RETURN
        END

        SUBROUTINE establishview(y, pv, el, slice, left, MAXXRES, 
     *                                  MAXYRES,MAXZRES,ngrid)
        INCLUDE '3dgeom.cb'
        INCLUDE '3duparms.cb'
        INTEGER y, left
        BYTE	dilution_scale
        BYTE	concentration_scale
        REAL 	slice(0:MAXXRES, 0:MAXZRES, 3)
        BYTE    pv(MAXXRES,MAXYRES,2)
        BYTE    el(MAXYRES,MAXZRES,2)
        INTEGER	x,z,ngrid
        REAL    mass
        if(dilution) then
           DO x=1,numX*resXY
              mass=slice(x,0,left)
              pv(x,y,1)=dilution_scale(mass)
           enddo
           DO z=1,numZ*resZ
              mass=slice(0,z,left)
              el(y,z,1)=dilution_scale(mass)
           enddo
        endif
        if(concentration) then
           DO x=1,numX*resXY
              mass=slice(x,0,left)
              pv(x,y,2)=concentration_scale(mass)
           enddo
           DO z=1,numZ*resZ
              mass=slice(0,z,left)
              el(y,z,2)=concentration_scale(mass)
           enddo
        endif
        IF(pbindump(ngrid)) 
     1		CALL pbindumproutine(slice, left, MAXXRES, MAXZRES)
        RETURN
        END

        
c--------------------------------------------------------pbindumproutine
        SUBROUTINE pbindumproutine(slice, left, MAXXRES, MAXZRES)
c----------------------------------------------------------------------c
c purpose:                                                             c
c         To dump a 3D plume file.                                     c
c----------------------------------------------------------------------c
        INCLUDE '3duparms.cb'
        INCLUDE '3dgeom.cb'
        INCLUDE '3dpoints.cb'
        INTEGER left
        REAL 	slice(0:MAXXRES, 0:MAXZRES, 3)
        INTEGER	x, z, pos, count, recpos, n0, numv
        REAL	mass, out, sview, rn

c BMM 070810 
c Change of the format of the bin file into a standard binary file.
c The file has been opened in 3drwalk.F on stream 37

        WRITE(37) ((slice(x,z,left),x=1,numX*resXY),z=1,numZ*resZ)

c	pos=1
c	count=0
c        read(20,REC=3) n0
cc       read(20,REC=3) rn
cc       n0=int(rn)
c        read(20,REC=n0,err=1) mass
c	INQUIRE(UNIT=20, NEXTREC=n0,err=2)
c	recpos=n0
c	DO 300 WHILE (pos.le.(numX*resXY*numZ*resZ))
c		x=mod(pos-1, (numX*resXY))+1
c		z=((pos-1)/(numX*resXY))+1
c		mass=slice(x,z,left)
c		IF (mass.eq.0.0) THEN
c			count=count+1
c		ELSE
c			IF (count.ne.0) THEN
c				out=(-1.0)*count
c				WRITE(20, REC=recpos,err=3) out
c				recpos=recpos+1
c				count=0
c			ENDIF
c			WRITE(20, REC=recpos,err=4) mass
c			recpos=recpos+1
c		END IF
c		pos=pos+1
c300	END DO
c	IF (count.ne.0) THEN
c		out=(-1.0)*count
c		WRITE(20, REC=recpos,err=5) out
c		recpos=recpos+1
c	END IF
c        read(20, REC=4,err=6) sview
c        numv=int(sview)
c        if(numv.ne.numviews) then
c	   write(20, REC=4) float(numviews)
c	   write(20, REC=4+numviews) float(n0)
c        endif
c	write(20, REC=3,err=7) recpos-1
cc       write(20, REC=3,err=7) float(recpos-1)
c	read(20, REC=recpos-1,err=8) mass
c	RETURN
c1       print *,1,n0
c        stop
c2       print *,2,n0
c        stop
c3       print *,3,recpos,out
c        stop
c4       print *,4,recpos,mass
c        stop
c5       print *,5,recpos,out
c        stop
c6       print *,6,4,sview
c        stop
c7       print *,7,recpos-1
c        stop
c8       print *,8,recpos-1,mass
c        stop


        END

c--------------------------------------------------------fbindumproutine
        SUBROUTINE fbindumproutine(toplayer, MAXXRES, MAXYRES)
c----------------------------------------------------------------------c
c purpose:                                                             c
c         To dump a floatable file.                                    c
c----------------------------------------------------------------------c
        INCLUDE '3duparms.cb'
        INCLUDE '3dgeom.cb'
        INCLUDE '3dpoints.cb'
        REAL 	toplayer(MAXXRES, MAXYRES)
        INTEGER	x, y, pos, count, recpos, n0
        REAL	mass, out, rn

        pos=1
        count=0
        read(19,REC=3) rn
        n0=int(rn)
        read(19,REC=n0) mass
        INQUIRE(UNIT=19, NEXTREC=n0)
        recpos=n0
        DO 300 WHILE (pos.le.(numX*resXY*numY*resXY))
        	x=mod(pos-1, (numX*resXY))+1
        	y=((pos-1)/(numX*resXY))+1
        	mass=toplayer(x,y)
        	IF (mass.eq.0.0) THEN
        		count=count+1
        	ELSE
        		IF (count.ne.0) THEN
        			out=(-1.0)*count
        			WRITE(19, REC=recpos) out
        			recpos=recpos+1
        			count=0
        		ENDIF
        		WRITE(19, REC=recpos) mass
        		recpos=recpos+1
        	END IF
        	pos=pos+1
300	END DO
        IF (count.ne.0) THEN
        	out=(-1.0)*count
        	WRITE(19, REC=recpos) out
        	recpos=recpos+1
        END IF
        write(19, REC=4) float(numviews)
        write(19, REC=4+numviews) float(n0)
        write(19, REC=3) float(recpos-1)
        read(19, REC=recpos-1) mass
        RETURN
        END


c -----------------------------------------------------------------------------

        FUNCTION dilution_scale(mass)
        INCLUDE	'3duparms.cb'
        INCLUDE	'3dgeom.cb'
        REAL 	mass, dil
        BYTE	dilution_scale

        IF (abs(mass).le.1.0e-6) THEN
        	dilution_scale=0
        	RETURN
        END IF
        dil=c_init*((dimXY/resXY)**2*(dimZ/resZ))/mass
        IF (dil.lt.dlevel(1)) THEN
           dilution_scale=1
        ELSE
           IF (dil.lt.dlevel(2)) THEN
              dilution_scale=2
           ELSE
              IF (dil.lt.dlevel(3)) THEN
        	 dilution_scale=3
              ELSE
        	 IF (dil.lt.dlevel(4)) THEN
        	    dilution_scale=4
        	 ELSE
        	    IF (dil.lt.dlevel(5)) THEN
        	       dilution_scale=5
        	    ELSE
        	       dilution_scale=6
        	    END IF
                 END IF
              END IF
           END IF
        END IF
        RETURN
        END
        
c -----------------------------------------------------------------------------

        FUNCTION concentration_scale(mass)
        INCLUDE	'3duparms.cb'
        INCLUDE	'3dgeom.cb'
        REAL 	mass, con
        BYTE	concentration_scale

        con=1.0e-4*mass/((dimXY/resXY)**2*(dimZ/resZ))
        IF (con.le.1.0e-5) THEN
        	concentration_scale=0
        	RETURN
        END IF
        IF (con.gt.clevel(5)) THEN
           concentration_scale=1
        ELSE
           IF (con.gt.clevel(4)) THEN
              concentration_scale=2
           ELSE
              IF (con.gt.clevel(3)) THEN
        	 concentration_scale=3
              ELSE
        	 IF (con.gt.clevel(2)) THEN
        	    concentration_scale=4
        	 ELSE
        	    IF (con.gt.clevel(1)) THEN
        	       concentration_scale=5
        	    ELSE
        	       concentration_scale=6
        	    END IF
                 END IF
              END IF
           END IF
        END IF
        RETURN
        END
        
c -------------------------------------------------------------------
c ---------------- Encode Graphics Subroutine ----------------------
c ------------------------------------------------------------------

        SUBROUTINE encodegraphics(stream,nc,pv,el,MAXXRES,MAXYRES,
     1                            MAXZRES)
        INCLUDE '3dgeom.cb'
        INCLUDE '3dpoints.cb'
        BYTE    pv(MAXXRES,MAXYRES,2)
        BYTE    el(MAXYRES,MAXZRES,2)
        INTEGER x, y, z, count, stream, nc, n0, n
        BYTE c, c1

        n=62
c	print*,'Call 3, Stream =',stream
        call in4bytes(n0,n,stream)
        read(stream,rec=n0) c
        INQUIRE(stream, NEXTREC=viewpoint(stream-20))

c	Planview
        x=1
        y=1
        c=pv(x,y,nc)
        count=0                            !should be 1 BUG
        x=x+1
        DO 200 WHILE (y.le.numY*resXY)
        	c1=pv(x,y,nc)
        	IF (c.eq.c1) THEN
        		count=count+1
        	ELSE
        		CALL grout(stream,c,count)
        		count=0            !should be 1 BUG
        		c=c1
        	END IF
        	x=x+1
        	IF (x.gt.numX*resXY) THEN
        		x=1
        		y=y+1
        	END IF
200	END DO
        IF (count.ne.0) THEN
        	CALL grout(stream,c,count)
        END IF

c	Elevation.
        y=1
        z=1
        c=el(y,z,nc)
        count=0
        z=z+1
        DO 300 WHILE (y.le.numY*resXY)
        	c1=el(y,z,nc)
        	IF (c.eq.c1) THEN
        		count=count+1
        	ELSE
        		CALL grout(stream,c,count)
        		count=0
        		c=c1
        	END IF
        	z=z+1
        	IF (z.gt.numZ*resZ) THEN
        		z=1
        		y=y+1
        	END IF
300	END DO
        IF (count.ne.0) THEN
             CALL grout(stream,c,count)
        END IF
        INQUIRE(stream, NEXTREC=n0)
        n=62
        call out4bytes(n0-1,n,stream)
        RETURN
        END

c -------------------------------------------------------------------
c ----------- Encode Double Graphics Subroutine ---------------------
c -------------------------------------------------------------------

        SUBROUTINE encodedoublegraphics(stream,tpv,bpv,MAXXRES,MAXYRES)
        INCLUDE '3dgeom.cb'
        INCLUDE '3dpoints.cb'
        BYTE    tpv(MAXXRES,MAXYRES)
        BYTE    bpv(MAXXRES,MAXYRES)
        INTEGER x, y, count, stream, n0, n
        BYTE c, c1

        n=62
c	print*,'Call 4, Stream =',stream
        call in4bytes(n0,n,stream)
        read(stream,rec=n0) c
        INQUIRE(stream, NEXTREC=viewpoint(stream-20))

c	Top Planview
        x=1
        y=1
        c=tpv(x,y)
        count=0
        x=x+1
        DO 200 WHILE (y.le.numY*resXY)
        	c1=tpv(x,y)
        	IF (c.eq.c1) THEN
        		count=count+1
        	ELSE
        		CALL grout(stream,c,count)
        		count=0
        		c=c1
        	END IF
        	x=x+1
        	IF (x.gt.numX*resXY) THEN
        		x=1
        		y=y+1
        	END IF
200	END DO
        IF (count.ne.0) THEN
        	CALL grout(stream,c,count)
        END IF

c	Bottom Planview
        x=1
        y=1
        c=bpv(x,y)
        count=0
        x=x+1
        DO 300 WHILE (y.le.numY*resXY)
        	c1=bpv(x,y)
        	IF (c.eq.c1) THEN
        		count=count+1
        	ELSE
        		CALL grout(stream,c,count)
        		count=0
        		c=c1
        	END IF
        	x=x+1
        	IF (x.gt.numX*resXY) THEN
        		x=1
        		y=y+1
        	END IF
300	END DO
        IF (count.ne.0) THEN
        	CALL grout(stream,c,count)
        END IF
        INQUIRE(stream, NEXTREC=n0)
        n=62
        call out4bytes(n0-1,n,stream)
        RETURN
        END

c -------------------------------------------------------------------

        SUBROUTINE grout(stream,c,count)
        BYTE c, b
        INTEGER count, stream
        INTEGER i1, i2, i3, i4, s, n

        IF (count.le.15) THEN
           s=128+8*count+c
           b=s-128
           INQUIRE(stream,NEXTREC=n)
           WRITE(stream,REC=n) b   
        ELSE
           i4=count/(256**3)
           i3=(count-i4*256**3)/256**2
           i2=(count-i4*256**3-i3*256**2)/256
           i1=count-i4*256**3-i3*256**2-i2*256
           s=c
           if (i4.gt.0) s=s+64
           if (i3.gt.0) s=s+32
           if (i2.gt.0) s=s+16
           if (i1.gt.0) s=s+8
           INQUIRE(stream,NEXTREC=n)
           b=s-128
           WRITE(stream,REC=n) b
           n=n+1
           if (i4.gt.0) then
                b=i4-128
                WRITE(stream,REC=n) b
                n=n+1          
           end if
           if (i3.gt.0) then
                b=i3-128
                WRITE(stream,REC=n) b
                n=n+1
           end if
           if (i2.gt.0) then
                b=i2-128
                WRITE(stream,REC=n) b
                n=n+1          
           end if
           if (i1.gt.0) then
                b=i1-128
                WRITE(stream,REC=n) b
                n=n+1
           end if
        END IF
        RETURN
        END

c --------------------------------------------------------------------
c ---Subroutine for reading a 4 byte (pos) integer to stream 1--------
c --------------------------------------------------------------------

       SUBROUTINE in4bytes(i,n,stream)
       INTEGER i,n,stream
       BYTE    b
       INTEGER i1, i2, i3, i4

       READ(stream,REC=n) b
       n=n+1
       i1=b+128
       READ(stream,REC=n) b
       n=n+1
       i2=b+128
       READ(stream,REC=n) b
       n=n+1
       i3=b+128
       READ(stream,REC=n) b
       n=n+1
       i4=b+128
       i=(i4*256**3)+(i3*256**2)+(i2*256)+i1
       RETURN
       END

c --------------------------------------------------------------------
c ---Subroutine for writing a 4 byte (pos) integer to stream 1--------
c --------------------------------------------------------------------

        SUBROUTINE out4bytes(i,n,stream)
        INTEGER	stream, i, n
        BYTE	b
        INTEGER	i1, i2, i3, i4

        i4=i/(256**3)
        i3=(i-i4*256**3)/256**2
        i2=(i-i4*256**3-i3*256**2)/256
        i1=i-i4*256**3-i3*256**2-i2*256
        b=i1-128
        WRITE(stream,REC=n) b
        n=n+1
        b=i2-128
        WRITE(stream,REC=n) b
        n=n+1
        b=i3-128
        WRITE(stream,REC=n) b
        n=n+1
        b=i4-128
        WRITE(stream,REC=n) b
        n=n+1
        RETURN
        END



c-----------------------------------------------------------particles_c
        subroutine particles_c(cord,nply,nump,no_p,no_p_time,ppm,
     *                                             no_poly,pe,pn,pa,pm)
c---------------------------------------------------------------------c
c purpose:                                                            c
c         To count particles in a convex polygon.                     c
c---------------------------------------------------------------------c
c input parameters:                                                   c
c         no_poly -- number of polygons                               c
c       nply(1,i) -- number of nodes in polygon i                     c
c       nply(2,i) -- starting point of connectivity data              c
c                    in array nump(k)                                 c
c            nump -- polygon connectivity data                        c
c       cord(3,1) -- finite element nodal coordinates                 c
c           pe,pn -- current location of the particle                 c
c              pa -- life of the particle                             c
c              pm -- mass of the particle                             c
c---------------------------------------------------------------------c
c output parameters:                                                  c
c         no_p(i) -- number of particles in polygon i                 c
c          ppm(i) -- total mass in polygon i                          c
c  no_p_time(i,k) -- number of particles in polygon i and hour k      c
c---------------------------------------------------------------------c
        include '3duparms.cb'
        real    cord(3,1),ppm(1)
        real    pe,pn,pa,pm
        integer nply(2,1),nump(1),no_p(1),no_p_time(no_poly,1)
        real*8  area,ass
c
        do i=1,no_poly
           do j=1,nply(1,i)-1
              i1=nply(2,i)+j-1
              i2=nply(2,i)+j
              x13=cord(1,nump(i1))-pe
              y13=cord(2,nump(i1))-pn
              x23=cord(1,nump(i2))-pe
              y23=cord(2,nump(i2))-pn
              ass=x13*y23
              area=ass-x23*y13
              if(area.lt.-0.1e-2*dabs(ass)) goto 20
           enddo
           no_p(i)=no_p(i)+1
           ppm(i)=ppm(i)+pm
           k=int((pa-dt)/3600)+1
           no_p_time(i,k)=no_p_time(i,k)+1
   20   enddo
        return
        end