c**** RDICRT.F c subroutine rdicrt(nox,noy,noz,nspsa,saconc) use filunit use grid use chmstry use bndary use camxcom use rtracchm use tracer c c----CAMx v7Beta6 190902 c c----------------------------------------------------------------------- c Description: c----------------------------------------------------------------------- c c This routine fils one hour of initial conditions for the RTRAC c species. It then places these concentrations in the appropriate c place in the gridded array used for tracer concentrations. c The values are left in PPM so that they can be interpolated to c the nests in a later step. c c Copyright 1996 - 2018 c Ramboll c c Argument description: c Outputs: c saconc R tracer concentrations c Inputs: c nox I number of X cells in the grid c noy I number of Y cells in the grid c noz I number of layers in the grid c nspsa I number of tracer species c c----------------------------------------------------------------------- c LOG: c----------------------------------------------------------------------- c c 01/21/02 --gwilson-- Original development c c----------------------------------------------------------------------- c Include files: c----------------------------------------------------------------------- c include 'camx.prm' include 'flags.inc' c c----------------------------------------------------------------------- c Arguement declarations: c----------------------------------------------------------------------- c integer nox integer noy integer noz integer nspsa real saconc(nox,noy,noz,nspsa) c c----------------------------------------------------------------------- c Local variables: c----------------------------------------------------------------------- c character*10 aqfil, cfile, cspec character*4 ifile(10), note(60), ispec(10) integer ispc, i, j, n integer iseg, nspc, idat1, idat2 integer izone, nx, ny, nz, ilay, idum, imod real tim1, tim2, orgx, orgy, utmx, utmy, dx, dy logical lexist, luse c real concic(MXCELLS,MXCELLS) c c----------------------------------------------------------------------- c Data statements: c----------------------------------------------------------------------- c data aqfil /'AIRQUALITY'/ c c----------------------------------------------------------------------- c Entry point: c----------------------------------------------------------------------- c c --- initailize to lower bound --- c do ispc=1,nspsa do k=1,noz do j=1,noy do i=1,nox saconc(i,j,k,ispc) = rtlbnd(ispc) enddo enddo enddo enddo c c --- if no IC file provided, then we are done --- c if( .NOT. licfil ) goto 9999 c c --- open the IC --- c inquire(file=icfil,exist=lexist) if( .NOT. lexist ) goto 7000 open(file=icfil,unit=ioric,status='UNKNOWN', & form='UNFORMATTED',ERR=7001) c c --- read 1st IC header record and check inputs --- c read(ioric,ERR=7002) ifile,note,iseg,nspc,idat1,tim1,idat2,tim2 if( INT(tim2) .EQ. 24 ) then idat2 = idat2 + 1 tim2 = 0. endif write(cfile,'(10A1)') (ifile(i),i=1,10) if( cfile .NE. aqfil ) goto 7003 tim1 = 100.*tim1 tim2 = 100.*tim2 if( idat1 .GT. begdate .AND. .NOT. le1day ) goto 7004 if( idat1 .EQ. begdate .AND. tim1 .GT. begtim & .AND. .NOT. le1day ) goto 7004 c c --- read 2nd IC header record and check inputs --- c read(ioric,ERR=7002) orgx,orgy,izone,utmx,utmy,dx,dy,nx,ny,nz if( .NOT. llatlon ) then dx = dx/1000. dy = dy/1000. endif if( nx .NE. ncol(1) .OR. ny .NE. nrow(1) & .OR. nz .NE. nlay(1) ) goto 7005 c c --- skip the next 2 records --- c read(ioric,ERR=7002) read(ioric,ERR=7002) c c --- read the date and time and make sure it is the correct hour --- c 111 continue read(ioric,ERR=7007,END=7006) idat1, tim1, idat2, tim2 tim1 = 100*tim1 tim2 = 100*tim2 if( INT(tim2) .EQ. 24 ) then idat2 = idat2 + 1 tim2 = 0. if( MOD(idat2,1000) .GT. 365 ) then if( MOD(INT(idat2/1000),4) .EQ. 0 ) then if( MOD(idat2,1000) .EQ. 367 ) & idat2 = (INT(idat2/1000)+1)*1000 + 1 else idat2 = (INT(idat2/1000)+1)*1000 + 1 endif endif endif if( (idat1 .LT. begdate .OR. & (idat1 .EQ. begdate .AND. tim1 .LE. begtim)) .AND. & (idat2 .GT. begdate .OR. & (idat2 .EQ. begdate .AND. tim2 .GT. begtim))) then c c --- read the concentrations for each species --- c do ispc=1,nspc c c --- loop over layers --- c do ilay=1,nz read(ioric) idum,(ispec(n),n=1,10), & ((concic(i,j),i=1,nx),j=1,ny) write(cspec,'(10A1)') ispec c c --- find this species in the RTRAC species list --- c luse = .FALSE. do imod=1,ntotsp if( cspec .EQ. ptname(imod) ) then luse = .TRUE. do 20 j=2,ny-1 do i=2,nx-1 if( concic(i,j) .GE. rtlbnd(imod) ) & saconc(i,j,ilay,imod) = concic(i,j) enddo 20 continue endif c c --- check the next modeled species --- c enddo c c --- if not found in model species list, write a message ---- c if( .NOT. luse .AND. ilay .EQ. 1) then write(idiag,'(1X,4A)') 'Species in RTRAC ', & 'initial conditions file: ',cspec(:istrln(cspec)), & ' not found in species list ... Skipping.' endif c c --- next layer --- c enddo c c --- read nect species worth of data --- c enddo c c --- if not the right hour, read through it --- c else do ispc=1,nspc do ilay=1,nz read(ioric,ERR=7007) enddo enddo goto 111 endif c c --- close the file and return to the calling routine --- c close(ioric) goto 9999 c c----------------------------------------------------------------------- c Error messages: c----------------------------------------------------------------------- c 7000 continue write(iout,'(//,A)') 'ERROR in RDICRT:' write(iout,*) 'ERROR: IC file for RTRAC does not exist: ', & icfil(:istrln(icfil)) call camxerr() c 7001 continue write(iout,'(//,A)') 'ERROR in RDICRT:' write(iout,*) 'ERROR: Opening IC file for RTRAC: ', & icfil(:istrln(icfil)) call camxerr() c 7002 continue write(iout,'(//,A)') 'ERROR in RDICRT:' write(iout,*)'ERROR: Reading header of IC file for RTRAC: ', & icfil(:istrln(icfil)) call camxerr() c 7003 continue write(iout,'(//,A)') 'ERROR in RDICRT:' write(iout,*) 'ERROR: IC input file for RTRAC is not labelled ', & 'AIRQUALITY.' call camxerr() c 7004 continue write(iout,'(//,A)') 'ERROR in RDICRT:' write(iout,*) 'ERROR: IC input file for RTRAC is not for ', & 'correct time period.' write(iout,*) ' *** Episode ***' write(iout,'(a,i10.5)') 'Date : ',begdate write(iout,'(a,f10.1)') 'Time : ',begtim write(iout,*) ' *** IC File ***' write(iout,'(a,i10.5)') 'Date : ',idat1 write(iout,'(a,f10.1)') 'Time : ',tim1 call camxerr() c 7005 continue write(iout,'(//,A)') 'ERROR in RDICRT:' write(iout,*) 'ERROR: IC input file does not appear to be for ', & ' the correct grid.' write(iout,*) ' *** Coarse Grid ***' write(iout,*) 'No. of Cells : (',ncol(1),',',nrow(1),')' write(iout,*) 'No. of layers: ',nlay(1) write(iout,*) ' *** IC File ***' write(iout,*) 'No. of Cells : (',nx,',',ny,')' write(iout,*) 'No. of layers: ',nz call camxerr() c 7006 continue write(iout,'(//,A)') 'ERROR in RDICRT:' write(iout,*) 'ERROR: Premature end-of-file reached in IC file ', & 'for RTRAC.' write(iout,*) 'Make sure the file contains the correct date/time.' call camxerr() c 7007 continue write(iout,'(//,A)') 'ERROR in RDICRT:' write(iout,*) 'ERROR: Reading IC file for RTRAC: ', & icfil(:istrln(icfil)) call camxerr() c c----------------------------------------------------------------------- c Format statements: c----------------------------------------------------------------------- c c----------------------------------------------------------------------- c Return point: c----------------------------------------------------------------------- c 9999 continue c return end