C***** RDPTGRP c subroutine rdptgrp(ndate,ttime,igroup,numcls,emscls,izcel) use filunit use grid use camxcom use ptemiss use tracer c c c Copyright 1996 - 2018 c Ramboll c c c----CAMx v7Beta6 190902 c c c----------------------------------------------------------------------- c LOG: c----------------------------------------------------------------------- c c 08/18/99 --gwilson-- Added code to implement the override c flag for the source area of point sources c 10/24/01 Removed BSWAP and converted integer strings to character*4 c 07/05/02 Changed to account for new type of the PiG flag c 05/01/03 Time span of emissions must now match emiss update interval c 09/25/03 Significant changes to handle PSAT c 03/01/16 Fixed bug in point source override and compact ptsrce file c c----------------------------------------------------------------------- c Include files: c----------------------------------------------------------------------- c include 'camx.prm' include 'flags.inc' c c----------------------------------------------------------------------- c Argument declarations: c----------------------------------------------------------------------- c integer ndate real ttime integer igroup integer numcls real emscls(MXTRCLS,*) integer izcel(*) c c----------------------------------------------------------------------- c Local variables: c----------------------------------------------------------------------- c character*200 fname character*4 iname(10) integer ibgdat, iendat, iounit, idx, iseg, idxfile integer npoint, ispc, i, idum, idxcp, idcompact(MXPTSRC) integer num_ptsfiles, idxbase real bgtim, edtim, rdum logical lfound c integer izcel_in(MXPTSRC) real emspts_in(MXPTSRC) real emspts(MXPTSRC) c c----------------------------------------------------------------------- c Entry point: c----------------------------------------------------------------------- c c --- skip if filename not supplied --- c num_ptsfiles = num_iortpt(igroup) if( igroup .EQ. 0 ) num_ptsfiles = npoint_files do idxfile=1,num_ptsfiles if( .NOT. ltptfl(igroup,idxfile) ) cycle c c --- set the unit number for file --- c if( igroup .EQ. 0 ) then if( is_netcdf_iptem(idxfile) ) cycle iounit = iptem(idxfile) write(fname,'(A,I3)') 'PTSOURCE -- UNIT ',iptem(idxfile) do i=1,nspcpt(igroup,idxfile) backspace(iounit) enddo backspace(iounit) backspace(iounit) backspace(iounit) else if( is_netcdf_iortpt(igroup,idxfile) ) cycle iounit = iortpt(igroup,idxfile) fname = tptfil(igroup,idxfile) endif c c --- gary wants this flush --- c call flush(6) c c --- read the date and time, again --- c lfound = .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 RDPTGRP:' 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 c c --- read the number of points and point locations --- c read(iounit,ERR=7000) iseg, npoint if( npoint .LE. 0 ) cycle read(iounit,ERR=7000,END=7001) (idcompact(i), idum, & izcel_in(i), rdum, rdum,i=1,npoint) do i=1,npoint idxcp = i if( lcompactpt(igroup,idxfile) ) idxcp = idcompact(i) idxbase = idx_point_in_list(igroup,idxfile,idxcp) izcel(idxbase) = izcel_in(i) enddo c c --- read the emissions for this hour --- c do 10 ispc=1,nspcpt(igroup,idxfile) read(iounit,ERR=7000,END=7001) iseg, (iname(i),i=1,10), & (emspts_in(i),i=1,npoint) c c --- if date and time does not match this hour, skip this record --- c if( le1day ) then if( bgtim .NE. ttime ) goto 10 else if( ndate .NE. ibgdat .OR. bgtim .NE. ttime ) goto 10 endif lfound = .TRUE. c c --- if the species is a not modelled or not a tracer species skip it --- c idx = idxpts(igroup,idxfile,ispc) if( idx .LE. 0 ) goto 10 if( .NOT. lusespc(idx) ) goto 10 c c --- convert to PPM (PPMC) ---- c do i=1,npoint idxcp = i if( lcompactpt(igroup,idxfile) ) idxcp = idcompact(i) emspts(idxcp) = emspts_in(i)/(60.*dtems) c c --- load into the tracer emissions array --- c do 20 icls=1,ntrcls c c --- if this is the NOx emissions tracer and this is a c PiG source, skip it (PiG treated elsewhere) --- c c --- gary wants this call to flush --- c call flush(6) if( lpigsa(idxcp) ) goto 20 idxbase = idx_point_in_list(igroup,idxfile,idxcp) emscls(icls,idxbase) = emscls(icls,idxbase) + & emspts(idxcp) * trspmap(idx,icls) 20 continue enddo c c --- next species --- c 10 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 cycle 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) read(iounit) read(iounit) goto 111 else goto 7001 endif cycle enddo goto 9999 c 7000 continue write(iout,'(//,a)') 'ERROR in RDPTGRP:' write(iout,'(/,1X,A,I8.5,F8.1,2A)') & 'Reading emissions after hour ',ibgdat, bgtim,' in file: ', & fname(:istrln(fname)) call camxerr() c 7001 continue write(iout,'(//,a)') 'ERROR in RDPTGRP:' write(iout,'(/,1X,3A)') 'Premature end-of-file reading ', & 'emissions from file: ',fname(:istrln(fname)) call camxerr() c 7002 continue write(iout,'(//,a)') 'ERROR in RDPTGRP:' write(iout,'(/,1X,A,I10,2A)') 'Number of points: ',npoint, & ' is not consistent with regular emissions in file: ', & fname(:istrln(fname)) call camxerr() c 9999 continue c return end