c***** RDPTDDM.F c subroutine rdptddm(ndate,ttime) use filunit use grid use chmstry use ptemiss use bndary use camxcom use tracer c c----CAMx v7Beta6 190902 c c c Copyright 1996 - 2018 c Ramboll c c----------------------------------------------------------------------- c c This routine reads one hour of emissions for the DDM process c and fills the approproate arrays. The emissions file for one grid c but each emissions groups is read. c Argument descriptions: c Outputs: c Inputs: c ndate I julian day of current hour c ttime R current hour c c----------------------------------------------------------------------- c LOG: c----------------------------------------------------------------------- c c 10/24/01 Removed BSWAP and converted integer strings to character*4 c 07/19/02 Added seperate source area map for each grids. c 05/01/03 Time span of emissions must now match emiss update interval c 07/16/07 -bkoo- Added HRVOC c 03/01/16 -gwilson- Added partial source area map c c----------------------------------------------------------------------- c Include files: c----------------------------------------------------------------------- c include 'camx.prm' include 'flags.inc' c c----------------------------------------------------------------------- c Argument declarations: c----------------------------------------------------------------------- c integer ndate real ttime c c----------------------------------------------------------------------- c Local variables: c----------------------------------------------------------------------- c character*200 fname character*10 cname character*4 iname(10) integer ibgdat, iendat, iounit, igroup, idx, iseg integer i, j, nedge, iptr, ispc, iddm, igrd integer icel, jcel, imap, npoint, idum, imod, izcel(MXPTSRC) integer idcompact(MXPTSRC), idxfile real bgtim, edtim, emstmp real xloccrs, yloccrs, xloctmp, yloctmp logical lfound, luse, lpass c real emspnt(MXPTSRC) c c----------------------------------------------------------------------- c Entry point: c----------------------------------------------------------------------- c c --- initialize emissions to zero --- c do i=1,nptsrc do j=1,ntotsp sapnts(i,j) = 0. enddo enddo c c --- set the number of BC edges -- c if( lbndry ) then nedge = 5 else nedge = 1 endif c c --- loop over all of the groups ---- c do 10 igroup=1,ngroup do idxfile=1,num_iortpt(igroup) c c --- skip if filename not supplied --- c if( is_netcdf_iortpt(igroup,idxfile) .OR. .NOT. & ltptfl(igroup,idxfile) .OR. .NOT. lptsrc ) goto 10 c c --- set the unit number for surface emissions file --- c iounit = iortpt(igroup,idxfile) fname = tptfil(igroup,idxfile) c c --- read the date and time, again --- c lfound = .FALSE. lpass = .FALSE. 111 continue read(iounit,END=222) ibgdat, bgtim, iendat, edtim ichktm1 = NINT( 1000*(bgtim) ) if( le1day ) then ichktm2 = NINT( 1000*(edtim) ) else ichktm2 = NINT( 1000*(edtim)+24000*(iendat-ibgdat) ) endif if( NINT(edtim) .EQ. 0 ) ichktm2 = 24000 ichkems = NINT( 1000*(dtems/60.) ) if( (ichktm2 - ichktm1) .NE. ichkems ) then write(iout,'(//,a)')'ERROR in RDPTDDM:' write(iout,*) 'Time interval in surface emissions file does' write(iout,*) ' not match emissions update time interval.' write(iout,*) ' Beginning Date/Time (HHMM): ',ibgdat,bgtim write(iout,*) ' Ending Date/Time (HHMM): ',iendat,edtim write(iout,*) ' Emiss Input interval (min): ',dtems call camxerr() endif if(NINT(edtim) .EQ. 0) then edtim = 24. iendat = iendat - 1 endif bgtim = bgtim*100.0 edtim = edtim*100.0 c c --- read the emissions for this hour --- c read(iounit,ERR=7000,END=7001) iseg, npoint c if( npoint .GT. nptsrc ) goto 7002 read(iounit,ERR=7000,END=7001) (idcompact(i), idum, & izcel(i), rdum, rdum,i=1,npoint) c do 20 ispc=1,nspcpt(igroup,idxfile) read(iounit,ERR=7000) iseg, (iname(i),i=1,10), & (emspnt(i),i=1,npoint) write(cname,'(10A1)') iname c c --- if date and time does not match this hour, skip this record --- c if( le1day ) then if( bgtim .NE. ttime ) goto 20 else if( ndate .NE. ibgdat .OR. bgtim .NE. ttime ) goto 20 endif lfound = .TRUE. c c --- if the species is a not modelled or not used for DDM ---- c idx = idxpts(igroup,idxfile,ispc) if( idx .LE. 0 ) goto 20 c c --- find this species in the modeled species list --- c luse = .FALSE. do imod=1,nspec if( cname .EQ. spname(imod) ) then do iddm=1,nemddm luse = .FALSE. if( emddmsp(iddm) .EQ. cname ) luse = .TRUE. if( emddmsp(iddm) .EQ. NAMALL ) luse = .TRUE. if( emddmsp(iddm) .EQ. NAMVOC & .AND. lvocsp(imod) ) luse = .TRUE. if( emddmsp(iddm) .EQ. NAMNOX & .AND. lnoxsp(imod) ) luse = .TRUE. if( emddmsp(iddm) .EQ. NAMHRV & .AND. lhrvoc(imod) ) luse = .TRUE. c c --- if this DDM species matches this modeled species, load it --- c if( luse ) then do 30 i=1,npoint idxcp = i if( lcompactpt(igroup,idxfile) ) idxcp = idcompact(i) if( llatlon ) then xloccrs = xlocpt(idxcp) - xorg yloccrs = ylocpt(idxcp) - yorg else xloccrs = xlocpt(idxcp)/1000. - xorg yloccrs = ylocpt(idxcp)/1000. - yorg endif icel = 1 + FLOOR( xloccrs/delx ) jcel = 1 + FLOOR( yloccrs/dely ) if( icel .LT. 1 .OR. icel .GT. ncol(1) ) & goto 30 if( jcel .LT. 1 .OR. jcel .GT. nrow(1) ) & goto 30 c c --- find out if a nest contains this source --- c igrd = 1 do ig = 2,ngrid xloctmp = xloccrs - (inst1(ig)-1)*delx yloctmp = yloccrs - (jnst1(ig)-1)*dely if( xloctmp .GT. 0. .AND. & yloctmp .GT. 0. ) then ii = 2 + FLOOR( xloctmp/delx * & FLOAT( meshold(ig) ) ) jj = 2 + FLOOR( yloctmp/dely * & FLOAT( meshold(ig) ) ) if( ii .GT. 1 .AND. jj .GT. 1 .AND. & ii .LT. ncol(ig) .AND. & jj .LT. nrow(ig) ) then igrd = ig icel = ii jcel = jj endif endif enddo c c --- get the region for this cell from mapping array ---- c imap = igrmap(0,1,igrd,icel,jcel) if( izcel(i) .LT. 0 ) then if( .NOT. lptoverride ) goto 7003 imap = ABS( izcel(i) ) endif if( imap .LE. 0 .OR. imap .GT. nregin ) & goto 30 c c --- convert to emissions time and put into array --- c emstmp = emspnt(i)/(60.*dtems) iptr = iptddm(imod) + nicddm + & nbcddm*nedge + (iddm-1)*ngroup*nregin + & (imap-1)*ngroup + igroup - 1 if( emstmp .GT. bdnl(imod) ) & sapnts(idxcp,iptr) = emstmp c c --- next point --- c 30 continue endif c c --- next DDM emssions species --- c enddo c c --- next modeled species --- c endif enddo c c --- next species --- c 20 continue c c --- if the correct hour has not been found, c go back and read some more else read next file --- c if( .NOT. lfound ) then goto 111 else do i=1,nspcpt(igroup,idxfile) + 3 backspace(iounit) enddo goto 10 endif c c --- if using 1 day emissions, we need to rewind the file to c get the current hour --- c 222 continue if( le1day ) then rewind(iounit) read(iounit) read(iounit) read(iounit) read(iounit) if( lpass ) goto 7001 if( .NOT. lpass ) lpass = .TRUE. goto 111 else goto 7001 endif c c --- get the next file --- c enddo 10 continue goto 9999 c c---------------------------------------------------------------------- c Error messages: c----------------------------------------------------------------------- c 7000 continue write(iout,'(//,a)')'ERROR in RDPTDDM:' write(iout,'(/,1X,2A,I8.5,F8.1,2A)') 'ERROR: Reading emissions ', & 'after hour ',ibgdat, bgtim,' in file: ',fname(:istrln(fname)) call camxerr() c 7001 continue write(iout,'(//,a)')'ERROR in RDPTDDM:' write(iout,'(/,1X,2A,I8.5,F8.1,2A)') & 'ERROR: Premature end-of-file', & ' in point source file after hour ',ibgdat, bgtim, & ' in file: ',fname(:istrln(fname)) call camxerr() c 7002 continue write(iout,'(//,a)') 'ERROR in RDPTDDM:' write(iout,'(/,1X,A,I10,2A)') 'Number of points: ',npoint, & ' exceeds max in file: ',fname(:istrln(fname)) write(iout,'(1X,2A,/,1X,A)') 'Make sure the Probing Tools ', & 'point source files are consistent with regular', & ' model file.' call camxerr() c 7003 continue write(iout,'(//,a)') 'ERROR in RDPTDDM:' write(iout,'(/,1X,2A )') 'A source was read that has the point ', & 'source override trigger turned on.' write(iout,'(1X,2A)') 'If you intend to use point source ', & 'override please set the namelist variable' write(iout,'(1X,2A)') 'DDM_PT_Override to TRUE in the CAMx_Control namelist.' write(iout,'(1X,2A)') 'If you do not want point source override ', & 'you need to set the kcell variable ' write(iout,'(1X,2A)') 'in your point source file to zero.' call camxerr() c c---------------------------------------------------------------------- c Return point: c----------------------------------------------------------------------- c 9999 continue c return end