subroutine rdpthdr(begtim,begdate,endtim,enddate) use filunit use grid use chmstry use bndary use ptemiss use tracer c c----CAMx v7Beta6 190902 c c RDPTHDR reads the header of binary point source emissions file, c initializes time-invariant point source variables, and maps the point c source species list to the internal CAMx species list c c Copyright 1996 - 2018 c Ramboll c c Modifications: c 10/24/01 Removed BSWAP and converted integer strings to character*4 c 11/06/01 Input dates are now Julian c 02/09/02 Added code to handle end of year dates c 12/21/13 Added compact point source file c 12/07/14 Revised for VBS emissions c 01/08/16 Updated for Revised VBS emissions c 11/22/17 Added checks for PFE/PMN/PK/PCA/PMG emissions (disabled) c c Input arguments: c begtim model start time (HHMM) c begdate model start date (YYJJJ) c endtim model end time (HHMM) c enddate model end date (YYJJJ) c c Output arguments: c c Routines Called: c none c c Called by: c PNTPREP c include 'camx.prm' include 'flags.inc' include 'vbs.inc' c integer begdate integer enddate c character*10 ptfil, infil, ptspc, ptcompact character*4 ifile(10), note(60) c character*4 ptspec(10,MXSPEC) c logical l_exist_ivoc, l_exist_poa_xx integer ifle c integer, parameter :: num_elem = 5 integer :: idx_elem(num_elem) integer, allocatable, dimension(:) :: idxpnt integer idx_start c data ptfil /'PTSOURCE '/ data ptcompact /'PTSOURCECP'/ c c-----Entry point c c-----Initialize the mapping array --- c do ifle=1,npoint_files c c-----skip if this is a NetCDF file --- c if( is_netcdf_iptem(ifle) ) cycle c c-----Read 1st PT header record and check inputs c rewind(iptem(ifle)) read(iptem(ifle)) ifile,note,nseg,nptspc(ifle),idat1,tim1,idat2,tim2 allocate( idxpnt(nptspc(ifle)) ) c if(INT(tim2) .EQ. 24) then tim2 = 0. idat2 = idat2 + 1 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 write(infil,'(10a1)') (ifile(n),n=1,10) if (infil.ne.ptfil .AND. infil .ne. ptcompact) then write(iout,'(//,a)') 'ERROR in RDPTHDR:' write(iout,*)'PT input file is not labelled PTSOURCE or PTSOURCECP' call camxerr() endif tim1 = 100.*tim1 tim2 = 100.*tim2 if (idat1.gt.begdate) then write(iout,'(//,a)') 'WARNING in RDPTHDR:' write(iout,*)'PT start date > simulation start date' write(iout,*)' PT file: ',idat1 write(iout,*)'Sim start: ',begdate if (.not.le1day) then write(iout,*)'CAMx expecting day-specific emissions: Stopping' call camxerr() endif elseif (idat1.eq.begdate .and. tim1.gt.begtim) then write(iout,'(//,a)') 'WARNING in RDPTHDR:' write(iout,*)'PT start time > simulation start time' write(iout,*)' PT file: ',tim1 write(iout,*)'Sim start: ',begtim call camxerr() elseif (idat2.lt.enddate) then write(iout,'(//,a)') 'WARNING in RDPTHDR:' write(iout,*)'PT end date < simulation end date' write(iout,*)'PT file: ',idat2 write(iout,*)'Sim end: ',enddate if (.not.le1day) then write(iout,*)'CAMx expecting day-specific emissions: Stopping' call camxerr() endif elseif (idat2.eq.enddate .and. tim2.lt.endtim) then write(iout,'(//,a)') 'ERROR in RDPTHDR:' write(iout,*)'PT end time < simulation end time' write(iout,*)'PT file: ',tim2 write(iout,*)'Sim end: ',endtim call camxerr() endif c c-----Read 2nd PT header c read(iptem(ifle)) orgx,orgy,izone,utmx,utmy,dx,dy,nx,ny,nz c c-----Read 3rd & 4th PT header c read(iptem(ifle)) read(iptem(ifle)) ((ptspec(n,l),n=1,10),l=1,nptspc(ifle)) c c-----Map PT species to model species c if (lvbs .and. LVBSPREPROC) then ! assign fake positive idx to count all the primary VBS spc in do l = 0, NVOLBIN lemmap(kpap_c(l)) = nptspc(ifle) + 1 lemmap(kpfp_c(l)) = nptspc(ifle) + 1 enddo l_exist_ivoc = .false. l_exist_poa_xx = .false. endif do 15 lpt = 1,nptspc(ifle) write(ptspc,'(10a1)') (ptspec(n,lpt),n=1,10) if (ptspc.eq.'HNO2 ') ptspc = 'HONO ' if (ptspc.eq.'HCHO ' .and. kHCHO.eq.nspec+1) & ptspc = 'FORM ' cgwilson if (lvbs .and. LVBSPREPROC) then cgwilson if (ptspc.eq.'IVOA ' .or. cgwilson & ptspc.eq.'IVOB ') l_exist_ivoc = .true. cgwilson if (ptspc.eq.'POA_OP ') then cgwilson l_exist_poa_xx = .true. cgwilson lemmap(kpap_c(0)) = lpt ! temporarily assign to PAP0 cgwilson write(idiag,'(a,i5,2x,2a)') 'Point source species ', cgwilson & lpt,ptspc,' mapped to model species PAP0-PAP5 (VBS)' cgwilson goto 15 cgwilson endif cgwilson if (ptspc.eq.'POA_BB ') then cgwilson l_exist_poa_xx = .true. cgwilson lemmap(kpfp_c(0)) = lpt ! temporarily assign to PFP0 cgwilson write(idiag,'(a,i5,2x,2a)') 'Point source species ', cgwilson & lpt,ptspc,' mapped to model species PFP0-PFP5 (VBS)' cgwilson goto 15 cgwilson endif cgwilson endif c c --- check if species is not modelled --- idxpnt(lpt) = 0 do 20 l = 1,nspec if (ptspc.eq.spname(l)) then idxpnt(lpt) = l write(idiag,'(2(a,i5,2x,a))') & 'Point source species ',lpt,ptspc, & ' mapped to model species ',l,spname(l) goto 15 endif 20 continue write(idiag,*)'PT species: ',ptspc,' not modeled' 15 continue c c----Find this species in master list --- c do lpt=1,nptspc(ifle) idxpnt_files(ifle,lpt) = 0 if( idxpnt(lpt) .LE. 0 ) cycle write(ptspc,'(10a1)') (ptspec(n,lpt),n=1,10) do k=1,nemspc if(ptspc .EQ. emspcname(k) ) then idxpnt_files(ifle,lpt) = k endif enddo if( idxpnt_files(ifle,lpt) .EQ. 0 ) then nemspc = nemspc + 1 emspcname(nemspc) = ptspc idxpnt_files(ifle,lpt) = nemspc endif lemmap(idxpnt(lpt)) = idxpnt_files(ifle,lpt) enddo c cgwilson if (lvbs .and. LVBSPREPROC) then cgwilson if ( .not.l_exist_ivoc .or. .not.l_exist_poa_xx ) then cgwilson write(iout,'(//,a)') 'ERROR in RDPTHDR:' cgwilson write(iout,'(2A)')'Point source species are not compatible', cgwilson & ' with VBS.' cgwilson write(iout,'(2A)')'VBS requires IVOC and sector-specific', cgwilson & ' POA emissions.' cgwilson call camxerr() cgwilson endif cgwilson endif c c-----Read time invariant data (assume nseg=1) c check number of sources against max c read(iptem(ifle)) idum,nptsrc_files(ifle) if( allocated(idxpnt) ) deallocate( idxpnt ) enddo c c-----Allocate the arrays --- c allocate( xloc(nptsrc) ) allocate( yloc(nptsrc) ) c c----Call routine to allocate the arrays c call alloc_ptemiss(nspec,ngrid,nptsrc) c c --- read rest of each file --- c do ifle=1,npoint_files c c-----skip if this is a NerCDF file --- c if( is_netcdf_iptem(ifle) ) cycle idx_start = idx_start_pts(ifle) read(iptem(ifle)) (xloc(n),yloc(n),hstk(n),dstk(n),tstk(n), & vstk(n),n=idx_start+1,idx_start+nptsrc_files(ifle)) do 30 n = idx_start+1,idx_start+nptsrc_files(ifle) if (dstk(n).lt.0.) then lpiglet(n) = .true. c dstk(n) = -dstk(n) else lpiglet(n) = .false. endif vstk(n) = vstk(n)/3600. c c========================= Source Apportion End ======================== c 30 continue enddo write(idiag,*) c return end