c----------------------------------------------------------------RWALK_3D program RWALK_3D c-----------------------------------------------------------------------c c Purpose: c c RWALK_3D - Random Walk Model c c-----------------------------------------------------------------------c include '3duparms.cb' include '3dpolls.cb' include '3dgeom.cb' include '3dmesh.cb' include '3dpoints.cb' include 'rise_fall.cb' parameter (ntotal=50000000) character fname*100,buff*100,partl*100,fltnam*100 character plmnam*100,cext*5 real r integer t,NUMPARTS,max_numps,v_time logical flipflag,restout,existing integer numxx(50),numyy(50),numzz(50),resxyy(50),reszz(50) real goee(50),gonn(50),gass(50),gacc(50),dimxyy(50),dimzz(50) common /mgird/goee,gonn,gass,gacc,numxx,numyy,numzz,dimxyy, * dimzz,resxyy,reszz common /dbsys/numa,next,idir,ipp(3) common /etype/inode(4) common /randm/isd, isd1 common /iolist/ntm,ntr,nin,not,nsp,nfl,nt7,nt8,nt9,nt10, * nt11,nt12,nt13,nt14,nt15,nt16,nt17,nt18,nt19 common mtot,npp,ia(ntotal) integer isd, isd1 integer ADAY,AYEAR,AMONTH,ATIME,EGDS,EGDF data inode/10,15,20,13/ data isd/0/, isd1/0/ data y0f/10.6/, y1f/-11.34/, y0r/1.5951/, y1r/-0.97525/ data rf/30.0/, rr/5.0/ c write(*,'(a)') '-----------------------------------------------' write(*,'(a)') '--- ---' write(*,'(a)') '--- 3D_RWALK Version 2.2 ---' write(*,'(a)') '--- 06/08/96 ---' write(*,'(a)') '--- ---' write(*,'(a)') '--- Y.C. Wang & B. Miller ---' write(*,'(a)') '--- Water Research Lab. U.N.S.W. ---' write(*,'(a)') '--- Compiled with ifort 12/7/07 ---' write(*,'(a)') '--- ---' write(*,'(a)') '-----------------------------------------------' c------------------------------------------------------------------ c Use Defined variables to echo where and when this program was compiled c added to code by AF 12/8/04 c c WRITE(*,'(2A)') 'This program was compiled in: ' c 1 ,PATH c WRITE(*,'(2A)') ' with filename : ' c 1 ,__FILE__ c WRITE(*,'(2A)') 'It was compiled on : ' c 1 ,__DATE__ c WRITE(*,'(2A)') ' at time : ' c 1 ,__TIME__ c c IF (INDEX c 1 (PATH,'/wrlnmr/') c 2 .eq.0) THEN c PRINT *,'This is not being run from the QA area' c ELSE c PRINT*, 'This is being run from the QA area' c ENDIF c c print *,'Running the program' c---------------------------------------------------------------- mtot=ntotal idir=mtot call setcst c c-------open required files c c 21 : output stream for RWD graphics file c 22 : output stream for RWC graphics file c 23 : output stream for RWZ graphics file c 9 : geometry file c 2 : RMA10 velocity file c 3 : input user parameters file c 4 : input pollutants file c 7 : input open-boundary file c 8 : input hard-boundary file c 10 : input restart file c 11 : output restart file c 19 : Floatable Bin Dump file c 20 : Plume Bin Dump file c 30 : settling particles file c 35 : particle tracking path file c 36 : particle counting file c WRITE(*,*) ' Enter start-stamp (yyyymmddhhmm): ' READ(*,'(A12)') start_stamp WRITE(*,'(A18,A12,A1)') ' START STAMP is "',start_stamp,'"' WRITE(*,*) fname='920820' call askstr(' Enter output graphics filename',fname) partl=fname dimopt='10' call askstr(' Enter RMA-2 or RMA-10 option',dimopt) if(dimopt(1:2).eq.'10') then fname='sydney.3dg' call askstr(' Enter 3d geometry filename',fname) open(9,file=fname,status='old',form='unformatted',err=10) fname='sydney.res' call askstr(' Enter RMA-10 velocity filename',fname) open(2,file=fname,status='old',form='unformatted',err=10) else fname='sydney.geo' call askstr(' Enter 2D geometry filename',fname) open(9,file=fname,status='old',form='unformatted',err=10) buff='1.0,1.0' call askstr(' Enter scales in x and y directions',buff) read(buff,*) xscale,yscale fname='sydney.res' call askstr(' Enter RMA-2 velocity filename',fname) open(2,file=fname,status='old',form='unformatted',err=10) endif fname='usrparam.rw' call askstr(' Enter user parameters filename',fname) open(3,file=fname,status='old',form='formatted',err=10) fname='polls' call askstr(' Enter pollutants filename',fname) open(4,file=fname,status='old',form='formatted',err=10) fname='no' call askstr(' Enter open boundary filename',fname) if(fname(1:1).ne.'n'.and.fname(1:1).ne.'N') then open(7,file=fname,status='old',form='formatted',err=10) rewind 7 openbd=.true. else openbd=.false. endif fname='no' call askstr(' Enter input restart filename',fname) if(fname(1:1).ne.'n'.and.fname(1:1).ne.'N') then open(10,file=fname,status='unknown',form='unformatted',err=10) restart=.true. else restart=.false. endif fname='no' call askstr(' Enter output restart filename',fname) if(fname(1:1).ne.'n'.and.fname(1:1).ne.'N') then open(11,file=fname,status='unknown',form='unformatted',err=10) restout=.true. else restout=.false. endif fname='no' CALL askstr(' Enter Floatables Bin-Dump filename',fname) fltnam=fname if(fname(1:1).ne.'n'.and.fname(1:1).ne.'N') then fbindump=.TRUE. else fbindump=.false. endif fname='no' CALL askstr(' Enter Plumes Bin-Dump filename',fname) plmnam=fname if(fname(1:1).ne.'n'.and.fname(1:1).ne.'N') then do itemp=1,50 pbindump(itemp)=.TRUE. enddo else do itemp=1,50 pbindump(itemp)=.false. enddo endif c print*,plmnam,'pbindump=',pbindump(1) fname='no' CALL askstr(' Enter settleable particles filename',fname) if(fname(1:1).ne.'n'.and.fname(1:1).ne.'N') then inquire(file=fname(1:lenstr(fname)),EXIST=existing) if(existing) then open(30,file=fname(1:lenstr(fname)),status='old') close(30,status='delete') endif OPEN(30,FILE=fname, ACCESS='direct', 1 STATUS='new',FORM='unformatted',RECL=8, ERR=10) settles=.TRUE. rr=-1.0 rf=100.0 y0f=y0f*100.0/30.0 y1f=y1f*100.0/30.0 else settles=.false. endif fname='no' CALL askstr(' Enter particle tracking path filename',fname) if(fname(1:1).ne.'n'.and.fname(1:1).ne.'N') then inquire(file=fname(1:lenstr(fname)),EXIST=existing) if(existing) then open(35,file=fname(1:lenstr(fname)),status='old') close(35,status='delete') endif ctmp OPEN(35,FILE=fname, ACCESS='direct', ctmp 1 STATUS='new',FORM='unformatted',RECL=8, ERR=10) OPEN(35,FILE=fname, 1 STATUS='new',FORM='formatted',ERR=10) tracking=.TRUE. else tracking=.false. endif goto 20 10 len0=lnblnk(fname) write(6,'(a)') '*** File: '''//fname(1:len0)//''' not found ***' stop c c-------read data c 20 write(*,'(/a/)') 'Loading the user parameters ...' call getusrparams print *,'plumeonly,floatableonly=',plumeonly,floatableonly call echoallparameters write(*,'(/a/)') 'Loading the geometry of FE mesh ...' rewind 9 read(9) np,ne rewind 9 call defini('nop ',nnop ,10,ne+4) call defini('ilst',nilst,1,ne/2+4) call defini('imat',nimat,1,ne/2+4) call definr('cord',ncord,3,7*np) !leave more space for 2D case call definr('ao ',nao ,2,7*np+12) call defini('nsur',nnsur,1,np*7/2+12) call definr('widt',nwidt,1,np*7+12) c BMM extra line for diffusivities call definr('difs',ndifs,2,ne+4) print *,'np=',np,npm,ne call getgeometry(ia(ncord),ia(nnop),ia(nnsur),ia(nimat), & ia(nwidt),ia(nao),ia(nilst),ia(ndifs)) print *,'np=',np,npm,ne call refinr('cord',ncord,3,np+800) !leave some space for polygon call refinr('ao ',nao ,2,np+4) call refini('nsur',nnsur,1,np/2+4) call refinr('widt',nwidt,1,np+4) call refinr('difs',ndifs,2,ne+4) c c-------calculate the day of year DAYOFY c if(dieoffc) then READ(start_stamp,'(I4,2I2,I4)') ISY, ISM, ISD, IST RMIN=-outputTS/60 CALL TINC2(IST,ISD,ISM,ISY,ATIME,ADAY,AMONTH,AYEAR,RMIN,IER,0) call gdate(1,AMONTH,ADAY,AYEAR,IDWK,IDYR,IDMON,EGDF,IER,0) call gdate(1,1,1,AYEAR,IDWK,IDYR,IDMON,EGDS,IER,0) DAYOFY=EGDF-EGDS+1 TOFDAY=int(ATIME/100)+mod(ATIME,100)/60.0 call DIEOFFS(0.0,DAYOFY,T90_D) c print *,'T90_D=',T90_D T90_D=3600.0*T90_D endif print *,'Euler=',euler call defini('nply',nnply,2,1000) call defini('nump',nnump,1,10000) call getareaparams(ia(nnply),ia(nnump),ia(ncord),np,no_poly, & nlengthp) print *,'no_poly,nlengthp=',no_poly,nlengthp call refini('nump',nnump,1,nlengthp) call refini('nply',nnply,2,no_poly) call defini('no_p',nno_p,1,no_poly) call definr('ppm ',nppm ,1,no_poly) c c-------create an array storing number of particles in specified area with c time tag c mlp=tot_dead_age/3600+2 call defini('nopt',nnopt,no_poly,mlp) if(p_count) then fname=partl(1:lenstr(partl))//'.par' CALL askstr(' Enter particle counting filename',fname) inquire(file=fname(1:lenstr(fname)),EXIST=existing) if(existing) then open(36,file=fname(1:lenstr(fname)),status='old') close(36,status='delete') endif OPEN(36,FILE=fname, 1 STATUS='new',FORM='formatted', ERR=10) write(36,'(a)') ' Start_stamp='//start_stamp write(36,'(a,i15)') ' outputTS=',outputTS write(36,'(a,i15)') 'tot_dead_age=',tot_dead_age write(36,'(a,i15)') 'No. of Areas=',no_poly endif write(*,'(/a/)') 'Loading the pollutant windows ...' read(4,*) poll_type,num_pollwins call definr('pwin',npwin,4,num_pollwins) call definr('masA',nmasA,1,num_pollwins) call getpollwins(ia(npwin),ia(nmasA)) c c-------divide FE elements into blocks c nx=2 ny=5 nz=1 nxyz=nx*ny*nz call defini('ityp',nityp,1,ne) call definr('ebox',nebox,6,ne) call definr('egrp',negrp,6,nxyz) call defini('nbeg',nnbeg,1,nxyz) call defini('nend',nnend,1,nxyz) call defini('nelg',nnelg,3,ne) call definr('egps',negps,6,2000) call defini('nbb ',nnbb ,1,2000) call defini('nee ',nnee ,1,2000) call defini('nblk',nnblk,2,2000) call defini('nelb',nnelb,1,1) call blocks(nx,ny,nz,np,ne,ia(nnop),ia(ncord),nxyz,ia(negrp), * ia(nnbeg),ia(nnend),ia(nnelg),ia(nnbb),ia(nnee),ia(nnelb), * ia(nnblk),ia(negps),ia(nityp),ia(nebox),m,num) call refini('nelb',nnelb,1,num) call delete('nelg') call delete('nbeg') call delete('nend') call refinr('egrp',negrp,6,nxyz) call refinr('egps',negps,6,m) call refini('nbb ',nnbb ,1,m) call refini('nee ',nnee ,1,m) call refini('nblk',nnblk,2,m) call locate('nelb',nnelb,mlt,num) c c-------read open boundaries c if(openbd) then read(7,*) no_open call definr('opbd',nopbd,4,no_open) call getopenbound(no_open,ia(nopbd)) endif call bcname c c-------setup boundary conditions c c c-------main program loop c write(*,*) 'Start the walking ...' no_settles=1 NUMPARTS=0 max_numpsA=0 max_numpsB=0 write(*,'(/a/)') 'Loading velocity field ...' call definr('Avel',nAvel,3,np) call definr('Bvel',nBvel,3,np) call definr('vel ',nvel ,3,np) call definr('dudt',ndudt,3,np) call definr('dhdt',ndhdt,1,np) call definr('wsel',nwsel,1,np) call definr('wsl1',nwsl1,1,np) call defini('ic ',nic ,1,np/2+4) call definr('Apol',nApol,4,num_pollwins) call definr('Bpol',nBpol,4,num_pollwins) call definr('poll',npoll,4,num_pollwins) call definr('pdot',npdot,1,num_pollwins) call definr('masp',nmasp,1,num_pollwins) call clearr(ia(npdot),1,num_pollwins) call clearr(ia(ndhdt),1,np) c c-------initialise dudt(3,np) c if(.not.Euler) then call clearr(ia(ndudt),3,np) endif c c-------skip the first pollutant release for hot start c if(.not.psteadystate.and.restart) then call getpollconditions(ia(nApol),ia(nmasp),ia(nmasA), * NUMPARTS,max_numpsA,keyp) if(keyp.eq.0) goto 50 endif call getflowconditions(ia(nnsur),ia(nAvel),ia(ncord), * ia(nao),ia(nwsel),ia(nwsl1),ia(nic), * ia(ndhdt),ia(nnop),ia(nilst),keyf) call getpollconditions(ia(nApol),ia(nmasp),ia(nmasA), * NUMPARTS,max_numpsA,keyp) if(keyf.eq.0.or.keyp.eq.0) goto 50 if(.not.restart) then if(.not.hsteadystate) then call getflowconditions(ia(nnsur), * ia(nBvel),ia(ncord),ia(nao),ia(nwsel),ia(nwsl1), * ia(nic),ia(ndhdt),ia(nnop),ia(nilst),keyf) if(keyf.eq.0) goto 50 else nBvel=nAvel endif if(.not.psteadystate) then call getpollconditions(ia(nBpol),ia(nmasp),ia(nmasA), * NUMPARTS,max_numpsB,keyp) if(keyp.eq.0) goto 50 else nBpol=nApol max_numpsB=max_numpsA endif endif flipflag=.FALSE. max_numps=max(max_numpsA,max_numpsB) print *,'no_grids=',no_grids do m=1,no_grids if(no_grids.eq.1) then cext=' ' else write(cext,'(i2.2)') m endif inquire(file=partl(1:lenstr(partl))//'.rwd'//cext(1:2), * EXIST=existing) if(existing) then open(21,file=partl(1:lenstr(partl))//'.rwd'//cext(1:2), * status='old') close(21,status='delete') endif open(21,file=partl(1:lenstr(partl))//'.rwd'//cext(1:2), * access='direct',status='new',form='unformatted',recl=1) inquire(file=partl(1:lenstr(partl))//'.rwc'//cext(1:2), * EXIST=existing) if(existing) then open(22,file=partl(1:lenstr(partl))//'.rwc'//cext(1:2), * status='old') close(22,status='delete') endif open(22,file=partl(1:lenstr(partl))//'.rwc'//cext(1:2), * access='direct',status='new',form='unformatted',recl=1) inquire(file=partl(1:lenstr(partl))//'.rwz'//cext(1:2), * EXIST=existing) if(existing) then open(23,file=partl(1:lenstr(partl))//'.rwz'//cext(1:2), * status='old') close(23,status='delete') endif open(23,file=partl(1:lenstr(partl))//'.rwz'//cext(1:2), * access='direct',status='new',form='unformatted',recl=1) goE=goee(m) goN=gonn(m) gaS=gass(m) gaC=gacc(m) numX=numxx(m) numY=numyy(m) numZ=numzz(m) dimXY=dimxyy(m) dimZ=dimzz(m) resXY=resxyy(m) resZ=reszz(m) call addoutputheader(21) call addoutputheader(22) call addoutputheader(23) close(21) close(22) close(23) IF (pbindump(m)) THEN inquire(file=plmnam(1:lenstr(plmnam))//cext(1:2), * EXIST=existing) if(existing) then open(20,file=plmnam(1:lenstr(plmnam))//cext(1:2), * status='old') close(20,status='delete') endif c BMM 070810 Addition of another file type for storing the bin file data OPEN(37,FILE=plmnam(1:lenstr(plmnam))//'-block'//cext(1:2), 1 STATUS='unknown',FORM='unformatted') OPEN(20,FILE=plmnam(1:lenstr(plmnam))//cext(1:2), cdrc 1 ACCESS='direct',STATUS='new',FORM='unformatted',RECL=1) 1 ACCESS='direct',STATUS='new',FORM='unformatted',RECL=4) r=FLOAT(numX*resXY) WRITE(20,REC=1) r r=FLOAT(numY*resXY) WRITE(20,REC=2) r r=FLOAT(numZ*resZ) WRITE(20,REC=3) r r=float(4+maxoutputs) WRITE(20,REC=3) int(r) WRITE(20,REC=4) 0.0 WRITE(20,REC=4+maxoutputs) 0.0 close(20) ENDIF IF (fbindump) THEN inquire(file=fltnam(1:lenstr(fltnam))//cext(1:2), * EXIST=existing) if(existing) then open(19,file=fltnam(1:lenstr(fltnam))//cext(1:2), * status='old') close(19,status='delete') endif OPEN(19,FILE=fltnam(1:lenstr(fltnam))//cext(1:2), cdrc 1 ACCESS='direct',STATUS='new',FORM='unformatted',RECL=1) 1 ACCESS='direct',STATUS='new',FORM='unformatted',RECL=4) r=FLOAT(numX*resXY) WRITE(19,REC=1) r r=FLOAT(numY*resXY) WRITE(19,REC=2) r r=float(4+maxoutputs) WRITE(19,REC=3) r WRITE(19,REC=4) 0.0 WRITE(19,REC=4+maxoutputs) 0.0 close(19) ENDIF enddo if(settles) write(30,rec=1) no_settles,mass_pp if(restart) then rewind 10 read(10) NUMPARTS endif call defini('prtI',nprtI,1,NUMPARTS+1) call definr('prtE',nprtE,1,NUMPARTS+1) call definr('prtN',nprtN,1,NUMPARTS+1) call definr('prtZ',nprtZ,1,NUMPARTS+1) call definr('prtM',nprtM,1,NUMPARTS+1) call definr('prtA',nprtA,1,NUMPARTS+1) call definr('prtV',nprtV,1,NUMPARTS+1) c c-------read data for restart c if(restart) then call inputRS(NUMPARTS,max_numps,ia(nprtI),ia(nprtE), * ia(nprtN),ia(nprtZ),ia(nprtM),ia(nprtA),ia(nprtV),ia(nBvel), * ia(nwsl1),ia(nBpol),ia(nmasA)) flipflag=.true. endif v_time=0 !sum of dtnew until newcondTS t_p=0 !sum of time until termination do i=1,maxoutputs t=0 c c----------estimate the maximum number of particles released c max_num=max_numps+NUMPARTS call refini('prtI',nprtI,1,max_num) call refinr('prtE',nprtE,1,max_num) call refinr('prtN',nprtN,1,max_num) call refinr('prtZ',nprtZ,1,max_num) call refinr('prtM',nprtM,1,max_num) call refinr('prtA',nprtA,1,max_num) call refinr('prtV',nprtV,1,max_num) c c----------unsteady case c if(.not.hsteadystate.or.(.not.psteadystate)) then 30 if(flipflag) then call walkem(ia(ncord),ia(nnop),ia(nityp),ia(nebox), * ia(nBvel),ia(nAvel),ia(nvel),ia(ndudt),ia(nao),nxyz, * ia(negrp),ia(negps),ia(nnblk),ia(nnelb),ia(nnbb), * ia(nnee),ia(nBpol),ia(nApol),ia(npoll),ia(npdot), * ia(nmasp),ia(npwin),ia(nprtE),ia(nprtN),ia(nprtZ), * ia(nprtI),ia(nprtM),ia(nprtA),ia(nprtV),ia(nopbd), * no_open,NUMPARTS,t,t_p,v_time,ia(ndifs)) if(v_time.eq.newcondTS) then v_time=0 if(.not.hsteadystate) then call getflowconditions(ia(nnsur), * ia(nBvel),ia(ncord),ia(nao),ia(nwsel),ia(nwsl1), * ia(nic),ia(ndhdt),ia(nnop),ia(nilst),keyf) endif if(.not.psteadystate) then call getpollconditions(ia(nBpol),ia(nmasp), * ia(nmasA),NUMPARTS,max_numpsB,keyp) endif flipflag=.FALSE. if(max_numps.lt.max_numpsB) then max_num=max_num + max_numpsB - max_numps max_numps=max_numpsB call refini('prtI',nprtI,1,max_num) call refinr('prtE',nprtE,1,max_num) call refinr('prtN',nprtN,1,max_num) call refinr('prtZ',nprtZ,1,max_num) call refinr('prtM',nprtM,1,max_num) call refinr('prtA',nprtA,1,max_num) call refinr('prtV',nprtV,1,max_num) endif endif else call walkem(ia(ncord),ia(nnop),ia(nityp),ia(nebox), * ia(nAvel),ia(nBvel),ia(nvel),ia(ndudt),ia(nao),nxyz, * ia(negrp),ia(negps),ia(nnblk),ia(nnelb),ia(nnbb), * ia(nnee),ia(nApol),ia(nBpol),ia(npoll),ia(npdot), * ia(nmasp),ia(npwin),ia(nprtE),ia(nprtN),ia(nprtZ), * ia(nprtI),ia(nprtM),ia(nprtA),ia(nprtV),ia(nopbd), * no_open,NUMPARTS,t,t_p,v_time,ia(ndifs)) if(v_time.eq.newcondTS) then v_time=0 if(.not.hsteadystate) then call getflowconditions(ia(nnsur), * ia(nAvel),ia(ncord),ia(nao),ia(nwsel),ia(nwsl1), * ia(nic),ia(ndhdt),ia(nnop),ia(nilst),keyf) endif if(.not.psteadystate) then call getpollconditions(ia(nApol),ia(nmasp), * ia(nmasA),NUMPARTS,max_numpsA,keyp) endif flipflag=.TRUE. if(max_numps.lt.max_numpsA) then max_num=max_num + max_numpsA - max_numps max_numps=max_numpsA call refini('prtI',nprtI,1,max_num) call refinr('prtE',nprtE,1,max_num) call refinr('prtN',nprtN,1,max_num) call refinr('prtZ',nprtZ,1,max_num) call refinr('prtM',nprtM,1,max_num) call refinr('prtA',nprtA,1,max_num) call refinr('prtV',nprtV,1,max_num) endif endif endif if(t.lt.outputTS) then if(.not.hsteadystate.and.keyf.eq.0) goto 35 if(.not.psteadystate.and.keyp.eq.0) goto 35 goto 30 endif c c----------steady-state case c else call walkem(ia(ncord),ia(nnop),ia(nityp),ia(nebox), * ia(nAvel),ia(nAvel),ia(nAvel),ia(ndudt),ia(nao),nxyz, * ia(negrp),ia(negps),ia(nnblk),ia(nnelb),ia(nnbb), * ia(nnee),ia(nApol),ia(nApol),ia(nApol),ia(npdot), * ia(nmasp),ia(npwin),ia(nprtE),ia(nprtN),ia(nprtZ), * ia(nprtI),ia(nprtM),ia(nprtA),ia(nprtV),ia(nopbd), * no_open,NUMPARTS,t,t_p,v_time,ia(ndifs)) endif c c----------output graphics c 35 call refini('prtI',nprtI,1,NUMPARTS) call refinr('prtE',nprtE,1,NUMPARTS) call refinr('prtN',nprtN,1,NUMPARTS) call refinr('prtZ',nprtZ,1,NUMPARTS) call refinr('prtM',nprtM,1,NUMPARTS) call refinr('prtA',nprtA,1,NUMPARTS) call refinr('prtV',nprtV,1,NUMPARTS) if(.not.settles.and.t.eq.outputTS) then do m=1,no_grids if(no_grids.eq.1) then cext=' ' else write(cext,'(i2.2)') m endif open(21,file=partl(1:lenstr(partl))//'.rwd'//cext(1:2), * access='direct',status='old',form='unformatted',recl=1) open(22,file=partl(1:lenstr(partl))//'.rwc'//cext(1:2), * access='direct',status='old',form='unformatted',recl=1) open(23,file=partl(1:lenstr(partl))//'.rwz'//cext(1:2), * access='direct',status='old',form='unformatted',recl=1) if(fbindump) then OPEN(19,FILE=fltnam(1:lenstr(fltnam))//cext(1:2), cdrc 1 ACCESS='direct',STATUS='old',FORM='unformatted',RECL=1) 1 ACCESS='direct',STATUS='old',FORM='unformatted',RECL=4) endif c print*,plmnam,'pbindump=',pbindump(m) if(pbindump(m)) then OPEN(20,FILE=plmnam(1:lenstr(plmnam))//cext(1:2), crdc 1 ACCESS='direct',STATUS='old',FORM='unformatted',RECL=1) 1 ACCESS='direct',STATUS='old',FORM='unformatted',RECL=4) endif goE=goee(m) goN=gonn(m) gaS=gass(m) gaC=gacc(m) numX=numxx(m) numY=numyy(m) numZ=numzz(m) dimXY=dimxyy(m) dimZ=dimzz(m) resXY=resxyy(m) resZ=reszz(m) call outputgraphicscodes(m) c print*,'here' call addpointers(21) c print*,'here2' call addpointers(22) call addpointers(23) close(21) close(22) close(23) if(fbindump) close(19) if(pbindump(m)) close(20) enddo endif if(.not.hsteadystate.and.keyf.eq.0) goto 40 if(.not.psteadystate.and.keyp.eq.0) goto 40 enddo 40 if(settles) write(30,rec=1) no_settles,mass_pp call bcname c c-------output restart file c if(restout) then if(hsteadystate.and.psteadystate) then call outputRS(NUMPARTS,max_numps,ia(nprtI),ia(nprtE), * ia(nprtN),ia(nprtZ),ia(nprtM),ia(nprtA),ia(nprtV),ia(nAvel), * ia(nwsl1),ia(nApol),ia(nmasA)) elseif(flipflag) then call outputRS(NUMPARTS,max_numps,ia(nprtI),ia(nprtE), * ia(nprtN),ia(nprtZ),ia(nprtM),ia(nprtA),ia(nprtV),ia(nAvel), * ia(nwsl1),ia(nApol),ia(nmasA)) else call outputRS(NUMPARTS,max_numps,ia(nprtI),ia(nprtE), * ia(nprtN),ia(nprtZ),ia(nprtM),ia(nprtA),ia(nprtV),ia(nBvel), * ia(nwsl1),ia(nBpol),ia(nmasA)) endif endif 50 close(2) close(3) close(4) close(9) if(restart) close(10) if(restout) close(11) if(settles) close(30) stop end c----------------------------------------------------------------outputRS subroutine outputRS(NUMPARTS,max_numps,partI,partE,partN,partZ, * partM,partA,partV,vel,wsel1,poll,masspA) c-----------------------------------------------------------------------c c Purpose: c c To output neccessary data for restart. c c-----------------------------------------------------------------------c include '3dpolls.cb' include '3dmesh.cb' integer NUMPARTS,max_numps,i,j integer partI(1) real partE(1),partN(1),partZ(1),partM(1),partA(1),partV(1) real poll(4,1),vel(3,1),wsel1(1),masspA(1) c rewind 11 write(11) NUMPARTS,max_numps,(partI(i),i=1,NUMPARTS),(partE(i), 1 i=1,NUMPARTS),(partN(i),i=1,NUMPARTS),(partZ(i),i=1, 2 NUMPARTS),(partM(i),i=1,NUMPARTS),(partA(i),i=1, 3 NUMPARTS),(partV(i),i=1,NUMPARTS),((vel(j,i),j=1,3), 4 wsel1(i),i=1,np),((poll(j,i),j=1,4),i=1,num_pollwins), 5 (masspA(i),i=1,num_pollwins) return end c-----------------------------------------------------------------inputRS subroutine inputRS(NUMPARTS,max_numps,partI,partE,partN,partZ, * partM,partA,partV,vel,wsel1,poll,masspA) c-----------------------------------------------------------------------c c Purpose: c c To input neccessary data for restart. c c-----------------------------------------------------------------------c include '3dpolls.cb' include '3dmesh.cb' integer NUMPARTS,max_numps,i,j integer partI(1) real partE(1),partN(1),partZ(1),partM(1),partA(1),partV(1) real poll(4,1),vel(3,1),wsel1(1),masspA(1) c rewind 10 read(10) NUMPARTS,max_numps,(partI(i),i=1,NUMPARTS),(partE(i), 1 i=1,NUMPARTS),(partN(i),i=1,NUMPARTS),(partZ(i),i=1, 2 NUMPARTS),(partM(i),i=1,NUMPARTS),(partA(i),i=1, 3 NUMPARTS),(partV(i),i=1,NUMPARTS),((vel(j,i),j=1,3), 4 wsel1(i),i=1,np),((poll(j,i),j=1,4),i=1,num_pollwins), 5 (masspA(i),i=1,num_pollwins) return end