c***** EMPREPSA c subroutine emprepsa(idate,btim,igrid) use filunit use grid use chmstry use ptemiss use tracer c c----CAMx v7Beta6 190902 c c----------------------------------------------------------------------- c Description: c----------------------------------------------------------------------- c c This routine reads the source group emissions files and moves the c file pointer to the first hour to be used in this run. Each point c source and surace emissions files respresenting a source group is c read. c c Copyright 1996 - 2018 c Ramboll c c----------------------------------------------------------------------- c LOG: c----------------------------------------------------------------------- c c----------------------------------------------------------------------- c Include files: c----------------------------------------------------------------------- c include 'camx.prm' include 'flags.inc' c c----------------------------------------------------------------------- c Arguement declarations: c----------------------------------------------------------------------- c integer idate real btim integer igrid c c----------------------------------------------------------------------- c Local parameters: c----------------------------------------------------------------------- c integer MXOUT parameter (MXOUT = MAX(MXSPEC,MXTRSP)) c c----------------------------------------------------------------------- c External functions: c----------------------------------------------------------------------- c integer fnd_point c c----------------------------------------------------------------------- c Local variables: c----------------------------------------------------------------------- c character*200 fname character*10 namein, cfile character*4 ifname(10), ifnote(60) integer ifile, nseg, nspect, igroup integer ispc, ibgdat, iendat integer idateb, idatee, nxcelt, nycelt, nzceltm npts_in_list integer idum, izonet, iounit, isegm, npoint, idxpt_base integer i, j, ndate, seg4(4), idxfile, num_emsfiles, num_ptsfiles real tutmx, tutmy, tdxcel, tdycel real tbegti, tendti, begtim, endtim, dum real txorig, tyorig, ttime, tdummy c character*4 iname(10,MXOUT) real txloc (MXPTSRC) real tyloc (MXPTSRC) real tstkhgt(MXPTSRC) real tstkdiam(MXPTSRC) real tstktemp(MXPTSRC) c logical, allocatable, dimension(:) :: source_is_in_SA c common /comemprepsa/ txloc, tyloc, tstkhgt, tstkdiam, tstktemp c c----------------------------------------------------------------------- c Entry point: c----------------------------------------------------------------------- c c --- allocate array for checking list --- c if( .NOT. allocated(source_is_in_SA) ) & allocate( source_is_in_SA(nptsrc) ) xlocpt = xloc ylocpt = yloc idx_last_found = 1 c c --- set the date and time --- c ndate = idate ttime = btim/100 if( ttime .EQ. 24.0 ) then ndate = ndate + 1 ttime = 0. if( MOD(ndate,1000) .GT. 365 ) then if( MOD(INT(ndate/1000),4) .EQ. 0 ) then if( MOD(ndate,1000) .EQ. 367 ) & ndate = (INT(ndate/1000)+1)*1000 + 1 else ndate = (INT(ndate/1000)+1)*1000 + 1 endif endif endif c c --- initialize the flag for PiG sources --- c if( igrid .EQ. 1 ) then do i=1,nptsrc lpigsa(i) = .FALSE. enddo endif c c --- initialize postion zero, which is for the model emissions ---- c do idxfile=1,nemiss_files(igrid) if( larsrc .AND. ltrace ) then ltemfl(igrid,0,idxfile) = .TRUE. else ltemfl(igrid,0,idxfile) = .FALSE. endif enddo do idxfile=1,npoint_files if( lptsrc .AND. ltrace ) then ltptfl(0,idxfile) = .TRUE. else ltptfl(0,idxfile) = .FALSE. endif enddo c c --- loop over the source grouping files ---- c do 10 igroup=0,ngroup num_emsfiles = num_iortem(igrid,igroup) if( igroup .EQ. 0 ) num_emsfiles = nemiss_files(igrid) do 11 idxfile=1,num_emsfiles c c --- only read if surface emissions file is supplied --- c if( larsrc ) then if( igroup .EQ. 0 ) then if( is_netcdf_iarem(igrid,idxfile)) cycle iounit = iarem(igrid,idxfile) write(fname,'(A,I3)') 'EMISSIONS -- UNIT ', & iarem(igrid,idxfile) else if( is_netcdf_iortem(igrid,igroup,idxfile)) cycle iounit = iortem(igrid,igroup,idxfile) fname = temfil(igrid,igroup,idxfile) endif c c --- rewind the file ---- c rewind(iounit,ERR=7005) c c --- read the header of the emissions file --- c read(iounit,ERR=7000) ifname, ifnote, nseg, nspect, & idateb, tbegti, idatee, tendti if( nspect .GT. MXTRSP ) then write(iout,'(//,A)') 'ERROR in EMPREPSA:' write(iout,*) 'A parameter in the camx.prm is not ', & 'sufficiently large.' write(iout,*) & 'Please change the value for parameter: MXTRSP' write(iout,*) 'It should be set to a value of at least: ', & nspect call flush(iout) call camxerr() endif c read(iounit,ERR=7000) tutmx, tutmy, izonet, txorig, & tyorig, tdxcel, tdycel, nxcelt, nycelt, nzcelt read(iounit,ERR=7000) seg4 read(iounit,ERR=7000) & ((iname(i,ispc),i=1,10),ispc=1,nspect) c c --- set up index for species names --- c nspcem(igrid,igroup,idxfile) = nspect do 20 ispc=1,nspcem(igrid,igroup,idxfile) write(namein,'(10A1)') (iname(i,ispc),i=1,10) if(namein .EQ.'HNO2 ') namein = 'HONO ' if(namein .EQ.'HCHO ' .AND. kHCHO .eq. nspec+1 ) & namein = 'FORM ' do j=1,nspec if(namein .EQ. spname(j) ) then idxems(igrid,igroup,idxfile,ispc) = j goto 20 endif enddo 20 continue c c --- read the data until the correct position in the file is reached --- c 111 continue read(iounit,ERR=7002,END=7003) ibgdat, begtim, & iendat, endtim if(NINT(endtim) .EQ. 0) then endtim = 24. iendat = iendat - 1 endif if( le1day ) then if( INT(begtim*100) .EQ. INT(ttime*100) ) goto 222 else if( ibgdat .EQ. ndate .AND. & INT(begtim*100) .EQ. INT(ttime*100) ) goto 222 endif do ispc=1,nspcem(igrid,igroup,idxfile) read(iounit,ERR=7002,END=7003) idum, & (dum,i=1,10),((dum,i=1,ncol(igrid)),j=1,nrow(igrid)) enddo goto 111 222 continue backspace(iounit) endif 11 continue c c --- point sources are only for the coarse grid -- grid #1 --- c if( igrid .GT. 1 ) cycle c c --- only read if elevated point source emissions file is supplied --- c num_ptsfiles = num_iortpt(igroup) if( igroup .EQ. 0 ) then num_ptsfiles = npoint_files npts_in_list = 0 endif do idxfile=1,num_iortpt(igroup) source_is_in_SA = .FALSE. if( ltptfl(igroup,idxfile) .AND. lptsrc ) then if( igroup .EQ. 0 ) then if( is_netcdf_iptem(idxfile) ) cycle iounit = iptem(idxfile) write(fname,'(A,I3)') 'PTSOURCE -- UNIT ',iptem(idxfile) else if( is_netcdf_iortpt(igroup,idxfile) ) cycle iounit = iortpt(igroup,idxfile) fname = tptfil(igroup,idxfile) endif c c --- rewind the file ---- c rewind(iounit,ERR=7005) c c --- read the header of the emissions file --- c read(iounit,ERR=7000) ifname, ifnote, nseg, nspect, & idateb, tbegti, idatee, tendti if( nspect .GT. MXTRSP ) then write(iout,'(//,A)') 'ERROR in EMPREPSA:' write(iout,*) 'A parameter in the camx.prm is not ', & 'sufficiently large.' write(iout,*) & 'Please change the value for parameter: MXTRSP' write(iout,*) 'It should be set to a value of at least: ', & nspect call flush(iout) call camxerr() endif c c --- check to see if this is a compact file --- c write(cfile,'(10A1)') ifname lcompactpt(igroup,idxfile) = .FALSE. if( cfile .EQ. 'PTSOURCECP' ) lcompactpt(igroup,idxfile) = .TRUE. c read(iounit,ERR=7000) tutmx, tutmy, izonet, txorig, & tyorig, tdxcel, tdycel, nxcelt, nycelt, nzcelt read(iounit,ERR=7000) seg4 read(iounit,ERR=7000) & ((iname(i,ispc),i=1,10),ispc=1,nspect) c c --- set up index for species names --- c nspcpt(igroup,idxfile) = nspect do 30 ispc=1,nspcpt(igroup,idxfile) write(namein,'(10A1)') (iname(i,ispc),i=1,10) if(namein .EQ.'HNO2 ') namein = 'HONO ' if(namein .EQ.'HCHO ' .AND. kHCHO .eq. nspec+1 ) & namein = 'FORM ' do j=1,nspec if(namein .EQ. spname(j) ) then idxpts(igroup,idxfile,ispc) = j goto 30 endif enddo 30 continue read(iounit,ERR=7000) isegm, npoint if( npoint .GT. MXPTSRC ) then write(iout,'(//,A)') 'ERROR in RDPTDDM:' write(iout,*) 'A parameter in the camx.prm is not ', & 'sufficiently large.' write(iout,*) & 'Please change the value for parameter: MXPTSRC' write(iout,*) 'It should be set to a value of at least: ', & npoint call flush(iout) call camxerr() endif c read(iounit,ERR=7002) (txloc(i),tyloc(i),tstkhgt(i),tstkdiam(i), & tstktemp(i),tdummy,i=1,npoint) do i=1,npoint c c --- make sure this source is in the base inventory and flag it --- c if(igroup .GT. 0 ) then idxpt_base = fnd_point(txloc(i),tyloc(i),tstkhgt(i), & tstkdiam(i),tstktemp(i),source_is_in_SA) if(idxpt_base .LE. 0 ) then goto 7004 else source_is_in_SA(idxpt_base) = .TRUE. idx_point_in_list(igroup,idxfile,i) = idxpt_base endif else idxpt_base = i + npts_in_list idx_point_in_list(igroup,idxfile,i) = idxpt_base endif if( ipigflg .EQ. GRESPIG .AND. tstkdiam(i) .LT. 0. ) & lpigsa(i) = .TRUE. enddo c c --- read the data until the correct position in the file is reached --- c 333 continue read(iounit,ERR=7002,END=7003) ibgdat, begtim, & iendat, endtim if(NINT(endtim) .EQ. 0) then endtim = 24. iendat = iendat - 1 endif if( le1day ) then if( INT(begtim*100) .EQ. INT(ttime*100) ) goto 444 else if( ibgdat .EQ. ndate .AND. & INT(begtim*100) .EQ. INT(ttime*100) ) goto 444 endif read(iounit,ERR=7002) isegm, npoint read(iounit,ERR=7002) (idum,idum,idum,dum,dum,i=1,npoint) do ispc=1,nspcpt(igroup,idxfile) read(iounit,ERR=7002,END=7003) idum,(dum,i=1,10), & (dum,i=1,npoint) enddo goto 333 444 continue backspace(iounit) c endif if( igroup .EQ. 0 ) npts_in_list = npts_in_list + npoint enddo 10 continue c c ---- return to calling routine --- c goto 9999 c c----------------------------------------------------------------------- c Error messages: c----------------------------------------------------------------------- c 7000 continue write(iout,'(//,A)') 'ERROR in EMPREPSA:' write(iout,'(1X,3A)') 'Reading header of ', & 'emissions file: ',fname(:istrln(fname)) call camxerr() c 7002 continue write(iout,'(//,A)') 'ERROR in EMPREPSA:' write(iout,'(1X,2A)') 'Reading emissions grid in file: ', & fname(:istrln(fname)) call camxerr() c 7003 continue write(iout,'(//,A)') 'ERROR in EMPREPSA:' write(iout,'(1X,3A)') 'Premature end-of-file reading ', & 'emissions file: ',fname(:istrln(fname)) write(iout,'(1X,A)') 'Make sure date/time matches the simulation ' write(iout,'(1X,A)') 'or turn on single emissions flag.' call camxerr() c 7004 continue write(iout,'(//,A)') 'ERROR in EMPREPSA:' write(iout,'(1X,2A,/,A)') 'Point source found in Source Apportionment ', & 'point source file is not found ',' in the base inventory.' write(iout,'(1X,2A)') ' File: ',fname(:istrln(fname)) write(iout,'(1X,A,I10)') ' Point ID: ',i call camxerr() c 7005 continue if( igroup .EQ. 0 ) then if( iarem(igrid,1) .GT. 0 ) then write(iout,'(//,A)') 'ERROR in EMPREPSA:' write(iout,'(1X,2A)') 'Cannot access emissions file', & ' provided for OSAT processing. ' write(iout,'(1X,2A)') 'If it is the same as the file ', & 'used for the regular model, you may have to make a ' write(iout,'(1X,A)')'copy and specify the name of the copy.' else write(iout,'(//,A)') 'ERROR in EMPREPSA:' write(iout,'(1X,2A)') 'Flexi-nesting the emissions inputs', & ' is not supported with a ' write(iout,'(1X,2A)') 'Probing Tools application.' write(iout,'(1X,2A)') 'You must supply an emissions file ', & 'for each grid.' endif else write(iout,'(//,A)') 'ERROR in EMPREPSA:' write(iout,'(1X,3A)') 'Cannot access emissions file', & ' provided for OSAT processing: ',fname(:istrln(fname)) endif call camxerr() c c----------------------------------------------------------------------- c Format statements: c----------------------------------------------------------------------- c c----------------------------------------------------------------------- c Return point: c----------------------------------------------------------------------- c 9999 continue deallocate( source_is_in_SA ) return end