c*** HDRWSA c subroutine hdrwsa(iounit,fname,ftype,nspcs,nzcell, & idate,btim,jdate,etim,spec_units,spec_long_name, & spec_desc,spec_coords) use filunit use grid use camxcom use camxfld use tracer use procan use ncf_iomod c c----CAMx v7Beta6 190902 c c----------------------------------------------------------------------- c Description: c This routine writes the header information to the output tracer c instantaneous files and tracer surface concentration files. c The data is written to the unit number in the argument list. c c Copyright 1996 - 2018 c Ramboll c c Argument description: c iounit I unit number of file to write c fname C name of file being written c ftype C file type of file being written c nspcs I number of species to write to file c nzcell I number of layers (will be 1 for surface file) c idate I beginning date of simulation (YYJJJ) c btim R beginning time of simulation c jdate I ending date of simulation (YYJJJ) c etim R ending time of simulation c spec_units C array of units for this each species c spec_long_name C array of "long names" for each each species c spec_desc C array of desciption for this each species c spec_coords C array of coordinates for this each species c c----------------------------------------------------------------------- c LOG: c----------------------------------------------------------------------- c 1/20/99 Grid cell size on file should be meters for all c cartesian projections (UTM, LCP, PSP) c 10/24/01 Removed BSWAP and converted integer strings to character*4 c 11/06/01 Input dates are now Julian c 8/25/06 Surface output files now all UAM format, one file per grid c 1/04/11 Revised for new header format c c----------------------------------------------------------------------- c Include files: c----------------------------------------------------------------------- c include 'flags.inc' c c----------------------------------------------------------------------- c Argument declarations: c----------------------------------------------------------------------- c integer iounit(*) character*(*) fname(*) character*10 ftype integer nspcs integer nzcell integer idate real btim integer jdate real etim character*20 spec_units(*) character*20 spec_long_name(*) character*60 spec_desc(*) character*60 spec_coords(*) c c----------------------------------------------------------------------- c Local variables: c----------------------------------------------------------------------- c character*200 action character*10 ncf_filtype character*4 ifile(10), note(60), ispec(10,MXTRSP) integer i, j, ndate, ndlast, izero, ione, num_dims real ttime, ttlast, zero, factr real xorgf, yorgf, dxf, dyf logical lwrite_file c c----------------------------------------------------------------------- c Data statements: c----------------------------------------------------------------------- c data zero /0.0/ data izero /0/ data ione /1/ c c----------------------------------------------------------------------- c Entry point: c----------------------------------------------------------------------- c if( tectyp .EQ. SA ) then ncf_filtype = "SA" else if( tectyp .EQ. DDM .OR. tectyp .EQ. HDDM ) then ncf_filtype = "DDM" else if( tectyp .EQ. RTRAC .OR. tectyp .EQ. RTCMC ) then ncf_filtype = "RTRAC" else ncf_filtype = "CPA" endif ndate = idate ndlast = jdate ttime = AINT(ANINT(btim)/100.) + amod(ANINT(btim),100.)/60. ttlast = AINT(ANINT(etim)/100.) + amod(ANINT(etim),100.)/60. c c --- set scaling factor for coordinates --- c iutm = iuzon plon = polelon plat = polelat t1 = tlat1 t2 = tlat2 if (llatlon) then iproj = 0 orgx = xorg orgy = yorg dx = delx dy = dely else orgx = 1000.*xorg orgy = 1000.*yorg dx = 1000.*delx dy = 1000.*dely if (lutm) then iproj = 1 elseif (lambrt) then iproj = 2 elseif (lrpolar) then iproj = 3 elseif (lpolar) then iproj = 4 elseif (lmerc) then iproj = 5 endif endif c c ---- put species names into integer array ---- c nspcout = 0 ptnameout = ' ' do 10 j=1,nspcs if( loutsa(j) .OR. ftype .EQ. 'AIRQUALITY' ) then nspcout = nspcout + 1 read(ptname(j),'(10A1)') (ispec(i,nspcout),i=1,10) if( lcdfout ) then if( lddm .OR. lhddm ) then ptnameout(nspcout) = ptlong(j) else ptnameout(nspcout)(1:10) = ptname(j) endif endif endif 10 continue c c --- master grid file header --- c lwrite_file = .TRUE. if( (lddm .OR. lhddm) .AND. .NOT. lddmcalc(1) ) lwrite_file = .FALSE. if( lwrite_file ) then read(ftype,'(10A1)') (ifile(i),i=1,10) read(runmsg(1:60),'(60A1)') (note(i),i=1,60) n = 1 nz = 1 num_dims = 4 if (nzcell.gt.1) nz = nlay(1) if( ltrace .AND. lsa_3davrg ) nz = nlay(1) if( lirr ) then nz = 1 if( l3davg(n) ) nz = nlay(n) endif ntotspout = nspcout if( lcdfout ) then call ncf_set_vars_base() call ncf_set_tstep(idate,btim,jdate,etim) endif if( .NOT. lcdfout .OR. ftype .EQ. 'AIRQUALITY' ) then write(iounit(1),ERR=7000) ifile,note,itzon,nspcout,ndate,ttime, & ndlast,ttlast write(iounit(1),ERR=7000) plon,plat,iutm,orgx,orgy, & dx,dy,ncol(1),nrow(1), & nz,iproj,izero,t1,t2,zero write(iounit(1),ERR=7000) ione,ione,ncol(1),nrow(1) write(iounit(1),ERR=7000) ((ispec(i,j),i=1,10),j=1,nspcout) if( ftype .EQ. 'AIRQUALITY' ) goto 9999 else if( lcdfout .AND. ftype .NE. 'AIRQUALITY' ) then action = 'Writing tracer output file: '//fname(1)(:istrln(fname(1))) call ncf_set_global(ncf_filtype,1,ndate,ttime,ndlast,ttlast, & nz,nspcout) call ncf_wrt_dim(action,iounit(1),1,ncol(1),nrow(1),nz,nspcout) call ncf_wrt_global(action,iounit(1),nspcout,ptnameout,.FALSE.) if( tectyp .EQ. SA ) then call ncf_wrt_global_sa(action,iounit(1)) else if( tectyp .EQ. DDM .OR. tectyp .EQ. 'HDDM' ) then call ncf_wrt_global_ddm(action,iounit(1)) endif call ncf_wrt_vars_base(action,iounit(1)) call ncf_wrt_vars_species(action,iounit(1),ncol(1),nrow(1),nz, & nspcout,ptnameout,spec_units,spec_long_name, & spec_desc,spec_coords,num_dims) call ncf_enddef_file(action,iounit(1)) call ncf_wrt_data_grid(action,iounit(1),1,ncol(1),nrow(1), & orgx,orgy,dx,dy,nz,cellat(iptr2d(1)), & cellon(iptr2d(1)),topo(iptr2d(1))) endif endif c c --- nested grid headers --- c do n = 2,ngrid if( (lddm .OR. lhddm) .AND. .NOT. lddmcalc(n) ) cycle dxf = dx/float(meshold(n)) dyf = dy/float(meshold(n)) xorgf = orgx + dx*(inst1(n)-1) - dxf yorgf = orgy + dy*(jnst1(n)-1) - dyf if (nzcell.gt.1) nz = nlay(n) if( ltrace .AND. lsa_3davrg ) nz = nlay(1) if( lirr ) then nz = 1 num_dims = 4 if( l3davg(n) ) nz = nlay(n) endif if( .NOT. lcdfout ) then write(iounit(n),ERR=7000) ifile,note,itzon,nspcout,ndate,ttime, & ndlast,ttlast write(iounit(n),ERR=7000) plon,plat,iutm,xorgf,yorgf,dxf,dyf, & ncol(n),nrow(n),nz,iproj,izero, & t1,t2,zero write(iounit(n),ERR=7000) ione,ione,ncol(n),nrow(n) write(iounit(n),ERR=7000) ((ispec(i,j),i=1,10),j=1,nspcout) else action = 'Writing tracer output file: '//fname(n)(:istrln(fname(n))) call ncf_set_global(ncf_filtype,n,ndate,ttime,ndlast,ttlast, & nz,nspcout) call ncf_wrt_dim(action,iounit(n),n,ncol(n),nrow(n),nz,nspcout) call ncf_wrt_global(action,iounit(n),nspcout,ptnameout,.FALSE.) if( tectyp .EQ. SA ) then call ncf_wrt_global_sa(action,iounit(n)) else if( tectyp .EQ. DDM .OR. tectyp .EQ. 'HDDM' ) then call ncf_wrt_global_ddm(action,iounit(n)) endif call ncf_wrt_vars_base(action,iounit(n)) call ncf_wrt_vars_species(action,iounit(n),ncol(n),nrow(n),nz, & nspcout,ptnameout,spec_units,spec_long_name, & spec_desc,spec_coords,num_dims) call ncf_enddef_file(action,iounit(n)) call ncf_wrt_data_grid(action,iounit(n),n,ncol(n),nrow(n), & orgx,orgy,dx,dy,nz,cellat(iptr2d(n)), & cellon(iptr2d(n)),topo(iptr2d(n))) endif enddo c c --- reset the output species name --- c ptnameout = ' ' do j=1,nspcs if( lddm .OR. lhddm ) then ptnameout(j) = ptlong(j) else ptnameout(j)(1:10) = ptname(j) endif enddo c c --- return to calling routine --- c goto 9999 c c----------------------------------------------------------------------- c Error messages: c----------------------------------------------------------------------- c 7000 continue write(iout,'(//,A)') 'ERROR in HDRWSA:' write(iout,9000,ERR=9999)'Writing output tracer file: ', & fname(n)(:istrln(fname(n))) call camxerr() c c----------------------------------------------------------------------- c Format statements: c----------------------------------------------------------------------- c 9000 format(/,1X,2A) c c----------------------------------------------------------------------- c Return point: c----------------------------------------------------------------------- c 9999 continue return end c