diff --git a/aqm_files.cmake b/aqm_files.cmake index 6727dc86..b23a84f9 100644 --- a/aqm_files.cmake +++ b/aqm_files.cmake @@ -68,46 +68,42 @@ list(APPEND aqm_ioapi_files set(CCTM_ROOT "src/model/CMAQ/CCTM/src") set(AERO "${CCTM_ROOT}/aero/aero6") -set(BIOG "${CCTM_ROOT}/biog/beis3") +set(BIOG "${CCTM_ROOT}/biog/beis4") set(CLOUD "${CCTM_ROOT}/cloud/acm_ae6") set(DEPV "${CCTM_ROOT}/depv/m3dry") set(EMIS "${CCTM_ROOT}/emis/emis") -set(GAS "${CCTM_ROOT}/gas/ebi_cb6r3_ae6_aq") +set(GAS "${CCTM_ROOT}/gas/ebi_cb6r5_ae7_aq") set(GRID "${CCTM_ROOT}/grid/cartesian") set(ICL "${CCTM_ROOT}/ICL/fixed") -set(INIT "${CCTM_ROOT}/init/yamo") -set(MECHS "${CCTM_ROOT}/MECHS/cb6r3_ae6_aq") +set(INIT "${CCTM_ROOT}/init") +set(MECHS "${CCTM_ROOT}/MECHS/cb6r5_ae7_aq") set(PA "${CCTM_ROOT}/procan/pa") set(PHOT "${CCTM_ROOT}/phot/inline") set(PLRISE "${CCTM_ROOT}/plrise/smoke") set(SPCS "${CCTM_ROOT}/spcs/cgrid_spcs_nml") +set(STM "${CCTM_ROOT}/stm") set(STENEX "${CCTM_ROOT}/STENEX/noop") set(UTIL "${CCTM_ROOT}/util/util") -set(VDIFF "${CCTM_ROOT}/vdiff/acm2") +set(VDIFF "${CCTM_ROOT}/vdiff/acm2_m3dry") +set(DRIV "${CCTM_ROOT}/driver") set(localCCTM "src/model/src") list(APPEND aqm_CCTM_files ${AERO}/AERO_DATA.F ${AERO}/aero_driver.F - ${AERO}/AERO_EMIS.F + ${AERO}/aero_nml_modes.F ${AERO}/AEROMET_DATA.F ${AERO}/AEROSOL_CHEMISTRY.F ${AERO}/aero_subs.F - ${AERO}/aero_depv.F - ${AERO}/AOD_DEFN.F ${AERO}/coags.f ${AERO}/getpar.f ${AERO}/isocom.f ${AERO}/isofwd.f ${AERO}/isorev.f ${AERO}/isrpia.inc - ${AERO}/opvis.F - ${AERO}/opavis.F - ${AERO}/oppmdiag.F - ${AERO}/opapmdiag.F + ${AERO}/AERO_BUDGET.F ${AERO}/PRECURSOR_DATA.F - ${AERO}/PMDIAG_DATA.F ${AERO}/SOA_DEFN.F - ${BIOG}/beis3.F + ${BIOG}/beis.F ${BIOG}/checkmem.f ${BIOG}/czangle.F ${BIOG}/getparb.f @@ -131,31 +127,31 @@ list(APPEND aqm_CCTM_files ${DEPV}/gas_depv_map.F ${DEPV}/HGSIM.F ${DEPV}/LSM_MOD.F - ${DEPV}/MOSAIC_MOD.F + ${DEPV}/depv_data_module.F ${DEPV}/opdepv_diag.F - ${DEPV}/opdepv_mos.F - ${DEPV}/opdepv_fst.F ${DEPV}/m3dry.F ${EMIS}/BEIS_DEFN.F ${EMIS}/BIOG_EMIS.F ${EMIS}/cropcal.F - ${EMIS}/EMIS_DEFN.F + ${EMIS}/crop_data_module.F ${EMIS}/LTNG_DEFN.F ${EMIS}/LUS_DEFN.F ${EMIS}/MGEMIS.F - ${EMIS}/opemis.F ${EMIS}/PTBILIN.F ${EMIS}/SSEMIS.F ${EMIS}/STK_EMIS.F ${EMIS}/STK_PRMS.F - ${EMIS}/tfabove.F - ${EMIS}/tfbelow.F ${EMIS}/UDTYPES.F - ${GAS}/degrade_data.F - ${GAS}/degrade.F - ${GAS}/DEGRADE_SETUP_TOX.F - ${GAS}/final_degrade.F - ${GAS}/find_degraded.F + ${EMIS}/biog_emis_param_module.F + ${EMIS}/CMAQ_Control_DESID.nml + #${EMIS}/desid_module.F + ${EMIS}/desid_param_module.F + ${EMIS}/desid_util.F + ${EMIS}/desid_vars.F + ${EMIS}/lus_data_module.F + ${EMIS}/stack_group_data_module.F + ${GAS}/../../reactive_tracers/DEGRADE_PARAMETERS.F + ${GAS}/../../reactive_tracers/DEGRADE_ROUTINES.F ${GAS}/hrdata_mod.F ${GAS}/hrdriver.F ${GAS}/hrg1.F @@ -166,7 +162,7 @@ list(APPEND aqm_CCTM_files ${GAS}/hrprodloss.F ${GAS}/hrrates.F ${GAS}/hrsolver.F - ${GAS}/init_degrade.F + ${GAS}/../../reactive_tracers/DEGRADE_SETUP_TOX.F ${GRID}/GRID_CONF.F ${GRID}/HGRD_DEFN.F ${GRID}/VGRD_DEFN.F @@ -181,11 +177,15 @@ list(APPEND aqm_CCTM_files ${MECHS}/RXNS_DATA_MODULE.F90 ${MECHS}/RXNS_FUNC_MODULE.F90 ${PA}/PA_DEFN.F + ${PA}/budget_defn.F + ${PA}/../../hadv/ppm/xy_budget.F ${PA}/pa_update.F + ${PA}/PA_IRR_module.F + ${PA}/PA_IRR_CTL.F ${PHOT}/CLOUD_OPTICS.F ${PHOT}/complex_number_module.F90 ${PHOT}/CSQY_DATA.F - ${PHOT}/OMI_1979_to_2015.dat + ${PHOT}/OMI_1979_to_2019.dat ${PHOT}/opphot.F ${PHOT}/PHOT_MET_DATA.F ${PHOT}/PHOT_MOD.F @@ -193,6 +193,7 @@ list(APPEND aqm_CCTM_files ${PHOT}/PHOT_OPTICS.dat ${PHOT}/SEAS_STRAT_O3_MIN.F ${PHOT}/twoway_rrtmg_aero_optics.F90 + ${PHOT}/concld_prop_acm.F ${PLRISE}/delta_zs.f ${PLRISE}/fire_plmris.F ${PLRISE}/openlayout.F @@ -200,9 +201,11 @@ list(APPEND aqm_CCTM_files ${PLRISE}/plmris.F ${PLRISE}/plsprd.f ${PLRISE}/preplm.f - ${PLRISE}/ungridb2.f ${PLRISE}/write3_distr.f ${SPCS}/CGRID_SPCS.F + ${SPCS}/CGRID_SPCS_TYPES.F + ${STM}/STM_VARS.F + ${STM}/STM_MODULE.F ${STENEX}/noop_comm_module.f ${STENEX}/noop_data_copy_module.f ${STENEX}/noop_gather_module.f @@ -214,34 +217,41 @@ list(APPEND aqm_CCTM_files ${STENEX}/noop_slice_module.f ${STENEX}/noop_term_module.f ${STENEX}/noop_util_module.f - ${UTIL}/bmatvec.F ${UTIL}/findex.f - ${UTIL}/get_envlist.f + ${UTIL}/log_header.F + ${UTIL}/get_env_mod.f90 ${UTIL}/setup_logdev.F ${UTIL}/subhdomain.F ${UTIL}/UTILIO_DEFN.F + ${UTIL}/util_family_module.F + ${UTIL}/CMAQ_Control_Misc.nml + ${DRIV}/ELMO_PROC.F + ${DRIV}/ELMO_DATA.F ${VDIFF}/aero_sedv.F + ${VDIFF}/aero_depv.F ${VDIFF}/conv_cgrid.F ${VDIFF}/matrix1.F ${VDIFF}/opddep.F - ${VDIFF}/opddep_fst.F - ${VDIFF}/opddep_mos.F - ${VDIFF}/rddepv.F ${VDIFF}/SEDIMENTATION.F ${VDIFF}/tri.F + ${VDIFF}/VDIFF_DATA.F ${VDIFF}/VDIFF_DIAG.F ${VDIFF}/VDIFF_MAP.F - ${VDIFF}/vdiffproc.F + ${VDIFF}/vdiffacmx.F + #${VDIFF}/vdiffproc.F + ${VDIFF}/../../biog/megan3/BDSNP_MOD.F ${localCCTM}/o3totcol.f - ${localCCTM}/vdiffacmx.F - ${localCCTM}/PTMAP.F - ${localCCTM}/PT3D_DATA_MOD.F - ${localCCTM}/PT3D_DEFN.F - ${localCCTM}/PT3D_FIRE_DEFN.F - ${localCCTM}/PT3D_STKS_DEFN.F + ${localCCTM}/AERO_EMIS.F + ${localCCTM}/RUNTIME_VARS.F + #${localCCTM}/PTMAP.F + #${localCCTM}/PT3D_DATA_MOD.F + #${localCCTM}/PT3D_DEFN.F + #${localCCTM}/PT3D_FIRE_DEFN.F + #${localCCTM}/PT3D_STKS_DEFN.F ${localCCTM}/ASX_DATA_MOD.F ${localCCTM}/DUST_EMIS.F ${localCCTM}/AERO_PHOTDATA.F ${localCCTM}/phot.F + ${localCCTM}/centralized_io_module.F ${localCCTM}/centralized_io_util_module.F ) diff --git a/src/model/src/AERO_EMIS.F b/src/model/src/AERO_EMIS.F new file mode 100644 index 00000000..00881459 --- /dev/null +++ b/src/model/src/AERO_EMIS.F @@ -0,0 +1,579 @@ + +!------------------------------------------------------------------------! +! The Community Multiscale Air Quality (CMAQ) system software is in ! +! continuous development by various groups and is based on information ! +! from these groups: Federal Government employees, contractors working ! +! within a United States Government contract, and non-Federal sources ! +! including research institutions. These groups give the Government ! +! permission to use, prepare derivative works of, and distribute copies ! +! of their work in the CMAQ system to the public and to permit others ! +! to do so. The United States Environmental Protection Agency ! +! therefore grants similar permission to use the CMAQ system software, ! +! but users are requested to provide copies of derivative works or ! +! products designed to operate in the CMAQ system to the United States ! +! Government without restrictions as to use by others. Software ! +! that is used with the CMAQ system but distributed under the GNU ! +! General Public License or the GNU Lesser General Public License is ! +! subject to their copyright restrictions. ! +!------------------------------------------------------------------------! + +C::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: + MODULE AERO_EMIS + +C Emissions data and code required for the modal aerosol module in CMAQ +C Based on original codes by Dr. Francis S. Binkowski and J. Young + +C Dependent Upon: NONE + +C Revision History: + +C 30 Aug 01 J.Young: dyn alloc - Use HGRD_DEFN +C 09 Oct 03 J.Gipson: added MW array for AE emis species to module contents +C 31 Jan 05 J.Young: dyn alloc - establish both horizontal & vertical +C domain specifications in one module, GRID_CONF +C 26 Apr 05 P.Bhave: removed code supporting the "old type" of emission +C files that had unspeciated PM10 and PM2.5 only +C removed need for 'AERO_SPC.EXT' by declaring the +C required variables locally +C 13 Jun 05 P.Bhave: added vars needed for sea-salt emission processing +C inherit N_AE_EMIS,AE_EMIS,AE_EMIS_MAP from AE_EMIS.EXT +C moved RHO* parameters from RDEMIS_AE to this module +C for use by SSEMIS routine +C 24 Aug 07 J.Young: Modified to enable in-line plume rise calculation for +C 3D pt source emissions. Distinguish between PM (primary, +C unspeciated, file data) and AE (model speciated). Re- +C named RDEMIS_AE to GET_AERO_EMIS. +C 11 Apr 08 J.Kelly: added code to emit coarse surface area +C 4 Jan 10 J.Young: restructure; eliminate ref to older AERO versions +C 21 Feb 10 J.Young: move sea salt emissions to its own module (SSEMIS) +C 23 Apr 10 J.Young: replace include files with mechanism namelists +C 30 Apr 10 J.Young: update to use aero_reeng by Steve Howard, Prakash Bhave, +C Jeff Young, and Sergey Napelenok +C 23 Jul 10 D.Wong: remove CLOSE3 and BARRIER +C 24 Feb 11 J.Young: Reorganized module with initialization and timestepping +C procedures +C 25 Feb 11 J.Young: add windblown dust module +C 25 Mar 11 S.Roselle: replaced I/O API include files with UTILIO_DEFN +C 11 May 11 D.Wong: incorporated twoway model implementation +C 18 Aug 11 David Wong: In the merge inline point source PM species calculation, +C arrays EMBUFF and PMEMIS_PT have incorrect index values +C 17 Apr 13 J.Young: replace "SPFC ASO4" (found by Havala Pye) with "SPFC_ASO4" +C 07 Nov 14 J.Bash: Updated for the ASX_DATA_MOD shared data module. +C----------------------------------------------------------------------- + + USE AERO_DATA, ONLY: DESID_N_AERO_REF, N_MODE + USE DESID_VARS, ONLY: DESID_LAYS, DESID_STREAM_AERO, DESID_N_SRM, CELLVOL + + IMPLICIT NONE + SAVE +C aerosol emissions: [ppmv/s] for mass & number spcs, [m2/mol/s] for surface area spcs + PUBLIC DESID_SIZE_DIST, AERO_EMIS_INIT, DESID_INIT_SIZE_DIST, + & MAP_ISTRtoAERO, MAP_ISTRtoMODE, MAP_NUMtoISTR, MAP_SRFtoISTR, + & MAP_ISTRtoNUM, MAP_ISTRtoSRF, MAP_ISTRtoSD, DESID_STREAM_AERO, + & SD_SPLIT + PRIVATE + +C Variables for converting mass emissions rate to number emissions rate + REAL :: FACNUM( DESID_N_AERO_REF,N_MODE ) + +C Variables for converting mass emissions rate to 2nd moment emissions rate + REAL :: FACSRF( DESID_N_AERO_REF,N_MODE ) + +C Variables for Saving split factors between emission modes + REAL, ALLOCATABLE :: SD_SPLIT( :,: ) + +C Emission rate of all aerosol species interpolated to current time + INTEGER, ALLOCATABLE :: MAP_ISTRtoAERO( : ) + INTEGER, ALLOCATABLE :: MAP_ISTRtoMODE( : ) + INTEGER, ALLOCATABLE :: MAP_NUMtoISTR ( : ) + INTEGER, ALLOCATABLE :: MAP_SRFtoISTR ( : ) + INTEGER, ALLOCATABLE :: MAP_ISTRtoNUM ( : ) + INTEGER, ALLOCATABLE :: MAP_ISTRtoSRF ( : ) + INTEGER, ALLOCATABLE :: MAP_ISTRtoSD ( :,: ) + INTEGER, ALLOCATABLE :: MAP_AEROtoDIFF( :,: ) ! indices of aero species to CGRID + +C Miscellaneous variables + CHARACTER( 200 ) :: XMSG = ' ' + + CONTAINS + +C----------------------------------------------------------------------- + FUNCTION AERO_EMIS_INIT ( JDATE, JTIME, TSTEP ) RESULT ( SUCCESS) + +C Revision History: + +C 30 Aug 01 J.Young: dynamic allocation - Use INTERPX +C 29 Jul 03 P.Bhave: added compatibility with emission files that contain +C PM10, PEC, POA, PNO3, PSO4, and PMF, but do not +C contain PMC +C 20 Aug 03 J.Young: return aero emissions in molar mixing ratio, ppm units +C 09 Oct 03 J.Gipson: added MW array for AE emis species to module contents +C 01 Sep 04 P.Bhave: changed MW for primary organics from 120 to 220 g/mol, +C to match MWPOA in subroutine ORGAER3. +C 31 Jan 05 J.Young: dyn alloc - removed HGRD_ID, VGRID_ID, and COORD_ID +C include files because those parameters are now +C inherited from the GRID_CONF module +C 26 Apr 05 P.Bhave: removed code supporting the "old type" of emission +C files that had unspeciated PM10 and PM2.5 only +C removed need for 'AERO_CONST.EXT' by declaring the +C required variables locally +C simplified the CONVM, CONVN, CONVS calculations +C updated and enhanced in-line documentation +C 03 May 05 P.Bhave: fixed bug in the H2SO4 unit conversion, initially +C identified by Jinyou Liang of CARB +C 13 Jun 05 P.Bhave: calculate sea-salt emissions; execute if MECHNAME = AE4 +C read input fields from new OCEAN_1 file +C read extra input fields from MET_CRO_2D and MET_CRO_3D +C write diagnostic sea-salt emission file +C added TSTEP to call vector for diagnostic output file +C inherit MWs from AE_SPC.EXT instead of hardcoding +C find pointers to CGRID indices instead of hardcoding +C 08 Mar 07 P.Bhave& added capability for emission files that contain +C S.Roselle: POC or POA +C 30 Jan 08 P.Bhave: added compatibility with AE5 mechanisms +C 23 Mar 08 J.Young: modifications to allow for in-line point source emissions +C 11 Apr 08 J.Kelly: added code to emit coarse surface area +C 09 Sep 08 P.Bhave: backward compatibility with AE4 mechanisms +C 20 Feb 10 J.Young: move ssemis out to its own F90 module +C 24 Feb 11 J.Young: add windblown dust emissions option +C 25 Mar 11 S.Roselle: Replaced I/O API include files with UTILIO_DEFN +C 07 Jul 14 B.Hutzell: replaced mechanism include file(s) with fortran module +C 17 Sep 14 K.Fahey: Changed geometric mean diameter and geometric +C standard deviation of emitted particles according to +C Elleman and Covert (2010) +C 15 Apr 16 J.Young: Use aerosol factors from the AERO_DATA module's named constants; +C Moved K.Fahey's mods to geometric mean diameter and standard +C deviation to the AERO_DATA module + +C References: +C CRC76, "CRC Handbook of Chemistry and Physics (76th Ed)", +C CRC Press, 1995 +C Elleman & Covert, "Aerosol size distribution modeling with the Community +C Multiscale Air Quality modeling system in the Pacific +C Northwest: 3. Size distribution of particles emitted +C into a mesoscale model", J. Geophys. Res., Vol 115, +C No D3, doi:10.1029/2009JD012401, 2010 +C Hobbs, P.V. "Basic Physical Chemistry for the Atmospheric Sciences", +C Cambridge Univ. Press, 206 pp, 1995. +C Snyder, J.P. "Map Projections-A Working Manual", U.S. Geological Survey +C Paper 1395 U.S.GPO, Washington, DC, 1987. +C Binkowski & Roselle Models-3 Community Multiscale Air Quality (CMAQ) +C model aerosol component 1: Model Description. +C J. Geophys. Res., Vol 108, No D6, 4183 +C doi:10.1029/2001JD001409, 2003 +C----------------------------------------------------------------------- + + USE AERO_DATA, ONLY: DESID_AERO_REF, N_AEROSPC, AEROSPC, + & AERO_MISSING, MAP_AERO + USE GRID_CONF, ONLY: GDTYP_GD, XCELL_GD, YCELL_GD, YORIG_GD, GL_NROWS, X3FACE_GD + USE DUST_EMIS, ONLY: DUST_EMIS_INIT + USE DESID_VARS, ONLY: MAP_ISTRtoEMVAR + USE PRECURSOR_DATA, ONLY: MAP_PRECURSOR + USE RUNTIME_VARS, ONLY: OCEAN_CHEM, WB_DUST + USE SSEMIS, ONLY: SSEMIS_INIT + USE UTILIO_DEFN !(Wei Li), ONLY: INDEX1, M3EXIT, LATGRD3, XSTAT1, XSTAT2 + USE VDIFF_MAP, ONLY : N_SPC_DIFF, DIFF_SPC + + INCLUDE SUBST_CONST ! physical and mathematical constants + INCLUDE SUBST_FILES_ID ! file name parameters + +C Arguments: + + INTEGER, INTENT( IN ) :: JDATE ! current model date, coded YYYYDDD + INTEGER, INTENT( IN ) :: JTIME ! current model time, coded HHMMSS + INTEGER, INTENT( IN ) :: TSTEP ! time step vector (HHMMSS) + ! TSTEP(1) = local output step + LOGICAL SUCCESS + +C External Functions: + INTEGER, EXTERNAL :: FINDEX ! looks up number in table. + +C Local Variables: + REAL DGV, SG, SPLIT_ACCUM + +C Domain decomposition info from emission and meteorology files + INTEGER GXOFF, GYOFF ! origin offset + +C Miscellaneous variables + INTEGER STATUS ! ENV..., ALLOCATE status + CHARACTER( 16 ), SAVE :: PNAME = 'AERO_EMIS_INIT ' + CHARACTER( 16 ) :: VNAME ! temp var for species names + CHARACTER( 50 ) :: VARDESC ! variable for reading environ. variables + INTEGER L, N, S, V, IAERO, ISRM, ! Loop indices + & IEM, IDIFF, ISPC + +C ---------------------------------------------------------------------- + + SUCCESS = .TRUE. + +C *** Map data modules + CALL MAP_AERO() + CALL MAP_PRECURSOR() + +C *** set up for sea-spray emission processing + IF ( OCEAN_CHEM ) THEN + IF ( .NOT. SSEMIS_INIT( JDATE, JTIME, TSTEP ) ) THEN + XMSG = 'Failure initializing sea-spray emission processing' + CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT2 ) + END IF + END IF + +C *** set up for dust emission processing + IF ( WB_DUST ) THEN + IF ( .NOT. DUST_EMIS_INIT( JDATE, JTIME, TSTEP ) ) THEN + XMSG = 'Failure initializing dust emission processing' + CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT2 ) + END IF + END IF + +C *** Set up emissions size distribution arrays + ! Calculate factors for converting 3rd moment emission rates into + ! number and surface area emission rates. See Equation 7b of + ! Binkowski & Roselle (2003) + DO IEM = 1,DESID_N_AERO_REF + DO N = 1, N_MODE + DGV = DESID_AERO_REF( IEM )%DGVEM( N ) + SG = DESID_AERO_REF( IEM )%SGEM ( N ) + + IF ( DESID_AERO_REF( IEM )%SPLIT( N ) .GT. 0.0 ) THEN + FACNUM( IEM,N ) = EXP( 4.5 * LOG( SG ) ** 2 ) / DGV ** 3 + FACSRF( IEM,N ) = PI * EXP( 0.5 * LOG( SG ) ** 2 ) / DGV + ELSE + FACNUM( IEM,N ) = 0.0 + FACSRF( IEM,N ) = 0.0 + END IF + END DO + + END DO + + ! Map the Modal-Dependent Names to Transported Species + ALLOCATE ( MAP_AEROtoDIFF( N_AEROSPC, N_MODE ) ) + DO ISPC = 1,N_AEROSPC + DO N = 1,N_MODE + MAP_AEROtoDIFF( ISPC, N ) = INDEX1( AEROSPC( ISPC )%name( N ), + & N_SPC_DIFF, DIFF_SPC ) + END DO + END DO + + + ! Modify the reference emissions splits based on what transported + ! aerosol species are actually available. For example, if the aerosol + ! namelist only includes the accumulation mode (J) but not the + ! Aitken mode (I) for a particular species, then the split for + ! Aitken mode should be added to the Accumulation mode. Save + ! these scale factors as a function of transported species and + ! mode. + ALLOCATE( SD_SPLIT( N_SPC_DIFF, DESID_N_AERO_REF ) ) + SD_SPLIT = 0.0 + DO IEM = 1,DESID_N_AERO_REF + ! For the Fine Mode Reference Distribution, lump Aitken + ! with Accumulation mode if Aitken Mode does not exist + IF ( DESID_AERO_REF( IEM )%NAME .EQ. 'FINE_REF' ) THEN + DO ISPC = 1,N_AEROSPC + SPLIT_ACCUM = 0.0 + DO N = 1,N_MODE-1 + IF ( AERO_MISSING( ISPC,N ) ) THEN + SPLIT_ACCUM = SPLIT_ACCUM + DESID_AERO_REF( IEM )%SPLIT( N ) + ELSE + SD_SPLIT( MAP_AEROtoDIFF( ISPC,N ),IEM ) = + & SD_SPLIT( MAP_AEROtoDIFF( ISPC,N ),IEM ) + + & DESID_AERO_REF( IEM )%SPLIT( N ) + SPLIT_ACCUM + SPLIT_ACCUM = 0.0 + END IF + END DO + END DO + ELSE + ! Arbitrary Distribution -> Apply factor to species + ! if it exists in each mode + DO ISPC = 1, N_AEROSPC + DO N = 1, N_MODE + IF ( .NOT. AERO_MISSING( ISPC,N ) ) THEN + SD_SPLIT( MAP_AEROtoDIFF( ISPC,N ),IEM ) = + & DESID_AERO_REF( IEM )%SPLIT( N ) + END IF + END DO + END DO + END IF + END DO + + ALLOCATE ( MAP_NUMtoISTR ( N_MODE ), + & MAP_SRFtoISTR ( N_MODE ), STAT = STATUS ) + CALL CHECKMEM( STATUS, 'MAP_NUMtoEM', PNAME ) + CALL CHECKMEM( STATUS, 'MAP_SRFtoEM', PNAME ) + + END FUNCTION AERO_EMIS_INIT + +C----------------------------------------------------------------------- + + SUBROUTINE DESID_INIT_SIZE_DIST ( JDATE, JTIME ) + +C EM_SD_INIT initializes the structures that map modes and streams to +C reference modes including splits, diameters, and standard deviations. + +C----------------------------------------------------------------------- + USE AERO_DATA, ONLY: DESID_AERO_REF, DESID_N_AERO_REF + USE DESID_VARS, ONLY: DESID_SD_NML + USE DESID_UTIL, ONLY: DESID_GET_RULE_STREAMS + USE UTILIO_DEFN, ONLY: INDEX1, XSTAT1 + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: JDATE ! current model date, coded YYYYDDD + INTEGER, INTENT( IN ) :: JTIME ! current model time, coded HHMMSS + INTEGER ISRM + + INTEGER :: N_SD_RULE + INTEGER :: N_SD( DESID_N_SRM ) + CHARACTER( 16 ) :: SD_NAME( DESID_N_SRM, 10 ) + INTEGER :: SD( DESID_N_SRM, 10 ) + LOGICAL :: RULE_STREAM( DESID_N_SRM ) + CHARACTER( 16 ) :: CSUR + CHARACTER( 16 ), SAVE :: PNAME = 'EM_SD_INIT ' + CHARACTER( 20 ) :: DESID_AERO_REF_CAPS( DESID_N_AERO_REF ) + + INTEGER IRULE, ISUR, N, NLEN, ISD, IM, IEM, NRULE + LOGICAL :: LREMOVE + + ! Find Total Number of Size Distribution Registries + N_SD_RULE = 0 + DO IRULE = 1,SIZE( DESID_SD_NML ) + IF ( DESID_SD_NML( IRULE )%STREAM .EQ. '' ) EXIT + N_SD_RULE = IRULE + END DO + + ! First Load all of the Streams with the Default FINE, COARSE, and + ! AERO Mode references + SD = 0 + SD_NAME = '' + + ! Capitalize EM_AERO_REF(:)%NAME + DO IM = 1,DESID_N_AERO_REF + DESID_AERO_REF_CAPS( IM ) = DESID_AERO_REF( IM )%NAME + CALL UPCASE( DESID_AERO_REF_CAPS( IM ) ) + ENDDO + + DO ISRM = 1,DESID_N_SRM + N_SD( ISRM ) = 2 + SD_NAME( ISRM,1 ) = 'FINE' + SD( ISRM,1 ) = INDEX1( 'FINE_REF', DESID_N_AERO_REF, DESID_AERO_REF_CAPS( : ) ) + SD_NAME( ISRM,2 ) = 'COARSE' + SD( ISRM,2 ) = INDEX1( 'COARSE_REF', DESID_N_AERO_REF, DESID_AERO_REF_CAPS( : ) ) + END DO + + ! Now Modify those defaults or add new modes to desired streams + DO IRULE = 1, N_SD_RULE + ! Expand Size Distribution Rule to All Streams if Requested + LREMOVE = .FALSE. + IF ( DESID_SD_NML( IRULE )%STREAM .EQ. '' ) CYCLE + CALL DESID_GET_RULE_STREAMS( DESID_SD_NML( IRULE )%STREAM, IRULE, + & RULE_STREAM, LREMOVE ) + IF ( LREMOVE ) CYCLE + + ! Loop through streams, set defaults, and build map array + DO ISRM = 1, DESID_N_SRM + IF ( RULE_STREAM( ISRM ) ) THEN + ! This Stream is Being Modified by a Size Distribution + ! rule + CALL UPCASE( DESID_SD_NML( IRULE )%MODE_REF ) + IF ( DESID_SD_NML( IRULE )%MODE .EQ. 'FINE' ) THEN + ! Overwrite the FINE mode. All fine particle species + ! will go to this mode by default + SD( ISRM,1 ) = INDEX1( DESID_SD_NML( IRULE )%MODE_REF, + & DESID_N_AERO_REF, DESID_AERO_REF_CAPS( : ) ) + IF ( SD( ISRM,1 ) .EQ. 0 ) THEN + WRITE( XMSG,'(A,A,A,/,A,I2,A)' ), '*** Reference Aerosol Mode (', + & DESID_SD_NML( IRULE )%MODE_REF, 'Specified in Emissions Size ', + & 'Dist Rule ',IRULE,' does not exist in AERO_DATA.' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + ELSEIF ( DESID_SD_NML( IRULE )%MODE .EQ. 'COARSE' ) THEN + ! Overwrite the COARSE mode. All coarse particle + ! species will go to this mode by default + SD( ISRM,2 ) = INDEX1( DESID_SD_NML( IRULE )%MODE_REF, + & DESID_N_AERO_REF, DESID_AERO_REF_CAPS( : ) ) + IF ( SD( ISRM,2 ) .EQ. 0 ) THEN + WRITE( XMSG,'(A,A,A,/,A,I2,A)' ), '*** Reference Aerosol Mode (', + & DESID_SD_NML( IRULE )%MODE_REF, 'Specified in Emissions Size ', + & 'Dist Rule ',IRULE,' does not exist in AERO_DATA.' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + ELSE + ! Add a New Available Mode. For example, add a mode + ! just for BC, call it PUREBC, and make sure the AEC + ! for this stream is pointing to this mode. Also make + ! sure you set AEC for FINE mode aerosol to 0.0 if + ! you have default mapping turned on. + N_SD( ISRM ) = N_SD( ISRM ) + 1 + SD_NAME( ISRM,N_SD( ISRM ) ) = DESID_SD_NML( IRULE )%MODE + SD( ISRM,N_SD( ISRM ) ) = INDEX1( DESID_SD_NML( IRULE )%MODE_REF, + & DESID_N_AERO_REF, DESID_AERO_REF_CAPS( : ) ) + IF ( SD( ISRM,N_SD( ISRM )) .EQ. 0 ) THEN + WRITE( XMSG,'(A,A,A,/,A,I2,A)' ), '*** Reference Aerosol Mode (', + & DESID_SD_NML( IRULE )%MODE_REF, 'Specified in Emissions Size ', + & 'Dist Rule ',IRULE,' does not exist in AERO_DATA.' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + END IF + END IF + END DO + END DO + + ! Finally, transfer this data to a global variable which + ! captures and organizes the modes of each stream + ALLOCATE( DESID_STREAM_AERO( DESID_N_SRM ) ) + DO ISRM = 1,DESID_N_SRM + N = N_SD( ISRM ) + DESID_STREAM_AERO( ISRM )%LEN = N + 1 + ALLOCATE( DESID_STREAM_AERO( ISRM )%NAME( N+1 ) ) + ALLOCATE( DESID_STREAM_AERO( ISRM )%REF( N+1 ) ) + ALLOCATE( DESID_STREAM_AERO( ISRM )%FACNUM( N+1,N_MODE ) ) + ALLOCATE( DESID_STREAM_AERO( ISRM )%FACSRF( N+1,N_MODE ) ) + + DESID_STREAM_AERO( ISRM )%NAME( 2:N+1 ) = SD_NAME( ISRM,1:N ) + DESID_STREAM_AERO( ISRM )%REF( 2:N+1 ) = SD( ISRM,1:N ) + DESID_STREAM_AERO( ISRM )%NAME( 1 ) = 'GAS' + DESID_STREAM_AERO( ISRM )%REF( 1 ) = 0 + + ! Map Factors for Converting Aerosol Mass to Number and + ! Surface Area to each Emission Stream + DESID_STREAM_AERO( ISRM )%FACNUM( :,: ) = 0.0 + DESID_STREAM_AERO( ISRM )%FACSRF( :,: ) = 0.0 + DO ISD = 2,N+1 + IEM = DESID_STREAM_AERO( ISRM )%REF( ISD ) + DO IM = 1,N_MODE + DESID_STREAM_AERO( ISRM )%FACNUM( ISD,IM ) = FACNUM( IEM,IM ) + DESID_STREAM_AERO( ISRM )%FACSRF( ISD,IM ) = FACSRF( IEM,IM ) + END DO + END DO + END DO + + END SUBROUTINE DESID_INIT_SIZE_DIST + + +C----------------------------------------------------------------------- + + SUBROUTINE DESID_SIZE_DIST ( ISRM, VDEMIS, NL ) + +C EMISS_SIZE_DIST distributes bulk aerosol emissions into size space +C using parameters precompiled in the AERO_DATA module. +C +C Revision History: + +C 16 AUG 17 BMURPHY: Created +C +C ---------------------------------------------------------------------- + + USE AERO_DATA, ONLY: AEROSPC, N_AEROSPC, AEROSPC_MWINV + USE AEROMET_DATA, ONLY: F6DPI + USE ASX_DATA_MOD, ONLY: MET_DATA + USE DESID_VARS, ONLY: DESID_N_ISTR, IDUSTSRM, ISEASRM + USE GRID_CONF, ONLY: NCOLS, NROWS + USE SSEMIS, ONLY: SEA_FACTNUM, SEA_FACTSRF + + INTEGER, INTENT( IN ) :: ISRM, NL + REAL, INTENT( INOUT ) :: VDEMIS ( :,:,:,: ) + + INTEGER :: N, S, IAERO, IM, ISD, ISTR ! Looping Variables + INTEGER :: ROW, COL, LAY, N_SD, INUM, ISRF + REAL :: FACNUM, FACSRF, MW_FAC + REAL, ALLOCATABLE :: EMISM3( :,:,:,:,: ) + REAL, ALLOCATABLE, SAVE :: GSFAC( :,:,: ) + REAL, ALLOCATABLE, SAVE :: DENS_FAC( : ) + REAL, PARAMETER :: F6DPIM9 = 1.0E-9 * F6DPI ! 1.0E-9 = Kg/ug + LOGICAL, SAVE :: FIRST_TIME = .TRUE. + +C *** Initialize Variables + IF ( FIRST_TIME ) THEN + FIRST_TIME = .FALSE. + ALLOCATE( GSFAC ( DESID_LAYS,NCOLS,NROWS ) ) + + ALLOCATE( DENS_FAC( N_AEROSPC ) ) + DO IAERO = 1,N_AEROSPC + DENS_FAC( IAERO ) = F6DPIM9 / AEROSPC( IAERO )%DENSITY + END DO + + END IF + + N_SD = DESID_STREAM_AERO( ISRM )%LEN + ALLOCATE( EMISM3( DESID_LAYS,NCOLS,NROWS,N_MODE,N_SD ) ) + EMISM3 = 0.0 + +C *** Calculate scaling factor for converting mass emissions into [ug/m3/s] +C note: RJACM converts grid heights from sigma coordinates to meters +C Also calculate scaling factors for converting to molar-mixing-ratio units + DO LAY = 1,NL + GSFAC( LAY,:,: ) = Met_Data%RJACM( :,:,LAY ) / CELLVOL( :,:,LAY ) ![ug/s] to [ug/m3/s] + END DO + +C *** Apply Aerosol Size Distribution + DO ISTR = 1, DESID_N_ISTR + ! Find which Size Distribution or Phase this emissions species belongs + ! to for this stream. If the value is a 0, then there are no emissions + ! for this species from this stream. If it is a 1, then this species is + ! a gas and the following aerosol conversions should be skipped. + ISD = MAP_ISTRtoSD( ISTR,ISRM ) + IF ( ISD .LE. 1 ) CYCLE + + ! Look up Aerosol Species and Mode of Interest + IAERO = MAP_ISTRtoAERO( ISTR ) !This maps to the CMAQ aerosol + ! species so we can retrieve density + IM = MAP_ISTRtoMODE( ISTR ) !This maps to the internal CMAQ modes + ! (ie. I, J, and K) + !DENS_FAC = F6DPIM9 / AEROSPC( IAERO )%DENSITY + + ! Convert Aerosol from [g/s] to [ug/m3/s] for all streams + ! except Dust and Sea Spray. For those streams, convert + ! [g/m3/s] to [ug/m3/s] + VDEMIS( ISTR,1:NL,:,: ) = VDEMIS( ISTR,1:NL,:,: ) * 1.0E6 + IF ( ISRM .NE. ISEASRM .AND. ISRM .NE. IDUSTSRM ) THEN + VDEMIS( ISTR,1:NL,:,: ) = VDEMIS( ISTR,1:NL,:,: ) * GSFAC( 1:NL,:,: ) + END IF + + ! Sum Total Volume of Mode N [m3/m3/s] + IF ( .NOT. AEROSPC( IAERO )%TRACER ) + & EMISM3( 1:NL,:,:,IM,ISD ) = EMISM3( 1:NL,:,:,IM,ISD ) + + & VDEMIS( ISTR,1:NL,:,: ) * DENS_FAC( IAERO ) + + ! Convert Mass Emission Rates from [ug/m3/s] to [umol/m3/s] + VDEMIS( ISTR,1:NL,:,: ) = VDEMIS( ISTR,1:NL,:,: ) * AEROSPC_MWINV( IAERO ) + END DO + +C *** Calculate the number emissions rate for each mode [1/m3/s], using +C Equation 7b of Binkowski & Roselle (2003). +C Calculate the surface area emissions rate for the fine modes [m2/m3/s], +C using Equation 7c of Binkowski & Roselle (2003). Multiplying by PI +C converts 2nd moment to surface area. + + DO ISD = 2, N_SD ! Skip the Index for the Gas Phase + IF ( ISRM .EQ. ISEASRM ) THEN + ! Apply Spatially-Dependent Number and Surface Area Scale Factors + DO IM = 1, N_MODE + INUM = MAP_NUMtoISTR(IM) + VDEMIS( INUM,1,:,: ) = VDEMIS( INUM,1,:,: ) + & + EMISM3( 1,:,:,IM,ISD ) * SEA_FACTNUM( IM,:,: ) + + ISRF = MAP_SRFtoISTR(IM) + VDEMIS( ISRF,1,:,: ) = VDEMIS( ISRF,1,:,: ) + & + EMISM3( 1,:,:,IM,ISD ) * SEA_FACTSRF( IM,:,: ) + END DO + ELSE + ! Apply Homogeneous Scale Factors Consistent with this Stream + DO IM = 1, N_MODE + INUM = MAP_NUMtoISTR(IM) + FACNUM = DESID_STREAM_AERO( ISRM )%FACNUM( ISD,IM ) + VDEMIS( INUM,1:NL,:,: ) = VDEMIS( INUM,1:NL,:,: ) + EMISM3( 1:NL,:,:,IM,ISD ) * FACNUM + + ISRF = MAP_SRFtoISTR(IM) + FACSRF = DESID_STREAM_AERO( ISRM )%FACSRF( ISD,IM ) + VDEMIS( ISRF,1:NL,:,: ) = VDEMIS( ISRF,1:NL,:,: ) + EMISM3( 1:NL,:,:,IM,ISD ) * FACSRF + END DO + END IF + END DO + + END SUBROUTINE DESID_SIZE_DIST + + END MODULE AERO_EMIS + diff --git a/src/model/src/AERO_PHOTDATA.F b/src/model/src/AERO_PHOTDATA.F index ba1de045..e7acd250 100644 --- a/src/model/src/AERO_PHOTDATA.F +++ b/src/model/src/AERO_PHOTDATA.F @@ -38,16 +38,13 @@ MODULE AERO_PHOTDATA REAL, ALLOCATABLE :: BLK_AE_NI ( :,:,: ) ! mean aerosol imaginary part of refractive index REAL, ALLOCATABLE :: AERO_ASYM_FAC ( :,: ) ! aerosol modal averaged asymmetry factor - REAL, ALLOCATABLE :: AERO_EXTI_COEF( :,: ) ! aerosol modal averaged extinction coeff. - REAL, ALLOCATABLE :: AERO_SCAT_COEF( :,: ) ! aerosol modal averaged scattering coeff. + REAL, ALLOCATABLE :: AERO_EXTI_COEF( :,: ) ! aerosol modal averaged extinction coeff., 1/m + REAL, ALLOCATABLE :: AERO_SCAT_COEF( :,: ) ! aerosol modal averaged scattering coeff., 1/m + REAL, ALLOCATABLE :: AERO_EXTI_550 ( : ) ! aerosol modal averaged extinction coeff. at 550nm, 1/m - LOGICAL :: CORE_SHELL - LOGICAL :: MIE_CALC - PUBLIC :: AERO_ASYM_FAC, AERO_EXTI_COEF, AERO_SCAT_COEF, & INIT_AERO_DATA, GET_AERO_DATA, AERO_OPTICS_INTERNAL - INTEGER, PRIVATE :: LOGDEV ! unit number for the log file INTEGER, ALLOCATABLE, PRIVATE :: REFRACT_INDX_MAP( : ) ! map array for refactive index REAL, ALLOCATABLE, PRIVATE :: VOL_MINS( : ) ! minmum volume permode @@ -56,6 +53,16 @@ MODULE AERO_PHOTDATA INTEGER, PARAMETER, PRIVATE :: NUMB_COR_SPCS = 3 ! number species in core + LOGICAL :: CALCULATE_EXT_550 = .FALSE. ! flag to get extinction at 550 nm + LOGICAL :: USE_ANGSTROM_INTERP = .FALSE. ! flag to use angstrom exponents for 550 nm + + INTEGER :: IWL_ANGSTROM_LOWER = 0 ! index for wavelength less than 550 nm + INTEGER :: IWL_ANGSTROM_UPPER = 0 ! index for wavelength greater than 550 nm + REAL( 8 ) :: ANGSTROM_RATIO = 1.0D0 ! wavelength less than 550 nm divided by 550 nm + REAL( 8 ) :: LOG_ANGSTROM_RATIO = 0.0D0 + REAL( 8 ) :: ANGSTROM_SPAN = 1.0D0 ! reciprocal of log ((wavelength < 550 nm)/(wavelength > 550 nm) + REAL( 8 ) :: ANGSTROM_EXPONENT = 1.0D0 ! Angstrom exponent used to interpolate extinction at 550 nm + C *** Species in aerosol core CHARACTER( 16 ), PARAMETER, PRIVATE :: CORE_SPCS( NUMB_COR_SPCS ) = @@ -84,8 +91,6 @@ SUBROUTINE INIT_AERO_DATA( ) C Local: CHARACTER( 32 ) :: PNAME = 'INIT_AERO_DATA' - CHARACTER( 16 ) :: CORE_SHELL_OPTICS = 'CORESHELL_OPTICS' - CHARACTER( 16 ) :: OPTICS_MIE_CALC = 'MIE_OPTICS' CHARACTER( 120 ) :: XMSG INTEGER :: ALLOCSTAT @@ -103,45 +108,10 @@ SUBROUTINE INIT_AERO_DATA( ) RETURN END IF - LOGDEV = INIT3() JDATE = 0 JTIME = 0 -!...Get flag to use core-shell mixing model for aerosol optical properties - - CORE_SHELL = .FALSE. ! default - XMSG = 'Use core-shell mixing model for aerosol optical properties' - CORE_SHELL = ENVYN( CORE_SHELL_OPTICS, XMSG, CORE_SHELL, ESTAT ) - IF ( ESTAT .NE. 0 ) WRITE( LOGDEV, '(5X, A)' ) XMSG - IF ( ESTAT .EQ. 1 ) THEN - XMSG = 'Environment variable improperly formatted' - CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT2 ) - ELSE IF ( ESTAT .EQ. -1 ) THEN - XMSG = - & 'Environment variable set, but empty ... Using default:' - WRITE( LOGDEV, '(5X, A, L5)' ) XMSG, CORE_SHELL - ELSE IF ( ESTAT .EQ. -2 ) THEN - XMSG = 'Environment variable not set ... Using default:' - WRITE( LOGDEV, '(5X, A, L5)' ) XMSG, CORE_SHELL - END IF -!...Get flag to use fast optics for volume mixing model for aerosol optical properties - - MIE_CALC = .FALSE. ! default - XMSG = 'Use Mie theory for aerosol optical properties of Internal mixing model' - MIE_CALC = ENVYN( OPTICS_MIE_CALC, XMSG, MIE_CALC, ESTAT ) - IF ( ESTAT .NE. 0 ) WRITE( LOGDEV, '(5X, A)' ) XMSG - IF ( ESTAT .EQ. 1 ) THEN - XMSG = 'Environment variable improperly formatted' - CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT2 ) - ELSE IF ( ESTAT .EQ. -1 ) THEN - XMSG = - & 'Environment variable set, but empty ... Using default:' - WRITE( LOGDEV, '(5X, A, L5)' ) XMSG, MIE_CALC - ELSE IF ( ESTAT .EQ. -2 ) THEN - XMSG = 'Environment variable not set ... Using default:' - WRITE( LOGDEV, '(5X, A, L5)' ) XMSG, MIE_CALC - END IF C...Allocate needed arrays ALLOCATE ( VOL_MINS( N_MODE ), STAT = ALLOCSTAT ) @@ -220,6 +190,15 @@ SUBROUTINE INIT_AERO_DATA( ) AERO_EXTI_COEF = 0.0 AERO_ASYM_FAC = 0.0 + IF( CALCULATE_EXT_550 )THEN + ALLOCATE ( AERO_EXTI_550( NLAYS ), STAT = ALLOCSTAT ) + IF ( ALLOCSTAT .NE. 0 ) THEN + XMSG = 'Failure allocating AERO_EXTI_550' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + AERO_EXTI_550 = 0.0 + END IF + CALL MAP_AERO() ALLOCATE( M3_FACTOR( N_AEROSPC ), STAT = ALLOCSTAT ) @@ -330,6 +309,38 @@ SUBROUTINE INIT_AERO_DATA( ) END IF END DO + IF( CALCULATE_EXT_550 )THEN ! locate 550 nm in wavebands and set-up interpolation + IF ( WAVELENGTH( 1 ) .GE. 550.0 ) THEN + IWL_ANGSTROM_LOWER = 1 + ELSE IF ( WAVELENGTH( NWL ) .LE. 550.0 ) THEN + IWL_ANGSTROM_LOWER = NWL + ELSE + LOOP_FINDW: DO V = 1, NWL - 1 + IF ( WAVELENGTH( V ) .LT. 550.0 .AND. WAVELENGTH( V+1 ) .GT. 550.0 ) THEN + IWL_ANGSTROM_LOWER = V + IWL_ANGSTROM_UPPER = V+1 + ANGSTROM_SPAN = REAL( 1.0 / LOG( WAVELENGTH( V ) / WAVELENGTH( V+1 ) ), 8 ) + ANGSTROM_RATIO = REAL( (WAVELENGTH( V ) / 550.0), 8) +! ANGSTROM_RATIO = REAL( (WAVELENGTH( V ) / WAVELENGTH( V+1 )), 8) + LOG_ANGSTROM_RATIO = LOG( ANGSTROM_RATIO ) +! WRITE(LOGDEV,'(A,2(F7.3,1X))')'Angstrom Interpolation Wavelengths: ', +! & WAVELENGTH( IWL_ANGSTROM_LOWER ), WAVELENGTH( IWL_ANGSTROM_UPPER ) +! WRITE(LOGDEV,'(A,2(ES12.4,1X))')'Angstrom Span, Ratio: ', +! & ANGSTROM_SPAN, ANGSTROM_RATIO + USE_ANGSTROM_INTERP = .TRUE. + EXIT LOOP_FINDW + ELSE IF ( WAVELENGTH( V ) .EQ. 550.0 ) THEN + IWL_ANGSTROM_LOWER = V + EXIT LOOP_FINDW + END IF + END DO LOOP_FINDW + END IF + IF( .NOT. USE_ANGSTROM_INTERP )THEN + WRITE(LOGDEV,'(A,2(F7.3,1X))')'No Angstrom Inpolation Used 550 Extinction used at ', + & WAVELENGTH( IWL_ANGSTROM_LOWER ) + END IF + END IF + RETURN 5000 FORMAT(2X,'NR_',I3.3,7X,'NI_',I3.3,5X) @@ -339,7 +350,7 @@ SUBROUTINE INIT_AERO_DATA( ) END SUBROUTINE INIT_AERO_DATA C::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - SUBROUTINE GET_AERO_DATA ( COL, ROW, NLAYS, CGRID ) + SUBROUTINE GET_AERO_DATA ( COL, ROW, NLAYS, DENS, CGRID ) C----------------------------------------------------------------------- C FUNCTION: This subroutine calculates the volume, the natural logs of @@ -404,6 +415,7 @@ SUBROUTINE GET_AERO_DATA ( COL, ROW, NLAYS, CGRID ) INTEGER, INTENT( IN ) :: COL ! specified column index INTEGER, INTENT( IN ) :: ROW ! specified row index INTEGER, INTENT( IN ) :: NLAYS ! # of vertical layers + REAL, INTENT( IN ) :: DENS( :,:,: ) REAL, POINTER :: CGRID( :,:,:,: ) C Parameters: @@ -463,7 +475,9 @@ SUBROUTINE GET_AERO_DATA ( COL, ROW, NLAYS, CGRID ) INTEGER MODE ! aerosol mode loop counter LOGICAL SUCCESS LOGICAL TROUBLE - + LOGICAL, SAVE :: FIRSTCALL = .TRUE. + + #ifdef verbose_phot character( 26 ), allocatable :: lambda_list( : ) #endif @@ -486,16 +500,24 @@ SUBROUTINE GET_AERO_DATA ( COL, ROW, NLAYS, CGRID ) AE_DGN_CORE = 0.0 SUCCESS = .TRUE. - LAY_LOOP1: DO L = 1, NLAYS C *** extract grid cell concentrations of aero species from CGRID into aerospc_conc C *** in aero_data module C Also converts dry surface area to wet second moment +#ifdef sens + CALL EXTRACT_AERO ( CGRID( COL,ROW,L,: ), .TRUE., CGRID( COL,ROW,:,: ), .FALSE. ) +#else CALL EXTRACT_AERO ( CGRID( COL,ROW,L,: ), .TRUE. ) +#endif C *** extract soa concentrations from CGRID + AIRDENS = DENS ( COL,ROW,L ) +#ifdef sens + CALL EXTRACT_SOA ( CGRID( COL,ROW,L,: ), CGRID( COL,ROW,:,: ), .FALSE. ) +#else CALL EXTRACT_SOA ( CGRID( COL,ROW,L,: ) ) +#endif C *** Calculate geometric mean diameters and standard deviations of "wet" size distribution CALL GETPAR ( .FALSE. ) @@ -816,11 +838,11 @@ SUBROUTINE GET_AERO_DATA ( COL, ROW, NLAYS, CGRID ) END DO OPTICS_LOOP AERO_SCAT_COEF( L,V ) = BSCAT - AERO_EXTI_COEF( L,V ) = BEXT + AERO_EXTI_COEF( L,V ) = MAX( BEXT, 1.0E-30 ) AERO_ASYM_FAC ( L,V ) = G_BAR / MAX( BSCAT, 1.0E-30 ) #ifdef verbose_phot_extra - if( l .eq. 1 .and. v .eq. 1 )then + if( l .eq. 1 .and. v .eq. 1)then write(logdev, 9502)l, wavelength( V ), dgn_core, dgn_shell, bext_mode, & bscat_mode, gbar_mode, ae_nr_shell( l, mode, v ), ae_ni_shell( v, mode, v ), & ae_nr_core( l, mode, iv ), ae_ni_core( l, mode, v ) @@ -833,6 +855,37 @@ SUBROUTINE GET_AERO_DATA ( COL, ROW, NLAYS, CGRID ) END DO LAY_LOOP2 END DO LOOP_WAVE + + IF( CALCULATE_EXT_550 )THEN +! IF( USE_ANGSTROM_INTERP .AND. FIRSTCALL )THEN +! WRITE(LOGDEV,'(A,2(F7.3,1X))')'Angstrom Interpolation Wavelengths: ', +! & WAVELENGTH( IWL_ANGSTROM_LOWER ), WAVELENGTH( IWL_ANGSTROM_UPPER ) +! WRITE(LOGDEV,'(A,2(ES12.4,1X))')'Angstrom Span, Ratio: ', +! & ANGSTROM_SPAN, ANGSTROM_RATIO +! END IF + LOOP_550NM: DO L = 1, NLAYS + IF( USE_ANGSTROM_INTERP )THEN + ANGSTROM_EXPONENT = - REAL( LOG( AERO_EXTI_COEF( L,IWL_ANGSTROM_LOWER ) + & / AERO_EXTI_COEF( L,IWL_ANGSTROM_UPPER ) ), 8 ) + & * ANGSTROM_SPAN +! AERO_EXTI_550( L ) = LOG( AERO_EXTI_COEF( L,IWL_ANGSTROM_LOWER ) ) +! & + REAL( ANGSTROM_EXPONENT * LOG_ANGSTROM_RATIO, 4 ) +! AERO_EXTI_550( L ) = EXP( AERO_EXTI_550( L ) ) + AERO_EXTI_550( L ) = AERO_EXTI_COEF( L,IWL_ANGSTROM_LOWER ) + & * REAL( ANGSTROM_RATIO ** ANGSTROM_EXPONENT, 4 ) +! IF ( FIRSTCALL ) THEN +! WRITE( LOGDEV,'(I3,A,7(ES12.4,1X))')L, +! & ' AERO_EXT_LOWER,AERO_EXT_UPPER,EXPONENT,EXPONENT*LOG(RATIO),EXT_550_1,EXT_550_2: ', +! & AERO_EXTI_COEF( L,IWL_ANGSTROM_LOWER ), AERO_EXTI_COEF( L,IWL_ANGSTROM_UPPER ), +! & ANGSTROM_EXPONENT,REAL( ANGSTROM_EXPONENT * LOG_ANGSTROM_RATIO,4),AERO_EXTI_550( L ), +! & AERO_EXTI_COEF( L,IWL_ANGSTROM_LOWER)*ANGSTROM_RATIO ** ANGSTROM_EXPONENT +! END IF + ELSE + AERO_EXTI_550( L ) = AERO_EXTI_COEF( L,IWL_ANGSTROM_LOWER ) + END IF + END DO LOOP_550NM +! IF ( FIRSTCALL ) FIRSTCALL = .FALSE. + END IF #ifdef verbose_phot if ( col .eq. 1 .and. row .eq. 1 ) then @@ -1003,10 +1056,18 @@ SUBROUTINE AERO_OPTICS_INTERNAL ( COL, ROW, NLAYS, CGRID ) C *** extract grid cell concentrations of aero species from CGRID into aerospc_conc C *** in aero_data module C Also converts surface area to wet second moment +#ifdef sens + CALL EXTRACT_AERO ( CGRID( COL,ROW,L,: ), .TRUE., CGRID( COL,ROW,:,: ), .FALSE. ) +#else CALL EXTRACT_AERO ( CGRID( COL,ROW,L,: ), .TRUE. ) +#endif C *** extract soa concentrations from CGRID +#ifdef sens + CALL EXTRACT_SOA ( CGRID( COL,ROW,L,: ), CGRID( COL,ROW,:,: ), .FALSE. ) +#else CALL EXTRACT_SOA ( CGRID( COL,ROW,L,: ) ) +#endif C *** Calculate geometric mean diameters and standard deviations of "wet" size distribution CALL GETPAR ( .FALSE. ) @@ -1336,7 +1397,7 @@ SUBROUTINE FASTER_OPTICS ( NR, NI, ALPHV, XLNSIG, BETA_EXT, BETA_SCAT, G ) REAL T1F1, T2F1, T1F2, T2F2, T1F3, T2F3 REAL T1G1, T2G1, T1G2, T2G2, T1G3, T2G3, T1G4, T2G4 REAL T1G5, T2G5 - REAL(8) T1P1, T2P1 + REAL(8) T1P1, T2P1 !(Wei Li) C***the following are for calculating the Penndorff Coefficients @@ -1425,7 +1486,7 @@ SUBROUTINE FASTER_OPTICS ( NR, NI, ALPHV, XLNSIG, BETA_EXT, BETA_SCAT, G ) REAL QQSUM, QQF1,QQF2, QQF3, QQCORR REAL, PARAMETER :: DEGTORAD = PI180 - REAL(8), PARAMETER :: THREE_PI_TWO = 3.0 * PI / 2.0 + REAL(8), PARAMETER :: THREE_PI_TWO = 3.0 * PI / 2.0 !(Wei Li) C***FSB start calculation SIGMA_G = EXP( XLNSIG ) @@ -1473,11 +1534,11 @@ SUBROUTINE FASTER_OPTICS ( NR, NI, ALPHV, XLNSIG, BETA_EXT, BETA_SCAT, G ) ALPHA_I = F2 BEXT = B BSCAT = B - PENN1 = DBLE(0.0) - PENN2 = DBLE(0.0) + PENN1 = DBLE(0.0) !(Wei Li) + PENN2 = DBLE(0.0) !(Wei Li) - ALPHV2 = DBLE(ALPHV * ALPHV) - ALPHV3 = DBLE(ALPHV2 * ALPHV) + ALPHV2 = DBLE(ALPHV * ALPHV) !(Wei Li) + ALPHV3 = DBLE(ALPHV2 * ALPHV) !(Wei Li) IF ( NI .GT. 0.0 ) THEN @@ -1544,14 +1605,14 @@ SUBROUTINE FASTER_OPTICS ( NR, NI, ALPHV, XLNSIG, BETA_EXT, BETA_SCAT, G ) EXPFAC2 = EXP( 2.0 * XLNSIG2 ) EXPFAC3 = EXP( 4.5 * XLNSIG2 ) - T1P1 = DBLE(A1 + A2 * ALPHV2 * EXPFAC2) - T2P1 = DBLE(A3 * ALPHV3 * EXPFAC3) + T1P1 = DBLE(A1 + A2 * ALPHV2 * EXPFAC2) !(Wei Li) + T2P1 = DBLE(A3 * ALPHV3 * EXPFAC3) !(Wei Li) C***PENN1 is the analytic integral of the Pendorff formulae over C*** a log normal particle size distribution. - PENN1 = DBLE(THREE_PI_TWO * ( T1P1 + T2P1 )) - PENN2 = DBLE(THREE_PI_TWO * T2P1) + PENN1 = DBLE(THREE_PI_TWO * ( T1P1 + T2P1 ) ) !(Wei Li) + PENN2 = DBLE(THREE_PI_TWO * T2P1) !(Wei Li) END IF ! test for ni > 0.0 @@ -1791,7 +1852,7 @@ SUBROUTINE FAST_OPTICS( NR, NI, LAMBDA, DGN, SIGMA_G, BETA_EXT, BETA_SCAT, G ) REAL C, CEXT, CSCAT REAL B, BEXT, BSCAT REAL BBFAC - REAL(8) ALPHV + REAL(8) ALPHV !(Wei Li) REAL ALPHA_I REAL A, LOGX2, XLNSIG, XLNSIG2, MM1 @@ -1805,7 +1866,7 @@ SUBROUTINE FAST_OPTICS( NR, NI, LAMBDA, DGN, SIGMA_G, BETA_EXT, BETA_SCAT, G ) REAL LARGEEXT ! large sphere limit for extinction REAL SMALL_G, LARGE_G - REAL(8) ALPHV2, ALPHV3 + REAL(8) ALPHV2, ALPHV3 !(Wei Li) REAL X_ALPHA, X_ALPHA2, X_ALPHA3 REAL FCORR REAL EXPFAC2, EXPFAC3 @@ -1818,12 +1879,12 @@ SUBROUTINE FAST_OPTICS( NR, NI, LAMBDA, DGN, SIGMA_G, BETA_EXT, BETA_SCAT, G ) REAL T1F1, T2F1, T1F2, T2F2, T1F3, T2F3 REAL T1G1, T2G1, T1G2, T2G2, T1G3, T2G3, T1G4, T2G4 REAL T1G5, T2G5 - REAL(8) T1P1, T2P1 + REAL(8) T1P1, T2P1 !(Wei Li) C***the following are for calculating the Penndorff Coefficients REAL A1, A2, A3 - REAL(8) PENN1, PENN2 + REAL(8) PENN1, PENN2 !(Wei Li) REAL XNR, XNI, XNR2, XNI2, XNRI, XNRI2, XNRMI REAL XRI, XRI2, XRI36, XNX, XNX2 REAL Z1, Z12, Z2, XC1 @@ -1908,7 +1969,7 @@ SUBROUTINE FAST_OPTICS( NR, NI, LAMBDA, DGN, SIGMA_G, BETA_EXT, BETA_SCAT, G ) REAL QQSUM, QQF1,QQF2, QQF3, QQCORR REAL, PARAMETER :: DEGTORAD = PI180 - REAL(8), PARAMETER :: THREE_PI_TWO = 3.0 * PI / 2.0 + REAL(8), PARAMETER :: THREE_PI_TWO = 3.0 * PI / 2.0 !(Wei Li) REAL, PARAMETER :: SCALE = 1.00E+9 @@ -1921,9 +1982,9 @@ SUBROUTINE FAST_OPTICS( NR, NI, LAMBDA, DGN, SIGMA_G, BETA_EXT, BETA_SCAT, G ) C***FSB start calculation XLNSIG = LOG( SIGMA_G ) - ALPHV = DBLE(SCALE * PI * DGN * EXP( 3.0 * XLNSIG * XLNSIG ) / LAMBDA) - ALPHV2 = DBLE( ALPHV * ALPHV ) - ALPHV3 = DBLE( ALPHV * ALPHV * ALPHV ) + ALPHV = DBLE(SCALE * PI * DGN * EXP( 3.0 * XLNSIG * XLNSIG ) / LAMBDA) !(Wei Li) + ALPHV2 = DBLE(ALPHV * ALPHV) !(Wei Li) + ALPHV3 = DBLE(ALPHV * ALPHV * ALPHV) !(Wei Li) XLNSIG2 = XLNSIG * XLNSIG A = 0.5 / XLNSIG2 @@ -1963,8 +2024,8 @@ SUBROUTINE FAST_OPTICS( NR, NI, LAMBDA, DGN, SIGMA_G, BETA_EXT, BETA_SCAT, G ) ALPHA_I = F2 BEXT = B BSCAT = B - PENN1 = DBLE(0.0) - PENN2 = DBLE(0.0) + PENN1 = DBLE(0.0) !(Wei Li) + PENN2 = DBLE(0.0) !(Wei Li) IF ( NI .GT. 0.0 ) THEN @@ -2018,25 +2079,25 @@ SUBROUTINE FAST_OPTICS( NR, NI, LAMBDA, DGN, SIGMA_G, BETA_EXT, BETA_SCAT, G ) Z12 = Z1 * Z1 Z2 = 4.0 * XNRI2 + 12.0 * XNRMI + 9.0 XC1 = 8.0 / ( 3.0 * Z12 ) - A1 = DBLE(24.0 * XRI / Z1) + A1 = DBLE(24.0 * XRI / Z1) !(Wei Li) - A2 = DBLE(4.0 * XRI / 15.0 + 20.0 * XRI / ( 3.0 * Z2 ) + + A2 = DBLE(44.0 * XRI / 15.0 + 20.0 * XRI / ( 3.0 * Z2 ) + & 4.8 * XRI * ( 7.0 * XNRI2 + - & 4.0 * ( XNRMI - 5.0 ) ) / Z12) + & 4.0 * ( XNRMI - 5.0 ) ) / Z12 ) !(Wei Li) - A3 = DBLE(XC1 * ( XNX2 - XRI36 )) + A3 = DBLE(XC1 * ( XNX2 - XRI36 )) !(Wei Li) EXPFAC2 = EXP( 2.0 * XLNSIG2 ) EXPFAC3 = EXP( 4.5 * XLNSIG2 ) - T1P1 = DBLE(A1 + A2 * ALPHV2 * EXPFAC2) - T2P1 = DBLE(A3 * ALPHV3 * EXPFAC3) + T1P1 = DBLE(A1 + A2 * ALPHV2 * EXPFAC2) !(Wei Li) + T2P1 = DBLE(A3 * ALPHV3 * EXPFAC3) !(Wei Li) C***PENN1 is the analytic integral of the Pendorff formulae over C*** a log normal particle size distribution. - PENN1 = DBLE( THREE_PI_TWO * ( T1P1 + T2P1 ) ) - PENN2 = DBLE( THREE_PI_TWO * T2P1 ) + PENN1 = DBLE(THREE_PI_TWO * ( T1P1 + T2P1 )) !(Wei Li) + PENN2 = DBLE(THREE_PI_TWO * T2P1 ) !(Wei Li) END IF ! test of ni > 0.0 diff --git a/src/model/src/ASX_DATA_MOD.F b/src/model/src/ASX_DATA_MOD.F index 48d9258e..8270f494 100644 --- a/src/model/src/ASX_DATA_MOD.F +++ b/src/model/src/ASX_DATA_MOD.F @@ -30,6 +30,8 @@ Module ASX_DATA_MOD C Increased ar for ozone from 8 to 12. C Change meso from 0.1 to 0 for some org. nitrates C Changes based on Nguyen et al. 2015 PNAS and SOAS +C 07 May 2018 D. Schwede: Added call to CZANGLE here and removed call +C to CZANGLE in other modules C C---------Notes C * Updates based on literature review 7/96 JEP @@ -70,12 +72,20 @@ Module ASX_DATA_MOD C formulas. W. Hutzell (04/08) C %% G. Sarwar: added data for iodine and bromine species (03/2016) C %% B. Hutzell: added dry deposition data for methane, acrylic acid, methyl chloride, -C and acetonitrile (09/2016) +C and acetonitrile (09/2016) +C G. Sarwar: added ClNO3 and FMBR, and updated INO3 and BRNO3 name changes (07/2018) +C G. Sarwar: removed NACL (07/2018) +C G. Sarwar: made minor changes to halogen species and added several iodine species (12/2018) +C D. Wong: Implemented centralized I/O approach, removed all MY_N clauses, removed +C unnecessary SAVE attribute (02/2019) +C G. Sarwar: Removed CH3BR (03/2021) +C R. Gilliam: Include PX soil texture information when available (03/2022) C------------------------------------------------------------------------------- - + Use RUNTIME_VARS Use GRID_CONF ! horizontal & vertical domain specifications Use LSM_MOD ! Land surface data Use DEPVVARS, Only: ltotg + Use CENTRALIZED_IO_MODULE Implicit None @@ -83,16 +93,16 @@ Module ASX_DATA_MOD Type :: MET_Type !> 2-D meteorological fields: - Real, Allocatable :: RDEPVHT ( :,: ) ! air dens / dep vel ht + Real, Allocatable :: RDEPVHT ( :,: ) ! reciprocal layer 1 height [m-1] Real, Allocatable :: DENS1 ( :,: ) ! layer 1 air density Real, Allocatable :: PRSFC ( :,: ) ! surface pressure [Pa] Real, Allocatable :: Q2 ( :,: ) ! 2 meter water vapor mixing ratio [kg/kg] Real, Allocatable :: QSS_GRND ( :,: ) ! ground saturation water vapor mixing ratio [kg/kg] - Real, Allocatable :: RH ( :,: ) ! relative humidity [ratio] - Real, Allocatable :: RA ( :,: ) ! aerodynamic resistnace [s/m] - Real, Allocatable :: RS ( :,: ) ! stomatal resistnace [s/m] + Real, Allocatable :: RH2 ( :,: ) ! relative humidity [percent] + Real, Allocatable :: RA ( :,: ) ! aerodynamic resistance [s/m] + Real, Allocatable :: RS ( :,: ) ! stomatal resistance [s/m] Real, Allocatable :: RC ( :,: ) ! convective precipitation [cm] - Real, Allocatable :: RN ( :,: ) ! non-convective precipitation [mc] + Real, Allocatable :: RN ( :,: ) ! non-convective precipitation [cm] Real, Allocatable :: RGRND ( :,: ) ! Solar radiation at the ground [W/m**2] Real, Allocatable :: HFX ( :,: ) ! Sensible heat flux [W/m**2] Real, Allocatable :: LH ( :,: ) ! Latent heat flux [W/m**2] @@ -119,9 +129,11 @@ Module ASX_DATA_MOD Integer, Allocatable :: LPBL ( :,: ) ! PBL layer Logical, Allocatable :: CONVCT ( :,: ) ! convection flag Real, Allocatable :: PBL ( :,: ) ! pbl height (m) - Real, Allocatable :: NACL_EMIS( :,: ) ! NACL mass emission rate of particles with d <10 um (g/m2/s) +! Real, Allocatable :: NACL_EMIS( :,: ) ! NACL mass emission rate of particles with d <10 um (g/m2/s) + Real, Allocatable :: COSZEN ( :,: ) ! Cosine of the zenith angle + Real, Allocatable :: CFRAC ( :,: ) ! cloud fraction -!> Inline Canopy Processes +!> Inline Canopy Processes (Wei Li) Real, Allocatable :: FCH ( :,: ) ! Forest Canopy Height (m) Real, Allocatable :: FRT ( :,: ) ! Forest Fraction Real, Allocatable :: CLU ( :,: ) ! Clumping Index @@ -132,9 +144,9 @@ Module ASX_DATA_MOD Real, Allocatable :: C3R ( :,: ) ! cumulative LAI fraction hc to 0.35 * hc Real, Allocatable :: C4R ( :,: ) ! cumulative LAI fraction hc to 0.20 * hc -!> FENGSHA option - Real, Allocatable :: CLAYF ( :,: ) ! Fractional Clay Content - Real, Allocatable :: SANDF ( :,: ) ! Fractional Sand Content +!> FENGSHA option (Wei Li) + Real, Allocatable :: CLAYF ( :,: ) ! Fractional Clay Content + Real, Allocatable :: SANDF ( :,: ) ! Fractional Sand Content Real, Allocatable :: DRAG ( :,: ) ! Drag Partion Real, Allocatable :: UTHR ( :,: ) ! Dry Threshold Friction Velocity @@ -143,21 +155,22 @@ Module ASX_DATA_MOD Real, Allocatable :: VWIND ( :,:,: ) ! [m/s] !> 3-D meteorological fields: Real, Allocatable :: KZMIN ( :,:,: ) ! minimum Kz [m**2/s] - Real, Allocatable :: PRES ( :,:,: ) ! layer 1 pressure [Pa] - Real, Allocatable :: PRESF ( :,:,: ) ! full layer pressure [Pa] + Real, Allocatable :: PRES ( :,:,: ) ! pressure [Pa] + Real, Allocatable :: PRESF ( :,:,: ) ! full layer pressure [Pa] (Wei Li) Real, Allocatable :: QV ( :,:,: ) ! water vapor mixing ratio Real, Allocatable :: QC ( :,:,: ) ! cloud water mixing ratio Real, Allocatable :: THETAV ( :,:,: ) ! potential temp Real, Allocatable :: TA ( :,:,: ) ! temperature (K) + Real, Allocatable :: RH ( :,:,: ) ! relative humidity [ratio] Real, Allocatable :: ZH ( :,:,: ) ! mid-layer height above ground [m] Real, Allocatable :: ZF ( :,:,: ) ! layer height [m] - Real, Allocatable :: DZF ( :,:,: ) ! layer surface thickness + Real, Allocatable :: DZF ( :,:,: ) ! layer thickness Real, Allocatable :: DENS ( :,:,: ) ! air density Real, Allocatable :: RJACM ( :,:,: ) ! reciprocal mid-layer Jacobian Real, Allocatable :: RJACF ( :,:,: ) ! reciprocal full-layer Jacobian Real, Allocatable :: RRHOJ ( :,:,: ) ! reciprocal density X Jacobian - Real, Allocatable :: UWINDA ( :,:,: ) ! [m/s] - Real, Allocatable :: VWINDA ( :,:,: ) ! [m/s] + Real, Allocatable :: UWINDA ( :,:,: ) ! [m/s] (Wei Li) + Real, Allocatable :: VWINDA ( :,:,: ) ! [m/s] (Wei Li) End Type MET_Type Type :: GRID_Type @@ -171,61 +184,28 @@ Module ASX_DATA_MOD Real, Allocatable :: LON ( :,: ) ! longitude Real, Allocatable :: LAT ( :,: ) ! latitude Real, Allocatable :: LWMASK ( :,: ) ! land water mask - Real, Allocatable :: OCEAN ( :,: ) ! Open ocean - Real, Allocatable :: SZONE ( :,: ) ! Surf zone + Real, Allocatable :: OCEAN ( :,: ) ! Open ocean fraction + Real, Allocatable :: SZONE ( :,: ) ! Surf zone fraction Real, Allocatable :: PURB ( :,: ) ! percent urban [%] Integer, Allocatable :: SLTYP ( :,: ) ! soil type [category] - Real, Allocatable :: WSAT ( :,: ) ! soil wilting point + Real, Allocatable :: WSAT ( :,: ) ! volumetric soil saturation concentration Real, Allocatable :: WWLT ( :,: ) ! soil wilting point Real, Allocatable :: BSLP ( :,: ) ! B Slope Real, Allocatable :: WRES ( :,: ) ! Soil residual moisture point Real, Allocatable :: WFC ( :,: ) ! soil field capacity + Real, Allocatable :: CLAY_PX ( :,: ) ! Clay fraction from PX LSM + Real, Allocatable :: CSAND_PX ( :,: ) ! Coarse sand fraction from PX LSM + Real, Allocatable :: FMSAND_PX( :,: ) ! Fine-medium sand fraction from PX LSM ! Real, Allocatable :: RHOB ( :,: ) ! soil bulk density - Real, Allocatable :: LUFRAC ( :,:,: ) ! land use fraction (col,row,lu_type)[ratio] + Real, Allocatable :: LUFRAC ( :,:,: ) ! land use fraction (col,row,lu_type)[ratio] C Land use information: Character( 16 ), Allocatable :: NAME ( : ) ! LU name Character( 16 ), Allocatable :: LU_Type ( : ) ! general land use type e.g. water, forest, etc. End Type GRID_Type - Type :: MOSAIC_Type ! (col,row,lu) - Character( 16 ), Allocatable :: NAME ( : ) ! LU name - Character( 16 ), Allocatable :: LU_Type ( : ) ! general land use type e.g. water, forest, etc. -!> Sub grid cell meteorological variables: - Real, Allocatable :: USTAR ( :,:,: ) ! surface friction velocity [m/s] - Real, Allocatable :: LAI ( :,:,: ) ! leaf area index [m**2/m**2] - Real, Allocatable :: VEG ( :,:,: ) ! vegetation fraction [ratio] - Real, Allocatable :: Z0 ( :,:,: ) ! vegetation fraction [ratio] - Real, Allocatable :: DELTA ( :,:,: ) ! Surface wetness [ratio] -!> Sub grid cell resistances - Real, Allocatable :: RA ( :,:,: ) ! aerodynamic resistance [s/m] - Real, Allocatable :: RSTW ( :,:,: ) ! Stomatal Resistance of water [s/m] - Real, Allocatable :: RINC ( :,:,: ) ! In-canopy resistance [s/m] - End Type MOSAIC_Type - - Type :: ChemMos_Type ! (col,row,lu,spc) - Character( 16 ), Allocatable :: NAME ( : ) ! LU name - Character( 16 ), Allocatable :: Lu_Type ( : ) ! general land use type e.g. water, forest, etc. - Character( 16 ), Allocatable :: SubName ( : ) ! Deposition species name -!> Sub grid cell chemically dependent resistances - Real, Allocatable :: Rb ( :,:,:,: ) ! quasi-laminar boundary layer resistance [s/m] - Real, Allocatable :: Rst ( :,:,:,: ) ! stomatal resistance [s/m] - Real, Allocatable :: Rgc ( :,:,:,: ) ! Canopy covered soil resistance [s/m] - Real, Allocatable :: Rgb ( :,:,:,: ) ! Barron soil resistance [s/m] - Real, Allocatable :: Rcut ( :,:,:,: ) ! soil resistance [s/m] - Real, Allocatable :: Rwat ( :,:,:,: ) ! surface water resistance [s/m] -!> Sub grid cell compensation point - Real, Allocatable :: Catm ( :,:,:,: ) ! Atmospheric [ppm] - Real, Allocatable :: CZ0 ( :,:,:,: ) ! compensation point at Z0 [ppm] - Real, Allocatable :: Cleaf( :,:,:,: ) ! Leaf compensation point [ppm] - Real, Allocatable :: Cstom( :,:,:,: ) ! Stomatal compensation point [ppm] - Real, Allocatable :: Ccut ( :,:,:,: ) ! Cuticular compensation point [ppm] - Real, Allocatable :: Csoil( :,:,:,: ) ! Soil compensation point [ppm] - End Type ChemMos_Type - - Type( MET_Type ), Save :: Met_Data - Type( GRID_Type ), Save :: Grid_Data - Type( MOSAIC_Type ), Save :: Mosaic_Data - Type( ChemMos_Type ), Save :: ChemMos_Data + + Type( MET_Type ) :: Met_Data + Type( GRID_Type ) :: Grid_Data Integer, Save :: n_spc_m3dry = ltotg ! from DEPVVARS module !> M3 asx constants @@ -245,7 +225,7 @@ Module ASX_DATA_MOD Real, Parameter :: rg0 = 1000.0 ! [s/m] Real, Parameter :: rgwet0 = 25000.0 ! [s/m] Real, Parameter :: rsndiff = 10.0 ! snow diffusivity fac - Real, Parameter :: rsnow0 = 1000.0 + Real, Parameter :: rsnow0 = 10000.0 ! Changed from 1000 to 10000 - Helmig et al 2012 Real, Parameter :: svp2 = 17.67 ! from MM5 and WRF Real, Parameter :: svp3 = 29.65 ! from MM5 and WRF Real, Parameter :: rt25inK = 1.0/(stdtemp + 25.0) ! 298.15K = 25C @@ -268,154 +248,293 @@ Module ASX_DATA_MOD Character( 16 ) :: subname ( ltotg ) ! for subroutine HLCONST Logical, Save :: MET_INITIALIZED = .false. - Real, Save :: CONVPA ! Pressure conversion factor file units to Pa - Logical, Save :: MINKZ Logical, Save :: CSTAGUV ! Winds are available with C stagger? - Logical, Save :: ifwr = .false. +! Logical, Save :: ifwr = .false. - Public :: INIT_MET + Public :: INIT_MET, GET_MET - Logical, Private, Save :: ifsst = .false. - Logical, Private, Save :: ifq2 = .false. - Logical, Private, Save :: rinv = .True. - Logical, Private, Save :: iflh = .false. - Integer, Private :: C, R, L, S ! loop induction variables Integer, Private :: SPC Character( 16 ), Private, Save :: vname_rc, vname_rn, vname_uc, vname_vc - Real, Private, Save :: P0 ! reference pressure (100000.0 Pa) for Potential Temperature, note that in meteorology they do not use the SI 1 ATM. - - Integer, Private, Save :: LOGDEV - Integer, Private, Save :: GXOFF, GYOFF ! global origin offset from file - Integer, Private, Save :: STRTCOLMC3, ENDCOLMC3, STRTROWMC3, ENDROWMC3 ! MET_CRO_3D - Integer, Private, Save :: STRTCOLMD3, ENDCOLMD3, STRTROWMD3, ENDROWMD3 ! MET_DOT_3D - Integer, Private, Save :: STRTCOLMC2, ENDCOLMC2, STRTROWMC2, ENDROWMC2 ! MET_CRO_2D - Integer, Private, Save :: STRTCOL_O1, ENDCOL_O1, STRTROW_O1, ENDROW_O1 ! OCEAN_1 - Real, Pointer, Private :: BUFF1D( : ) ! 1D temp var number of layers - Real, Pointer, Private :: BUFF2D( :,: ) ! 2D temp var - Real, Pointer, Private :: BUFF3D( :,:,: ) ! 3D temp var + Real, allocatable, private :: BUFF1D( : ) ! 1D temp var number of layers + Real, allocatable, private :: BUFF2D( :,: ) ! 2D temp var + Real, allocatable, private :: BUFF3D( :,:,: ) ! 3D temp var -! Canopy option control +! Canopy option control (Wei Li) CHARACTER( 20 ), SAVE :: CTM_CANOPY_SHADE = 'CTM_CANOPY_SHADE '! env var for in-line LOGICAL, PUBLIC, SAVE :: CANOPY_SHADE ! flag in-lining canopy shading -! FENGSHA option control +! FENGSHA option control (Wei Li) CHARACTER( 18 ), SAVE :: CTM_WBDUST_FENGSHA = 'CTM_WBDUST_FENGSHA' ! env var for in-line LOGICAL, PUBLIC, SAVE :: FENGSHA ! flag for fengsha option INTEGER IOSX ! i/o and allocate memory status - DATA subname( 1), dif0( 1), ar( 1), meso( 1), lebas( 1) / 'SO2 ', 0.1089, 10.0, 0.0, 35.0/ - DATA subname( 2), dif0( 2), ar( 2), meso( 2), lebas( 2) / 'H2SO4 ', 0.1091, 8000.0, 0.0, 49.0/ - DATA subname( 3), dif0( 3), ar( 3), meso( 3), lebas( 3) / 'NO2 ', 0.1361, 2.0, 0.1, 21.0/ - DATA subname( 4), dif0( 4), ar( 4), meso( 4), lebas( 4) / 'NO ', 0.1802, 2.0, 0.0, 14.0/ - DATA subname( 5), dif0( 5), ar( 5), meso( 5), lebas( 5) / 'O3 ', 0.1444, 12.0, 1.0, 21.0/ - DATA subname( 6), dif0( 6), ar( 6), meso( 6), lebas( 6) / 'HNO3 ', 0.1067, 8000.0, 0.0, 35.0/ - DATA subname( 7), dif0( 7), ar( 7), meso( 7), lebas( 7) / 'H2O2 ', 0.1300,34000.0, 1.0, 28.0/ !ar=34,000 such that r_cut=0.7 s/m as in Nguyen et al. 2015 - DATA subname( 8), dif0( 8), ar( 8), meso( 8), lebas( 8) / 'ACETALDEHYDE ', 0.1111, 10.0, 0.0, 56.0/ - DATA subname( 9), dif0( 9), ar( 9), meso( 9), lebas( 9) / 'FORMALDEHYDE ', 0.1554, 10.0, 0.0, 35.0/ - DATA subname( 10), dif0( 10), ar( 10), meso( 10), lebas( 10) / 'METHYLHYDROPEROX', 0.1179, 10.0, 0.3, 49.0/ !meso change from 0.1 to 0.3, Wolfe and Thornton 2011 ACP per J. Bash - DATA subname( 11), dif0( 11), ar( 11), meso( 11), lebas( 11) / 'PEROXYACETIC_ACI', 0.0868, 20.0, 0.1, 70.0/ - DATA subname( 12), dif0( 12), ar( 12), meso( 12), lebas( 12) / 'ACETIC_ACID ', 0.0944, 20.0, 0.0, 63.0/ - DATA subname( 13), dif0( 13), ar( 13), meso( 13), lebas( 13) / 'NH3 ', 0.1978, 20.0, 0.0, 28.0/ - DATA subname( 14), dif0( 14), ar( 14), meso( 14), lebas( 14) / 'PAN ', 0.0687, 16.0, 0.1, 91.0/ - DATA subname( 15), dif0( 15), ar( 15), meso( 15), lebas( 15) / 'HNO2 ', 0.1349, 20.0, 0.1, 28.0/ - DATA subname( 16), dif0( 16), ar( 16), meso( 16), lebas( 16) / 'CO ', 0.1807, 5.0, 0.0, 14.0/ - DATA subname( 17), dif0( 17), ar( 17), meso( 17), lebas( 17) / 'METHANOL ', 0.1329, 2.0, 0.0, 42.0/ - DATA subname( 18), dif0( 18), ar( 18), meso( 18), lebas( 18) / 'N2O5 ', 0.0808, 5000.0, 0.0, 49.0/ - DATA subname( 19), dif0( 19), ar( 19), meso( 19), lebas( 19) / 'NO3 ', 0.1153, 5000.0, 0.0, 28.0/ - DATA subname( 20), dif0( 20), ar( 20), meso( 20), lebas( 20) / 'GENERIC_ALDEHYDE', 0.0916, 10.0, 0.0, 56.0/ - DATA subname( 21), dif0( 21), ar( 21), meso( 21), lebas( 21) / 'CL2 ', 0.1080, 10.0, 0.0, 49.0/ - DATA subname( 22), dif0( 22), ar( 22), meso( 22), lebas( 22) / 'HOCL ', 0.1300, 10.0, 0.0, 38.5/ - DATA subname( 23), dif0( 23), ar( 23), meso( 23), lebas( 23) / 'HCL ', 0.1510, 8000.0, 0.0, 31.5/ - DATA subname( 24), dif0( 24), ar( 24), meso( 24), lebas( 24) / 'FMCL ', 0.1094, 10.0, 0.0, 45.5/ - DATA subname( 25), dif0( 25), ar( 25), meso( 25), lebas( 25) / 'HG ', 0.1194, 0.1, 0.0, 14.8/ ! lebas not used - DATA subname( 26), dif0( 26), ar( 26), meso( 26), lebas( 26) / 'HGIIGAS ', 0.0976, 8000.0, 0.0, 95.0/ ! estimation from back calculating to get dw25 = 1.04e-5 (Garland et al, 1965) - DATA subname( 27), dif0( 27), ar( 27), meso( 27), lebas( 27) / 'TECDD_2378 ', 0.0525, 2.0, 0.0, 217.0/ - DATA subname( 28), dif0( 28), ar( 28), meso( 28), lebas( 28) / 'PECDD_12378 ', 0.0508, 2.0, 0.0, 234.5/ - DATA subname( 29), dif0( 29), ar( 29), meso( 29), lebas( 29) / 'HXCDD_123478 ', 0.0494, 2.0, 0.0, 252.0/ - DATA subname( 30), dif0( 30), ar( 30), meso( 30), lebas( 30) / 'HXCDD_123678 ', 0.0494, 2.0, 0.0, 252.0/ - DATA subname( 31), dif0( 31), ar( 31), meso( 31), lebas( 31) / 'HXCDD_123478 ', 0.0494, 2.0, 0.0, 252.0/ - DATA subname( 32), dif0( 32), ar( 32), meso( 32), lebas( 32) / 'HPCDD_1234678 ', 0.0480, 2.0, 0.0, 269.5/ - DATA subname( 33), dif0( 33), ar( 33), meso( 33), lebas( 33) / 'OTCDD ', 0.0474, 2.0, 0.0, 287.0/ - DATA subname( 34), dif0( 34), ar( 34), meso( 34), lebas( 34) / 'TECDF_2378 ', 0.0534, 2.0, 0.0, 210.0/ - DATA subname( 35), dif0( 35), ar( 35), meso( 35), lebas( 35) / 'PECDF_12378 ', 0.0517, 2.0, 0.0, 227.5/ - DATA subname( 36), dif0( 36), ar( 36), meso( 36), lebas( 36) / 'PECDF_23478 ', 0.0517, 2.0, 0.0, 227.5/ - DATA subname( 37), dif0( 37), ar( 37), meso( 37), lebas( 37) / 'HXCDF_123478 ', 0.0512, 2.0, 0.0, 245.0/ - DATA subname( 38), dif0( 38), ar( 38), meso( 38), lebas( 38) / 'HXCDF_123678 ', 0.0512, 2.0, 0.0, 245.0/ - DATA subname( 39), dif0( 39), ar( 39), meso( 39), lebas( 39) / 'HXCDF_234678 ', 0.0512, 2.0, 0.0, 245.0/ - DATA subname( 40), dif0( 40), ar( 40), meso( 40), lebas( 40) / 'HXCDF_123789 ', 0.0512, 2.0, 0.0, 245.0/ - DATA subname( 41), dif0( 41), ar( 41), meso( 41), lebas( 41) / 'HPCDF_1234678 ', 0.0487, 2.0, 0.0, 262.5/ - DATA subname( 42), dif0( 42), ar( 42), meso( 42), lebas( 42) / 'HPCDF_1234789 ', 0.0487, 2.0, 0.0, 262.5/ - DATA subname( 43), dif0( 43), ar( 43), meso( 43), lebas( 43) / 'OTCDF ', 0.0474, 2.0, 0.0, 280.0/ - DATA subname( 44), dif0( 44), ar( 44), meso( 44), lebas( 44) / 'NAPHTHALENE ', 0.0778, 4.0, 0.0, 119.0/ - DATA subname( 45), dif0( 45), ar( 45), meso( 45), lebas( 45) / '1NITRONAPHTHALEN', 0.0692, 4.0, 0.0, 133.0/ - DATA subname( 46), dif0( 46), ar( 46), meso( 46), lebas( 46) / '2NITRONAPHTHALEN', 0.0692, 4.0, 0.0, 133.0/ - DATA subname( 47), dif0( 47), ar( 47), meso( 47), lebas( 47) / '14NAPHTHOQUINONE', 0.0780, 4.0, 0.0, 119.0/ - DATA subname( 48), dif0( 48), ar( 48), meso( 48), lebas( 48) / 'HEXAMETHYLE_DIIS', 0.0380, 10.0, 0.0, 196.0/ - DATA subname( 49), dif0( 49), ar( 49), meso( 49), lebas( 49) / 'HYDRAZINE ', 0.4164, 20.0, 0.0, 42.0/ - DATA subname( 50), dif0( 50), ar( 50), meso( 50), lebas( 50) / 'MALEIC_ANHYDRIDE', 0.0950, 10.0, 0.0, 70.0/ - DATA subname( 51), dif0( 51), ar( 51), meso( 51), lebas( 51) / '24-TOLUENE_DIIS ', 0.0610, 10.0, 0.0, 154.0/ - DATA subname( 52), dif0( 52), ar( 52), meso( 52), lebas( 52) / 'TRIETHYLAMINE ', 0.0881, 20.0, 0.0, 154.0/ - DATA subname( 53), dif0( 53), ar( 53), meso( 53), lebas( 53) / 'ORG_NTR ', 0.0607, 16.0, 0.0, 160.0/ ! assumes 58.2% C5H11O4N and 41.8% C5H11O3N - DATA subname( 54), dif0( 54), ar( 54), meso( 54), lebas( 54) / 'HYDROXY_NITRATES', 0.0609, 16.0, 0.0, 156.1/ - DATA subname( 55), dif0( 55), ar( 55), meso( 55), lebas( 55) / 'MPAN ', 0.0580, 16.0, 0.1, 133.0/ - DATA subname( 56), dif0( 56), ar( 56), meso( 56), lebas( 56) / 'PPN ', 0.0631, 16.0, 0.1, 118.2/ - DATA subname( 57), dif0( 57), ar( 57), meso( 57), lebas( 57) / 'MVK ', 0.0810, 8.0, 1.0, 88.8/ - DATA subname( 58), dif0( 58), ar( 58), meso( 58), lebas( 58) / 'DINTR ', 0.0617, 16.0, 0.1, 169.8/ - DATA subname( 59), dif0( 59), ar( 59), meso( 59), lebas( 59) / 'NTR_ALK ', 0.0688, 16.0, 0.1, 133.0/ - DATA subname( 60), dif0( 60), ar( 60), meso( 60), lebas( 60) / 'NTR_OH ', 0.0665, 16.0, 0.1, 140.4/ - DATA subname( 61), dif0( 61), ar( 61), meso( 61), lebas( 61) / 'HYDROXY_NITRATES', 0.0646, 16.0, 0.0, 147.8/ - DATA subname( 62), dif0( 62), ar( 62), meso( 62), lebas( 62) / 'PROPNN ', 0.0677, 16.0, 0.0, 133.0/ - DATA subname( 63), dif0( 63), ar( 63), meso( 63), lebas( 63) / 'NITRYL_CHLORIDE ', 0.0888, 8.0, 0.0, 45.5/ ! dif0 estimated following Erickson III et al., JGR, 104, D7, 8347-8372, 1999 - DATA subname( 64), dif0( 64), ar( 64), meso( 64), lebas( 64) / 'ISOPNN ',0.0457, 8.0, 0.0, 206.8/ - DATA subname( 65), dif0( 65), ar( 65), meso( 65), lebas( 65) / 'MTNO3 ',0.0453, 8.0, 0.0, 251.2/ - DATA subname( 66), dif0( 66), ar( 66), meso( 66), lebas( 66) / 'IEPOX ',0.0579, 8.0, 0.0, 110.8/ - DATA subname( 67), dif0( 67), ar( 67), meso( 67), lebas( 67) / 'HACET ',0.1060, 8.0, 0.0, 72.6/ ! dif0 from Nguyen 2015 PNAS - DATA subname( 68), dif0( 68), ar( 68), meso( 68), lebas( 68) / 'SVALK1 ',0.0514, 20.0, 0.0, 280.5/ - DATA subname( 69), dif0( 69), ar( 69), meso( 69), lebas( 69) / 'SVALK2 ',0.0546, 20.0, 0.0, 275.6/ - DATA subname( 70), dif0( 70), ar( 70), meso( 70), lebas( 70) / 'SVBNZ1 ',0.0642, 20.0, 0.0, 134.1/ - DATA subname( 71), dif0( 71), ar( 71), meso( 71), lebas( 71) / 'SVBNZ2 ',0.0726, 20.0, 0.0, 127.5/ - DATA subname( 72), dif0( 72), ar( 72), meso( 72), lebas( 72) / 'SVISO1 ',0.0733, 20.0, 0.0, 126.3/ - DATA subname( 73), dif0( 73), ar( 73), meso( 73), lebas( 73) / 'SVISO2 ',0.0729, 20.0, 0.0, 123.8/ - DATA subname( 74), dif0( 74), ar( 74), meso( 74), lebas( 74) / 'SVPAH1 ',0.0564, 20.0, 0.0, 235.7/ - DATA subname( 75), dif0( 75), ar( 75), meso( 75), lebas( 75) / 'SVPAH2 ',0.0599, 20.0, 0.0, 231.5/ - DATA subname( 76), dif0( 76), ar( 76), meso( 76), lebas( 76) / 'SVSQT ',0.0451, 20.0, 0.0, 346.5/ - DATA subname( 77), dif0( 77), ar( 77), meso( 77), lebas( 77) / 'SVTOL1 ',0.0637, 20.0, 0.0, 153.7/ - DATA subname( 78), dif0( 78), ar( 78), meso( 78), lebas( 78) / 'SVTOL2 ',0.0607, 20.0, 0.0, 194.1/ - DATA subname( 79), dif0( 79), ar( 79), meso( 79), lebas( 79) / 'SVTRP1 ',0.0603, 20.0, 0.0, 194.9/ - DATA subname( 80), dif0( 80), ar( 80), meso( 80), lebas( 80) / 'SVTRP2 ',0.0559, 20.0, 0.0, 218.8/ - DATA subname( 81), dif0( 81), ar( 81), meso( 81), lebas( 81) / 'SVXYL1 ',0.0610, 20.0, 0.0, 154.6/ - DATA subname( 82), dif0( 82), ar( 82), meso( 82), lebas( 82) / 'SVXYL2 ',0.0585, 20.0, 0.0, 194.6/ - DATA subname( 83), dif0( 83), ar( 83), meso( 83), lebas( 83) / 'IO ',0.1002, 8.0, 0.0, 44.4/ - DATA subname( 84), dif0( 84), ar( 84), meso( 84), lebas( 84) / 'OIO ',0.0938, 8.0, 0.0, 51.8/ - DATA subname( 85), dif0( 85), ar( 85), meso( 85), lebas( 85) / 'I2O2 ',0.0732, 8.0, 0.0, 88.8/ - DATA subname( 86), dif0( 86), ar( 86), meso( 86), lebas( 86) / 'I2O3 ',0.0707, 8.0, 0.0, 96.2/ - DATA subname( 87), dif0( 87), ar( 87), meso( 87), lebas( 87) / 'I2O4 ',0.0684, 8.0, 0.0, 103.6/ - DATA subname( 88), dif0( 88), ar( 88), meso( 88), lebas( 88) / 'HI ',0.1045, 8.0, 0.0, 40.7/ - DATA subname( 89), dif0( 89), ar( 89), meso( 89), lebas( 89) / 'HOI ',0.0972, 8.0, 0.0, 48.1/ - DATA subname( 90), dif0( 90), ar( 90), meso( 90), lebas( 90) / 'INO ',0.0882, 8.0, 0.0, 60.9/ - DATA subname( 91), dif0( 91), ar( 91), meso( 91), lebas( 91) / 'INO2 ',0.0883, 20.0, 0.0, 69.2/ - DATA subname( 92), dif0( 92), ar( 92), meso( 92), lebas( 92) / 'IONO2 ',0.0792, 8.0, 0.0, 77.5/ - DATA subname( 93), dif0( 93), ar( 93), meso( 93), lebas( 93) / 'BRO ',0.1144, 1.0, 0.0, 34.4/ - DATA subname( 94), dif0( 94), ar( 94), meso( 94), lebas( 94) / 'HOBR ',0.1101, 1.0, 0.0, 38.1/ - DATA subname( 95), dif0( 95), ar( 95), meso( 95), lebas( 95) / 'HBR ',0.1216, 2.0, 0.0, 30.7/ - DATA subname( 96), dif0( 96), ar( 96), meso( 96), lebas( 96) / 'BRONO2 ',0.0855, 1.0, 0.0, 67.5/ - DATA subname( 97), dif0( 97), ar( 97), meso( 97), lebas( 97) / 'BRNO2 ',0.0909, 1.0, 0.0, 59.2/ - DATA subname( 98), dif0( 98), ar( 98), meso( 98), lebas( 98) / 'BRCL ',0.0966, 1.0, 0.0, 51.6/ - DATA subname( 99), dif0( 99), ar( 99), meso( 99), lebas( 99) / 'DMS ',0.0926, 2.0, 0.0, 77.4/ - DATA subname(100), dif0(100), ar(100), meso(100), lebas(100) / 'MSA ',0.0896, 2.0, 0.0, 77.4/ - DATA subname(101), dif0(101), ar(101), meso(101), lebas(101) / 'METHANE ',0.2107, 2.0, 0.0, 29.6/ ! dif0, equation 9-22. Scwarzenbach et. (1993) Env. Org. Chem. - DATA subname(102), dif0(102), ar(102), meso(102), lebas(102) / 'ACRYACID ',0.0908, 2.0, 0.0, 63.2/ - DATA subname(103), dif0(103), ar(103), meso(103), lebas(103) / 'CARBSULFIDE ',0.1240, 5.0, 0.0, 51.5/ - DATA subname(104), dif0(104), ar(104), meso(104), lebas(104) / 'ACETONITRILE ',0.1280, 5.0, 0.0, 52.3/ - DATA subname(105), dif0(105), ar(105), meso(105), lebas(105) / '6_NITRO_O_CRESOL',0.0664, 16.0, 0.0, 155.0/ ! dif0, equation 9-22. Scwarzenbach et. (1993) Env. Org. Chem. + DATA subname( 1), dif0( 1), ar( 1), meso( 1), lebas( 1) / 'SO2 ', 0.1089, 10.0, 0.0, 35.0 / + DATA subname( 2), dif0( 2), ar( 2), meso( 2), lebas( 2) / 'H2SO4 ', 0.1091, 8000.0, 0.0, 49.0 / + DATA subname( 3), dif0( 3), ar( 3), meso( 3), lebas( 3) / 'NO2 ', 0.1361, 2.0, 0.1, 21.0 / + DATA subname( 4), dif0( 4), ar( 4), meso( 4), lebas( 4) / 'NO ', 0.1802, 2.0, 0.0, 14.0 / + DATA subname( 5), dif0( 5), ar( 5), meso( 5), lebas( 5) / 'O3 ', 0.1444, 12.0, 1.0, 21.0 / + DATA subname( 6), dif0( 6), ar( 6), meso( 6), lebas( 6) / 'HNO3 ', 0.1067, 8000.0, 0.0, 35.0 / + DATA subname( 7), dif0( 7), ar( 7), meso( 7), lebas( 7) / 'H2O2 ', 0.1300,34000.0, 1.0, 28.0 / !ar=34,000 such that r_cut=0.7 s/m as in Nguyen et al. 2015 + DATA subname( 8), dif0( 8), ar( 8), meso( 8), lebas( 8) / 'ACETALDEHYDE ', 0.1111, 10.0, 0.0, 56.0 / + DATA subname( 9), dif0( 9), ar( 9), meso( 9), lebas( 9) / 'FORMALDEHYDE ', 0.1554, 10.0, 0.0, 35.0 / + DATA subname( 10), dif0( 10), ar( 10), meso( 10), lebas( 10) / 'METHYLHYDROPEROX', 0.1179, 10.0, 0.3, 49.0 / !meso change from 0.1 to 0.3, Wolfe and Thornton 2011 ACP per J. Bash + DATA subname( 11), dif0( 11), ar( 11), meso( 11), lebas( 11) / 'PEROXYACETIC_ACI', 0.0868, 20.0, 0.1, 70.0 / + DATA subname( 12), dif0( 12), ar( 12), meso( 12), lebas( 12) / 'ACETIC_ACID ', 0.0944, 20.0, 0.0, 63.0 / + DATA subname( 13), dif0( 13), ar( 13), meso( 13), lebas( 13) / 'NH3 ', 0.1978, 20.0, 0.0, 28.0 / + DATA subname( 14), dif0( 14), ar( 14), meso( 14), lebas( 14) / 'PAN ', 0.0687, 16.0, 0.1, 91.0 / + DATA subname( 15), dif0( 15), ar( 15), meso( 15), lebas( 15) / 'HNO2 ', 0.1349, 20.0, 0.1, 28.0 / + DATA subname( 16), dif0( 16), ar( 16), meso( 16), lebas( 16) / 'CO ', 0.1807, 5.0, 0.0, 14.0 / + DATA subname( 17), dif0( 17), ar( 17), meso( 17), lebas( 17) / 'METHANOL ', 0.1329, 2.0, 0.0, 42.0 / + DATA subname( 18), dif0( 18), ar( 18), meso( 18), lebas( 18) / 'N2O5 ', 0.0808, 5000.0, 0.0, 49.0 / + DATA subname( 19), dif0( 19), ar( 19), meso( 19), lebas( 19) / 'NO3 ', 0.1153, 5000.0, 0.0, 28.0 / + DATA subname( 20), dif0( 20), ar( 20), meso( 20), lebas( 20) / 'GENERIC_ALDEHYDE', 0.0916, 10.0, 0.0, 56.0 / + DATA subname( 21), dif0( 21), ar( 21), meso( 21), lebas( 21) / 'CL2 ', 0.1080, 10.0, 0.0, 49.0 / + DATA subname( 22), dif0( 22), ar( 22), meso( 22), lebas( 22) / 'HOCL ', 0.1300, 10.0, 0.0, 38.5 / ! used value of HCL + DATA subname( 23), dif0( 23), ar( 23), meso( 23), lebas( 23) / 'HCL ', 0.1510, 8000.0, 0.0, 31.5 / + DATA subname( 24), dif0( 24), ar( 24), meso( 24), lebas( 24) / 'FMCL ', 0.1094, 10.0, 0.0, 45.5 / ! default value + DATA subname( 25), dif0( 25), ar( 25), meso( 25), lebas( 25) / 'HG ', 0.1194, 0.1, 0.0, 14.8 / ! lebas not used + DATA subname( 26), dif0( 26), ar( 26), meso( 26), lebas( 26) / 'HGIIGAS ', 0.0976, 8000.0, 0.0, 95.0 / ! estimation from back calculating to get dw25 = 1.04e-5 (Garland et al, 1965) + DATA subname( 27), dif0( 27), ar( 27), meso( 27), lebas( 27) / 'TECDD_2378 ', 0.0525, 2.0, 0.0, 217.0 / + DATA subname( 28), dif0( 28), ar( 28), meso( 28), lebas( 28) / 'PECDD_12378 ', 0.0508, 2.0, 0.0, 234.5 / + DATA subname( 29), dif0( 29), ar( 29), meso( 29), lebas( 29) / 'HXCDD_123478 ', 0.0494, 2.0, 0.0, 252.0 / + DATA subname( 30), dif0( 30), ar( 30), meso( 30), lebas( 30) / 'HXCDD_123678 ', 0.0494, 2.0, 0.0, 252.0 / + DATA subname( 31), dif0( 31), ar( 31), meso( 31), lebas( 31) / 'HXCDD_123478 ', 0.0494, 2.0, 0.0, 252.0 / + DATA subname( 32), dif0( 32), ar( 32), meso( 32), lebas( 32) / 'HPCDD_1234678 ', 0.0480, 2.0, 0.0, 269.5 / + DATA subname( 33), dif0( 33), ar( 33), meso( 33), lebas( 33) / 'OTCDD ', 0.0474, 2.0, 0.0, 287.0 / + DATA subname( 34), dif0( 34), ar( 34), meso( 34), lebas( 34) / 'TECDF_2378 ', 0.0534, 2.0, 0.0, 210.0 / + DATA subname( 35), dif0( 35), ar( 35), meso( 35), lebas( 35) / 'PECDF_12378 ', 0.0517, 2.0, 0.0, 227.5 / + DATA subname( 36), dif0( 36), ar( 36), meso( 36), lebas( 36) / 'PECDF_23478 ', 0.0517, 2.0, 0.0, 227.5 / + DATA subname( 37), dif0( 37), ar( 37), meso( 37), lebas( 37) / 'HXCDF_123478 ', 0.0512, 2.0, 0.0, 245.0 / + DATA subname( 38), dif0( 38), ar( 38), meso( 38), lebas( 38) / 'HXCDF_123678 ', 0.0512, 2.0, 0.0, 245.0 / + DATA subname( 39), dif0( 39), ar( 39), meso( 39), lebas( 39) / 'HXCDF_234678 ', 0.0512, 2.0, 0.0, 245.0 / + DATA subname( 40), dif0( 40), ar( 40), meso( 40), lebas( 40) / 'HXCDF_123789 ', 0.0512, 2.0, 0.0, 245.0 / + DATA subname( 41), dif0( 41), ar( 41), meso( 41), lebas( 41) / 'HPCDF_1234678 ', 0.0487, 2.0, 0.0, 262.5 / + DATA subname( 42), dif0( 42), ar( 42), meso( 42), lebas( 42) / 'HPCDF_1234789 ', 0.0487, 2.0, 0.0, 262.5 / + DATA subname( 43), dif0( 43), ar( 43), meso( 43), lebas( 43) / 'OTCDF ', 0.0474, 2.0, 0.0, 280.0 / + DATA subname( 44), dif0( 44), ar( 44), meso( 44), lebas( 44) / 'NAPHTHALENE ', 0.0778, 4.0, 0.0, 119.0 / !Julin et al. 2014 doi:10.1021/es501816h + DATA subname( 45), dif0( 45), ar( 45), meso( 45), lebas( 45) / '1NITRONAPHTHALEN', 0.0692, 4.0, 0.0, 133.0 / + DATA subname( 46), dif0( 46), ar( 46), meso( 46), lebas( 46) / '2NITRONAPHTHALEN', 0.0692, 4.0, 0.0, 133.0 / + DATA subname( 47), dif0( 47), ar( 47), meso( 47), lebas( 47) / '14NAPHTHOQUINONE', 0.0780, 4.0, 0.0, 119.0 / + DATA subname( 48), dif0( 48), ar( 48), meso( 48), lebas( 48) / 'HEXAMETHYLE_DIIS', 0.0380, 10.0, 0.0, 196.0 / + DATA subname( 49), dif0( 49), ar( 49), meso( 49), lebas( 49) / 'HYDRAZINE ', 0.4164, 20.0, 0.0, 42.0 / + DATA subname( 50), dif0( 50), ar( 50), meso( 50), lebas( 50) / 'MALEIC_ANHYDRIDE', 0.0950, 10.0, 0.0, 70.0 / + DATA subname( 51), dif0( 51), ar( 51), meso( 51), lebas( 51) / '24-TOLUENE_DIIS ', 0.0610, 10.0, 0.0, 154.0 / + DATA subname( 52), dif0( 52), ar( 52), meso( 52), lebas( 52) / 'TRIETHYLAMINE ', 0.0881, 20.0, 0.0, 154.0 / + DATA subname( 53), dif0( 53), ar( 53), meso( 53), lebas( 53) / 'ORG_NTR ', 0.0607, 16.0, 0.0, 160.0 / ! assumes 58.2% C5H11O4N and 41.8% C5H11O3N + DATA subname( 54), dif0( 54), ar( 54), meso( 54), lebas( 54) / 'HYDROXY_NITRATES', 0.0609, 16.0, 0.0, 156.1 / + DATA subname( 55), dif0( 55), ar( 55), meso( 55), lebas( 55) / 'MPAN ', 0.0580, 16.0, 0.1, 133.0 / + DATA subname( 56), dif0( 56), ar( 56), meso( 56), lebas( 56) / 'PPN ', 0.0631, 16.0, 0.1, 118.2 / + DATA subname( 57), dif0( 57), ar( 57), meso( 57), lebas( 57) / 'METHACROLEIN ', 0.0810, 8.0, 1.0, 88.8 / + DATA subname( 58), dif0( 58), ar( 58), meso( 58), lebas( 58) / 'DINTR ', 0.0617, 16.0, 0.1, 169.8 / + DATA subname( 59), dif0( 59), ar( 59), meso( 59), lebas( 59) / 'NTR_ALK ', 0.0688, 16.0, 0.1, 133.0 / + DATA subname( 60), dif0( 60), ar( 60), meso( 60), lebas( 60) / 'NTR_OH ', 0.0665, 16.0, 0.1, 140.4 / + DATA subname( 61), dif0( 61), ar( 61), meso( 61), lebas( 61) / 'HYDROXY_NITRATES', 0.0646, 16.0, 0.0, 147.8 / + DATA subname( 62), dif0( 62), ar( 62), meso( 62), lebas( 62) / 'PROPNN ', 0.0677, 16.0, 0.0, 133.0 / + DATA subname( 63), dif0( 63), ar( 63), meso( 63), lebas( 63) / 'NITRYL_CHLORIDE ', 0.0888, 8.0, 0.0, 45.5 / ! dif0 estimated following Erickson III et al., JGR, 104, D7, 8347-8372, 1999 + DATA subname( 64), dif0( 64), ar( 64), meso( 64), lebas( 64) / 'ISOPNN ',0.0457, 275.9, 0.0, 206.8 / + DATA subname( 65), dif0( 65), ar( 65), meso( 65), lebas( 65) / 'MTNO3 ',0.0453, 96.2, 0.0, 251.2 / + DATA subname( 66), dif0( 66), ar( 66), meso( 66), lebas( 66) / 'IEPOX ',0.0579, 8.0, 0.0, 110.8 / + DATA subname( 67), dif0( 67), ar( 67), meso( 67), lebas( 67) / 'HACET ',0.1060, 8.0, 0.0, 72.6 / ! dif0 from Nguyen 2015 PNAS + DATA subname( 68), dif0( 68), ar( 68), meso( 68), lebas( 68) / 'SVALK1 ',0.0514, 4572.8, 0.0, 280.5 / ! Pye et al. doi:10.5194/acp-17-343-2017; rel. reactivity per J. Bash + DATA subname( 69), dif0( 69), ar( 69), meso( 69), lebas( 69) / 'SVALK2 ',0.0546, 12.9, 0.0, 275.6 / + DATA subname( 70), dif0( 70), ar( 70), meso( 70), lebas( 70) / 'SVBNZ1 ',0.0642,20671.2, 0.0, 134.1 / + DATA subname( 71), dif0( 71), ar( 71), meso( 71), lebas( 71) / 'SVBNZ2 ',0.0726, 52.5, 0.0, 127.5 / + DATA subname( 72), dif0( 72), ar( 72), meso( 72), lebas( 72) / 'SVISO1 ',0.0733, 50.6, 0.0, 126.3 / + DATA subname( 73), dif0( 73), ar( 73), meso( 73), lebas( 73) / 'SVISO2 ',0.0729,10009.0, 0.0, 123.8 / + DATA subname( 74), dif0( 74), ar( 74), meso( 74), lebas( 74) / 'SVPAH1 ',0.0564, 772.1, 0.0, 235.7 / + DATA subname( 75), dif0( 75), ar( 75), meso( 75), lebas( 75) / 'SVPAH2 ',0.0599, 4.8, 0.0, 231.5 / + DATA subname( 76), dif0( 76), ar( 76), meso( 76), lebas( 76) / 'SVSQT ',0.0451, 10.3, 0.0, 346.5 / + DATA subname( 77), dif0( 77), ar( 77), meso( 77), lebas( 77) / 'SVTOL1 ',0.0637, 1928.3, 0.0, 153.7 / + DATA subname( 78), dif0( 78), ar( 78), meso( 78), lebas( 78) / 'SVTOL2 ',0.0607, 111.6, 0.0, 194.1 / + DATA subname( 79), dif0( 79), ar( 79), meso( 79), lebas( 79) / 'SVTRP1 ',0.0603, 160.1, 0.0, 194.9 / + DATA subname( 80), dif0( 80), ar( 80), meso( 80), lebas( 80) / 'SVTRP2 ',0.0559, 13.0, 0.0, 218.8 / + DATA subname( 81), dif0( 81), ar( 81), meso( 81), lebas( 81) / 'SVXYL1 ',0.0610, 3586.7, 0.0, 154.6 / + DATA subname( 82), dif0( 82), ar( 82), meso( 82), lebas( 82) / 'SVXYL2 ',0.0585, 72.2, 0.0, 194.6 / + DATA subname( 83), dif0( 83), ar( 83), meso( 83), lebas( 83) / 'IO ',0.1004, 8.0, 0.0, 45.5 / + DATA subname( 84), dif0( 84), ar( 84), meso( 84), lebas( 84) / 'OIO ',0.0940, 8.0, 0.0, 52.5 / + DATA subname( 85), dif0( 85), ar( 85), meso( 85), lebas( 85) / 'I2O2 ',0.0734, 8.0, 0.0, 91.0 / + DATA subname( 86), dif0( 86), ar( 86), meso( 86), lebas( 86) / 'I2O3 ',0.0709, 8.0, 0.0, 98.0 / + DATA subname( 87), dif0( 87), ar( 87), meso( 87), lebas( 87) / 'I2O4 ',0.0686, 8.0, 0.0, 105.0 / + DATA subname( 88), dif0( 88), ar( 88), meso( 88), lebas( 88) / 'HI ',0.1047, 8.0, 0.0, 45.5 / + DATA subname( 89), dif0( 89), ar( 89), meso( 89), lebas( 89) / 'HOI ',0.0974, 8.0, 0.0, 52.5 / + DATA subname( 90), dif0( 90), ar( 90), meso( 90), lebas( 90) / 'INO ',0.0885, 8.0, 0.0, 52.5 / + DATA subname( 91), dif0( 91), ar( 91), meso( 91), lebas( 91) / 'INO2 ',0.0835, 20.0, 0.0, 59.5 / + DATA subname( 92), dif0( 92), ar( 92), meso( 92), lebas( 92) / 'INO3 ',0.0794, 8.0, 0.0, 66.5 / + DATA subname( 93), dif0( 93), ar( 93), meso( 93), lebas( 93) / 'BRO ',0.1146, 1.0, 0.0, 38.5 / + DATA subname( 94), dif0( 94), ar( 94), meso( 94), lebas( 94) / 'HOBR ',0.1104, 1.0, 0.0, 45.5 / + DATA subname( 95), dif0( 95), ar( 95), meso( 95), lebas( 95) / 'HBR ',0.1219, 2.0, 0.0, 38.5 / + DATA subname( 96), dif0( 96), ar( 96), meso( 96), lebas( 96) / 'BRNO3 ',0.0871, 1.0, 0.0, 59.5 / + DATA subname( 97), dif0( 97), ar( 97), meso( 97), lebas( 97) / 'BRNO2 ',0.0922, 1.0, 0.0, 52.5 / + DATA subname( 98), dif0( 98), ar( 98), meso( 98), lebas( 98) / 'BRCL ',0.0968, 1.0, 0.0, 56.0 / + DATA subname( 99), dif0( 99), ar( 99), meso( 99), lebas( 99) / 'DMS ',0.0896, 2.0, 0.0, 77.0 / + DATA subname(100), dif0(100), ar(100), meso(100), lebas(100) / 'MSA ',0.0844, 2.0, 0.0, 77.0 / + DATA subname(101), dif0(101), ar(101), meso(101), lebas(101) / 'METHANE ',0.2107, 2.0, 0.0, 29.6 / ! dif0, eqn 9-22 Schwarzenbach Gschwend & Imboden (1993) Env Org Chem + DATA subname(102), dif0(102), ar(102), meso(102), lebas(102) / 'ACRYACID ',0.0908, 2.0, 0.0, 63.2 / + DATA subname(103), dif0(103), ar(103), meso(103), lebas(103) / 'CARBSULFIDE ',0.1240, 5.0, 0.0, 51.5 / + DATA subname(104), dif0(104), ar(104), meso(104), lebas(104) / 'ACETONITRILE ',0.1280, 5.0, 0.0, 52.3 / + DATA subname(105), dif0(105), ar(105), meso(105), lebas(105) / '6_NITRO_O_CRESOL',0.0664, 16.0, 0.0, 155.0 / ! dif0, eqn 9-22 Schwarzenbach Gschwend & Imboden (1993) Env Org Chem + DATA subname(106), dif0(106), ar(106), meso(106), lebas(106) / 'GENERIC_ALDEHYDE',0.0646, 10.0, 0.0, 56.0 / ! PCVOC + DATA subname(107), dif0(107), ar(107), meso(107), lebas(107) / 'NTR_OH ',0.0722, 16.0, 0.1, 140.4 / ! INTR + DATA subname(108), dif0(108), ar(108), meso(108), lebas(108) / 'METHYLHYDROPEROX',0.0853, 10.0, 0.3, 49.0 / ! ISPX diffusion should be ~ 0.0710 according to Wolfe and thornton 2011 ACP + DATA subname(109), dif0(109), ar(109), meso(109), lebas(109) / 'METHYLHYDROPEROX',0.1371, 10.0, 0.3, 49.0 / ! ROOH diffusion should be ~ 0.0710 according to Wolfe and thornton 2011 ACP + DATA subname(110), dif0(110), ar(110), meso(110), lebas(110) / 'ADIPIC_ACID ',0.0646,90000.0, 0.0, 63.0 / ! LVPCSOG + DATA subname(111), dif0(111), ar(111), meso(111), lebas(111) / 'ADIPIC_ACID ',0.0456, 4.2, 0.0, 63.0 / ! VIVPO1 + DATA subname(112), dif0(112), ar(112), meso(112), lebas(112) / 'ADIPIC_ACID ',0.0766,71624.8, 0.0, 63.0 / ! VLVOO1 + DATA subname(113), dif0(113), ar(113), meso(113), lebas(113) / 'ADIPIC_ACID ',0.0766, 9042.0, 0.0, 63.0 / ! VLVOO2 + DATA subname(114), dif0(114), ar(114), meso(114), lebas(114) / 'ADIPIC_ACID ',0.0533,13818.0, 0.0, 63.0 / ! VLVPO1 + DATA subname(115), dif0(115), ar(115), meso(115), lebas(115) / 'ADIPIC_ACID ',0.0771, 1133.9, 0.0, 63.0 / ! VSVOO1 + DATA subname(116), dif0(116), ar(116), meso(116), lebas(116) / 'ADIPIC_ACID ',0.0771, 18.1, 0.0, 63.0 / ! VSVOO2 + DATA subname(117), dif0(117), ar(117), meso(117), lebas(117) / 'ADIPIC_ACID ',0.0775, 2.3, 0.0, 63.0 / ! VSVOO3 + DATA subname(118), dif0(118), ar(118), meso(118), lebas(118) / 'ADIPIC_ACID ',0.0511, 1830.5, 0.0, 63.0 / ! VSVPO1 + DATA subname(119), dif0(119), ar(119), meso(119), lebas(119) / 'ADIPIC_ACID ',0.0493, 241.0, 0.0, 63.0 / ! VSVPO2 + DATA subname(120), dif0(120), ar(120), meso(120), lebas(120) / 'ADIPIC_ACID ',0.0474, 31.8, 0.0, 63.0 / ! VSVPO3 + DATA subname(121), dif0(121), ar(121), meso(121), lebas(121) / 'FORMIC_ACID ',0.1411, 20.0, 0.0, 63.0 / ! FACD + DATA subname(122), dif0(122), ar(122), meso(122), lebas(122) / 'MEK ',0.0859, 1.0, 0.0, 108.2 / ! KET different in different mechanisms + DATA subname(123), dif0(123), ar(123), meso(123), lebas(123) / 'ETHENE ',0.1366, 1.0, 0.0, 58.1 / ! ETH + DATA subname(124), dif0(124), ar(124), meso(124), lebas(124) / 'HNO4 ',0.1233, 1.0, 0.0, 45.2 / ! PNA + DATA subname(125), dif0(125), ar(125), meso(125), lebas(125) / 'GLYOXAL ',0.1188, 1.0, 0.0, 56.2 / ! GLY + DATA subname(126), dif0(126), ar(126), meso(126), lebas(126) / 'GLYOXAL ',0.1181, 1.0, 0.0, 56.4 / ! GLYD + DATA subname(127), dif0(127), ar(127), meso(127), lebas(127) / 'METHYL_GLYOXAL ',0.1038, 1.0, 0.0, 72.5 / ! MGLY + DATA subname(128), dif0(128), ar(128), meso(128), lebas(128) / 'ETHANE ',0.1312, 1.0, 0.0, 61.5 / ! ETHA + DATA subname(129), dif0(129), ar(129), meso(129), lebas(129) / 'ETHANOL ',0.1213, 1.0, 0.0, 59.1 / ! ETOH + DATA subname(130), dif0(130), ar(130), meso(130), lebas(130) / 'ETHANE ',0.0870, 1.0, 0.0, 111.1 / ! PAR as Pentane + DATA subname(131), dif0(131), ar(131), meso(131), lebas(131) / 'ACETONE ',0.1057, 1.0, 0.0, 75.2 / ! ACET + DATA subname(132), dif0(132), ar(132), meso(132), lebas(132) / 'PROPANE ',0.1095, 1.0, 0.0, 78.1 / ! PRPA + DATA subname(133), dif0(133), ar(133), meso(133), lebas(133) / 'ACETYLENE ',0.1523, 1.0, 0.0, 45.8 / ! ETHY + DATA subname(134), dif0(134), ar(134), meso(134), lebas(134) / 'ETHENE ',0.1135, 1.0, 0.0, 73.1 / ! OLE as Propene + DATA subname(135), dif0(135), ar(135), meso(135), lebas(135) / 'ETHENE ',0.0990, 1.0, 0.0, 89.5 / ! IOLE as Isobutene + DATA subname(136), dif0(136), ar(136), meso(136), lebas(136) / 'MEK ',0.0852, 1.0, 0.0, 101.2 / ! IEPOX different scavenging H in CB05 and CB06 + DATA subname(137), dif0(137), ar(137), meso(137), lebas(137) / 'BENZENE ',0.0942, 1.0, 0.0, 89.4 / ! BENZENE + DATA subname(138), dif0(138), ar(138), meso(138), lebas(138) / '2-CRESOL ',0.0850, 1.0, 0.0, 108.1 / ! CRES + DATA subname(139), dif0(139), ar(139), meso(139), lebas(139) / 'TOLUENE ',0.0860, 1.0, 0.0, 105.7 / ! TOL + DATA subname(140), dif0(140), ar(140), meso(140), lebas(140) / 'O-XYLENE ',0.0796, 1.0, 0.0, 122.0 / ! XYLMN + DATA subname(141), dif0(141), ar(141), meso(141), lebas(141) / 'O-XYLENE ',0.0777, 1.0, 0.0, 123.5 / ! NAPH + DATA subname(142), dif0(142), ar(142), meso(142), lebas(142) / 'PHENOL ',0.0844, 1.0, 0.0, 102.6 / ! CAT1 + DATA subname(143), dif0(143), ar(143), meso(143), lebas(143) / 'PINENE ',0.0545, 1.0, 0.0, 251.5 / ! SESQ + DATA subname(144), dif0(144), ar(144), meso(144), lebas(144) / 'PINENE ',0.0700, 1.0, 0.0, 136.2 / ! TERP + DATA subname(145), dif0(145), ar(145), meso(145), lebas(145) / 'ISOPRENE ',0.0913, 1.0, 0.0, 136.2 / ! ISOP + DATA subname(146), dif0(146), ar(146), meso(146), lebas(146) / 'METHACROLEIN ',0.1033, 1.0, 0.0, 69.6 / ! OPEN C4H4O2 + DATA subname(147), dif0(147), ar(147), meso(147), lebas(147) / 'MEK ',0.0950, 1.0, 0.0, 81.7 / ! XOPN C5H6O2 + DATA subname(148), dif0(148), ar(148), meso(148), lebas(148) / 'DECANE ',0.0739, 1.0, 0.0, 142.8 / ! SOAALK as Propylcyclopentane + DATA subname(149), dif0(149), ar(149), meso(149), lebas(149) / '13-BUTADIENE ',0.1019, 1.0, 0.0, 84.8 / ! BUTADIENE13 + DATA subname(150), dif0(150), ar(150), meso(150), lebas(150) / 'ACROLEIN ',0.1092, 1.0, 0.0, 70.5 / + DATA subname(151), dif0(151), ar(151), meso(151), lebas(151) / 'SVMT1 ',0.0424, 20.0, 0.0, 355.2/ ! see Xu et al., 2018 ACPD: doi:10.5194/acp-2017-1109 + DATA subname(152), dif0(152), ar(152), meso(152), lebas(152) / 'SVMT2 ',0.0556, 20.0, 0.0, 236.8/ + DATA subname(153), dif0(153), ar(153), meso(153), lebas(153) / 'SVMT3 ',0.0583, 20.0, 0.0, 214.6/ + DATA subname(154), dif0(154), ar(154), meso(154), lebas(154) / 'SVMT4 ',0.0587, 20.0, 0.0, 229.4/ + DATA subname(155), dif0(155), ar(155), meso(155), lebas(155) / 'SVMT5 ',0.0619, 20.0, 0.0, 207.2/ + DATA subname(156), dif0(156), ar(156), meso(156), lebas(156) / 'SVMT6 ',0.0624, 20.0, 0.0, 222.0/ + DATA subname(157), dif0(157), ar(157), meso(157), lebas(157) / 'SVMT7 ',0.0661, 20.0, 0.0, 199.8/ + DATA subname(158), dif0(158), ar(158), meso(158), lebas(158) / 'SVAVB1 ',0.0560,100388.0, 0.0, 163.1/ + DATA subname(159), dif0(159), ar(159), meso(159), lebas(159) / 'SVAVB2 ',0.0600, 1461.2, 0.0, 163.2/ + DATA subname(160), dif0(160), ar(160), meso(160), lebas(160) / 'SVAVB3 ',0.0620, 175.2, 0.0, 163.0/ + DATA subname(161), dif0(161), ar(161), meso(161), lebas(161) / 'SVAVB4 ',0.0650, 20.8, 0.0, 162.7/ + DATA subname(162), dif0(162), ar(162), meso(162), lebas(162) / 'CLNO3 ',0.0902, 8.0, 0.0, 52.5/ + DATA subname(163), dif0(163), ar(163), meso(163), lebas(163) / 'FMBR ',0.0965, 10.0, 0.0, 52.5/ + DATA subname(164), dif0(164), ar(164), meso(164), lebas(164) / 'I2 ',0.0795, 4.0, 0.0, 77.0/ + DATA subname(165), dif0(165), ar(165), meso(165), lebas(165) / 'CH3I ',0.0881, 2.0, 0.0, 66.5/ + DATA subname(166), dif0(166), ar(166), meso(166), lebas(166) / 'ICL ',0.0878, 4.0, 0.0, 63.0/ + DATA subname(167), dif0(167), ar(167), meso(167), lebas(167) / 'IBR ',0.0851, 4.0, 0.0, 70.0/ + DATA subname(168), dif0(168), ar(168), meso(168), lebas(168) / 'MI2 ',0.0713, 2.0, 0.0, 98.0/ + DATA subname(169), dif0(169), ar(169), meso(169), lebas(169) / 'MIB ',0.0753, 2.0, 0.0, 91.0/ + DATA subname(170), dif0(170), ar(170), meso(170), lebas(170) / 'MIC ',0.0773, 2.0, 0.0, 84.0/ + DATA subname(171), dif0(171), ar(171), meso(171), lebas(171) / 'BR2 ',0.0925, 2.0, 0.0, 63.0/ + DATA subname(172), dif0(172), ar(172), meso(172), lebas(172) / 'MB3 ',0.0705, 2.0, 0.0, 108.5/ + DATA subname(173), dif0(173), ar(173), meso(173), lebas(173) / 'MB2 ',0.0804, 2.0, 0.0, 84.0/ + DATA subname(174), dif0(174), ar(174), meso(174), lebas(174) / 'MB2C ',0.0720, 2.0, 0.0, 101.5/ + DATA subname(175), dif0(175), ar(175), meso(175), lebas(175) / 'MBC2 ',0.0739, 2.0, 0.0, 94.5/ + DATA subname(176), dif0(176), ar(176), meso(176), lebas(176) / 'MBC ',0.0834, 2.0, 0.0, 77.0/ + DATA subname(177), dif0(177), ar(177), meso(177), lebas(177) / 'CLO ',0.1288, 8.0, 0.0, 31.5/ + DATA subname(178), dif0(178), ar(178), meso(178), lebas(178) / 'ACETALDEHYDE ',0.0975, 1.0, 0.0, 58.9/ + DATA subname(179), dif0(179), ar(179), meso(179), lebas(179) / 'ACETYLENE ',0.1212, 1.0, 0.0, 45.8/ + DATA subname(180), dif0(180), ar(180), meso(180), lebas(180) / 'ACROOPERA ',0.0869, 1.0, 0.0, 70.5/ + DATA subname(181), dif0(181), ar(181), meso(181), lebas(181) / 'ACETONE ',0.0842, 1.0, 0.0, 75.2/ + DATA subname(182), dif0(182), ar(182), meso(182), lebas(182) / 'APIOPERA ',0.0560, 1.0, 0.0, 154.9/ + DATA subname(183), dif0(183), ar(183), meso(183), lebas(183) / 'BENZALDEHYDE ',0.0688, 1.0, 0.0, 101.1/ + DATA subname(184), dif0(184), ar(184), meso(184), lebas(184) / 'BDE13OPERA ',0.0812, 1.0, 0.0, 84.8/ + DATA subname(185), dif0(185), ar(185), meso(185), lebas(185) / 'BENOPERA ',0.0751, 1.0, 0.0, 89.4/ + DATA subname(186), dif0(186), ar(186), meso(186), lebas(186) / 'CSLOPERA ',0.0590, 1.0, 0.0, 137.1/ + DATA subname(187), dif0(187), ar(187), meso(187), lebas(187) / 'METHACROLEIN ',0.0696, 1.0, 0.0, 100.6/ + DATA subname(188), dif0(188), ar(188), meso(188), lebas(188) / 'METHACROLEIN ',0.0647, 1.0, 0.0, 115.4/ + DATA subname(189), dif0(189), ar(189), meso(189), lebas(189) / 'METHACROLEIN ',0.0768, 1.0, 0.0, 82.8/ + DATA subname(190), dif0(190), ar(190), meso(190), lebas(190) / 'ETHANOL ',0.0965, 1.0, 0.0, 59.1/ + DATA subname(191), dif0(191), ar(191), meso(191), lebas(191) / 'ETHENE ',0.1085, 1.0, 0.0, 58.1/ + DATA subname(192), dif0(192), ar(192), meso(192), lebas(192) / 'ETHYLENEGLYCOL ',0.0931, 1.0, 0.0, 56.6/ + DATA subname(193), dif0(193), ar(193), meso(193), lebas(193) / 'FURANOPERA ',0.0751, 1.0, 0.0, 83.9/ + DATA subname(194), dif0(194), ar(194), meso(194), lebas(194) / 'FURANONEOPERA ',0.0820, 1.0, 0.0, 66.5/ + DATA subname(195), dif0(195), ar(195), meso(195), lebas(195) / 'HC10OPERA ',0.0505, 1.0, 0.0, 194.0/ + DATA subname(196), dif0(196), ar(196), meso(196), lebas(196) / 'HC3OPERA ',0.0872, 1.0, 0.0, 78.1/ + DATA subname(197), dif0(197), ar(197), meso(197), lebas(197) / 'HC5OPERA ',0.0694, 1.0, 0.0, 111.0/ + DATA subname(198), dif0(198), ar(198), meso(198), lebas(198) / 'HYDROXY-ACETONE ',0.0823, 1.0, 0.0, 72.7/ + DATA subname(199), dif0(199), ar(199), meso(199), lebas(199) / 'METHACROLEIN ',0.0663, 1.0, 0.3, 107.6/ + DATA subname(200), dif0(200), ar(200), meso(200), lebas(200) / 'ISOOPERA ',0.0728, 1.0, 0.0, 101.0/ + DATA subname(201), dif0(201), ar(201), meso(201), lebas(201) / '2NITRO_1BUTNL ',0.0609, 1.0, 0.1, 125.4/ + DATA subname(202), dif0(202), ar(202), meso(202), lebas(202) / 'LIMOPERA ',0.0547, 1.0, 0.0, 163.0/ + DATA subname(203), dif0(203), ar(203), meso(203), lebas(203) / 'UALDOPERA ',0.0511, 1.0, 0.0, 183.3/ + DATA subname(204), dif0(204), ar(204), meso(204), lebas(204) / 'METHACROLEIN ',0.0772, 1.0, 0.0, 86.8/ + DATA subname(205), dif0(205), ar(205), meso(205), lebas(205) / 'METHACROLEIN ',0.0745, 1.0, 0.3, 84.1/ + DATA subname(206), dif0(206), ar(206), meso(206), lebas(206) / 'MCTOPERA ',0.0672, 1.7, 0.0, 103.0/ + DATA subname(207), dif0(207), ar(207), meso(207), lebas(207) / 'MEK ',0.0752, 1.0, 0.0, 91.7/ + DATA subname(208), dif0(208), ar(208), meso(208), lebas(208) / 'METHANOL ',0.1182, 1.0, 0.0, 42.5/ + DATA subname(209), dif0(209), ar(209), meso(209), lebas(209) / 'MVK ',0.0772, 1.0, 0.0, 86.8/ + DATA subname(210), dif0(210), ar(210), meso(210), lebas(210) / '2NITRO_1BUTNL ',0.0766, 1.0, 0.1, 78.0/ + DATA subname(211), dif0(211), ar(211), meso(211), lebas(211) / 'OLIOPERA ',0.0717, 1.0, 0.0, 104.0/ + DATA subname(212), dif0(212), ar(212), meso(212), lebas(212) / 'OLTOPERA ',0.0904, 1.0, 0.0, 73.1/ + DATA subname(213), dif0(213), ar(213), meso(213), lebas(213) / 'MPAN ',0.0647, 1.0, 0.1, 114.0/ + DATA subname(214), dif0(214), ar(214), meso(214), lebas(214) / 'METHYLHYDROPEROX',0.1030, 1.0, 0.3, 48.9/ + DATA subname(215), dif0(215), ar(215), meso(215), lebas(215) / 'METHYLHYDROPEROX',0.0881, 1.0, 0.3, 65.4/ + DATA subname(216), dif0(216), ar(216), meso(216), lebas(216) / 'METHYLHYDROPEROX',0.0535, 1.0, 0.3, 162.4/ + DATA subname(217), dif0(217), ar(217), meso(217), lebas(217) / 'ORA1OPERA ',0.1119, 1.0, 0.0, 39.9/ + DATA subname(218), dif0(218), ar(218), meso(218), lebas(218) / 'ORA2OPERA ',0.0939, 1.0, 0.0, 56.2/ + DATA subname(219), dif0(219), ar(219), meso(219), lebas(219) / 'PHENOPERA ',0.0731, 3.4, 0.0, 86.3/ + DATA subname(220), dif0(220), ar(220), meso(220), lebas(220) / 'GENERIC_ALDEHYDE',0.0521, 1.0, 0.0, 175.5/ + DATA subname(221), dif0(221), ar(221), meso(221), lebas(221) / 'PROGOPERA ',0.0816, 1.0, 0.0, 73.4/ + DATA subname(222), dif0(222), ar(222), meso(222), lebas(222) / 'ROCIOXYOPERA ',0.0354, 1.0, 0.0, 384.0/ + DATA subname(223), dif0(223), ar(223), meso(223), lebas(223) / 'ADIPIC_ACID ',0.0382, 1.0, 0.0, 326.0/ + DATA subname(224), dif0(224), ar(224), meso(224), lebas(224) / 'ADIPIC_ACID ',0.0528, 1.0, 0.0, 172.0/ + DATA subname(225), dif0(225), ar(225), meso(225), lebas(225) / 'ADIPIC_ACID ',0.0431, 1.0, 0.0, 260.0/ + DATA subname(226), dif0(226), ar(226), meso(226), lebas(226) / 'ADIPIC_ACID ',0.0465, 1.0, 0.0, 221.0/ + DATA subname(227), dif0(227), ar(227), meso(227), lebas(227) / 'ADIPIC_ACID ',0.0483, 1.0, 0.0, 207.0/ + DATA subname(228), dif0(228), ar(228), meso(228), lebas(228) / 'ADIPIC_ACID ',0.0447, 1.0, 0.0, 243.0/ + DATA subname(229), dif0(229), ar(229), meso(229), lebas(229) / 'ADIPIC_ACID ',0.0484, 1.0, 0.0, 205.0/ + DATA subname(230), dif0(230), ar(230), meso(230), lebas(230) / 'ADIPIC_ACID ',0.0530, 1.0, 0.0, 174.0/ + DATA subname(231), dif0(231), ar(231), meso(231), lebas(231) / 'N-PROPANOL ',0.0836, 1.0, 0.0, 75.6/ + DATA subname(232), dif0(232), ar(232), meso(232), lebas(232) / 'SLOWROCOPERA ',0.1041, 1.0, 0.1, 38.9/ + DATA subname(233), dif0(233), ar(233), meso(233), lebas(233) / '2NITRO_1BUTNL ',0.0597, 18.6, 0.1, 123.5/ + DATA subname(234), dif0(234), ar(234), meso(234), lebas(234) / 'UALDOPERA ',0.0704, 1.0, 0.0, 102.0/ + DATA subname(235), dif0(235), ar(235), meso(235), lebas(235) / 'XYEOPERA ',0.0636, 1.0, 0.0, 122.0/ + DATA subname(236), dif0(236), ar(236), meso(236), lebas(236) / 'XYMOPERA ',0.0636, 1.0, 0.0, 122.0/ + DATA subname(237), dif0(237), ar(237), meso(237), lebas(237) / 'ELHOLM ',0.0464,49000.0, 0.3, 237.0/ + DATA subname(238), dif0(238), ar(238), meso(238), lebas(238) / 'HOLM ',0.0534, 711.0, 0.3, 157.7/ + DATA subname(239), dif0(239), ar(239), meso(239), lebas(239) / 'METHYLHYDROPEROX',0.0551, 783.0, 0.3, 153.1/ + DATA subname(240), dif0(240), ar(240), meso(240), lebas(240) / 'ADIPIC_ACID ',0.0303, 218.0, 0.0, 508.0/ + DATA subname(241), dif0(241), ar(241), meso(241), lebas(241) / 'ADIPIC_ACID ',0.0365, 8450.0, 0.0, 353.0/ + DATA subname(242), dif0(242), ar(242), meso(242), lebas(242) / 'ADIPIC_ACID ',0.0465, 2550.0, 0.0, 216.0/ + DATA subname(243), dif0(243), ar(243), meso(243), lebas(243) / 'ADIPIC_ACID ',0.0557, 182.0, 0.0, 147.7/ + DATA subname(244), dif0(244), ar(244), meso(244), lebas(244) / 'ADIPIC_ACID ',0.0298,28400.0, 0.0, 524.0/ + DATA subname(245), dif0(245), ar(245), meso(245), lebas(245) / 'ADIPIC_ACID ',0.0405, 696.0, 0.0, 285.4/ + DATA subname(246), dif0(246), ar(246), meso(246), lebas(246) / 'ADIPIC_ACID ',0.0485, 1440.0, 0.0, 197.0/ + DATA subname(247), dif0(247), ar(247), meso(247), lebas(247) / 'ADIPIC_ACID ',0.0588,2060000., 0.0, 130.0/ + DATA subname(248), dif0(248), ar(248), meso(248), lebas(248) / 'ADIPIC_ACID ',0.0308, 36.8, 0.0, 491.0/ + DATA subname(249), dif0(249), ar(249), meso(249), lebas(249) / 'ADIPIC_ACID ',0.0433, 130.0, 0.0, 251.0/ + DATA subname(250), dif0(250), ar(250), meso(250), lebas(250) / 'ADIPIC_ACID ',0.0505, 5520.0, 0.0, 183.0/ + DATA subname(251), dif0(251), ar(251), meso(251), lebas(251) / 'ADIPIC_ACID ',0.0314, 6.8, 0.0, 474.0/ + DATA subname(252), dif0(252), ar(252), meso(252), lebas(252) / 'ADIPIC_ACID ',0.0394, 583.0, 0.0, 304.0/ + DATA subname(253), dif0(253), ar(253), meso(253), lebas(253) / 'ADIPIC_ACID ',0.0483, 2820.0, 0.0, 202.0/ + DATA subname(254), dif0(254), ar(254), meso(254), lebas(254) / 'ADIPIC_ACID ',0.0332, 1.1, 0.0, 425.0/ + DATA subname(255), dif0(255), ar(255), meso(255), lebas(255) / 'ADIPIC_ACID ',0.0464, 9.6, 0.0, 221.0/ + DATA subname(256), dif0(256), ar(256), meso(256), lebas(256) / 'ADIPIC_ACID ',0.0355, 1.0, 0.0, 375.0/ + DATA subname(257), dif0(257), ar(257), meso(257), lebas(257) / 'ADIPIC_ACID ',0.0489, 1.0, 0.0, 198.7/ + DATA subname(258), dif0(258), ar(258), meso(258), lebas(258) / 'IPNOPERA ',0.0652, 86.6, 0.3, 104.8/ ! VD_IPN + DATA subname(259), dif0(259), ar(259), meso(259), lebas(259) / 'IPCOPERA ',0.0687, 1.0, 0.3, 99.3/ ! VD_IPC CONTAINS C======================================================================= - Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) + Subroutine INIT_MET ( JDATE, JTIME ) C----------------------------------------------------------------------- C 30 Mar 01 J.Young: dyn alloc - Use HGRD_DEFN; replace INTERP3 with INTERPX; @@ -426,25 +545,19 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) C 31 Jan 05 J.Young: dyn alloc - establish both horizontal & vertical C domain specifications in one module C 16 Feb 11 S.Roselle: replaced I/O API include files with UTILIO_DEFN +C 25 Jul 19 D.Wong: used N_SOIL_TYPE defined in LSM_Mod to handle +C various number of soil type from different WRF version C----------------------------------------------------------------------- Use UTILIO_DEFN + Use LSM_Mod, only : N_SOIL_TYPE Implicit None Include SUBST_FILES_ID ! file name parameters - Include SUBST_CONST ! constants C Arguments: Integer, Intent( IN ) :: JDATE, JTIME ! internal simulation date&time - Logical, Intent( IN ) :: MOSAIC - Logical, Intent( IN ) :: ABFLUX - Logical, Intent( IN ) :: HGBIDI - -C File variables: - Real, Pointer :: MSFX2 ( :,: ) - Real, Pointer :: SOILCAT ( :,: ) - Real, Pointer :: X3M ( : ) C Local variables: Character( 16 ) :: PNAME = 'INIT_MET' @@ -453,15 +566,11 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) CHARACTER( 30 ) :: MSG1 = ' Error interpolating variable ' Character( 96 ) :: XMSG = ' ' -C for INTERPX - Integer STRTCOLGC2, ENDCOLGC2, STRTROWGC2, ENDROWGC2 Integer V Integer ALLOCSTAT C----------------------------------------------------------------------- - LOGDEV = INIT3() - If( MET_INITIALIZED )Return !> Allocate buffers @@ -484,7 +593,7 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) & Met_Data%PRSFC ( NCOLS,NROWS ), & Met_Data%Q2 ( NCOLS,NROWS ), & Met_Data%QSS_GRND ( NCOLS,NROWS ), - & Met_Data%RH ( NCOLS,NROWS ), + & Met_Data%RH2 ( NCOLS,NROWS ), & Met_Data%RA ( NCOLS,NROWS ), & Met_Data%RS ( NCOLS,NROWS ), & Met_Data%RC ( NCOLS,NROWS ), @@ -513,18 +622,21 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) & Met_Data%LPBL ( NCOLS,NROWS ), & Met_Data%CONVCT ( NCOLS,NROWS ), & Met_Data%PBL ( NCOLS,NROWS ), - & Met_Data%NACL_EMIS( NCOLS,NROWS ), - & Met_Data%UWINDA ( NCOLS,NROWS,NLAYS ), - & Met_Data%VWINDA ( NCOLS,NROWS,NLAYS ), +! & Met_Data%NACL_EMIS( NCOLS,NROWS ), + & Met_Data%COSZEN ( NCOLS,NROWS ), + & Met_Data%CFRAC ( NCOLS,NROWS ), + & Met_Data%UWINDA ( NCOLS,NROWS,NLAYS ), !(Wei Li) + & Met_Data%VWINDA ( NCOLS,NROWS,NLAYS ), !(Wei Li) & Met_Data%UWIND ( NCOLS+1,NROWS+1,NLAYS ), & Met_Data%VWIND ( NCOLS+1,NROWS+1,NLAYS ), & Met_Data%KZMIN ( NCOLS,NROWS,NLAYS ), + & Met_Data%PRESF ( NCOLS,NROWS,1:NLAYS+1 ), !(Wei Li) & Met_Data%PRES ( NCOLS,NROWS,NLAYS ), - & Met_Data%PRESF ( NCOLS,NROWS,1:NLAYS+1 ), & Met_Data%QV ( NCOLS,NROWS,NLAYS ), & Met_Data%QC ( NCOLS,NROWS,NLAYS ), & Met_Data%THETAV ( NCOLS,NROWS,NLAYS ), & Met_Data%TA ( NCOLS,NROWS,NLAYS ), + & Met_Data%RH ( NCOLS,NROWS,NLAYS ), & Met_Data%ZH ( NCOLS,NROWS,NLAYS ), & Met_Data%ZF ( NCOLS,NROWS,NLAYS ), & Met_Data%DZF ( NCOLS,NROWS,NLAYS ), @@ -549,103 +661,62 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) & Grid_Data%SZONE ( NCOLS,NROWS ), & Grid_Data%PURB ( NCOLS,NROWS ), & Grid_Data%SLTYP ( NCOLS,NROWS ), + & Grid_Data%WSAT ( NCOLS,NROWS ), + & Grid_Data%WWLT ( NCOLS,NROWS ), + & Grid_Data%WFC ( NCOLS,NROWS ), !We now use WFC whether BIDI is on or off + & Grid_Data%CLAY_PX ( NCOLS,NROWS ), + & Grid_Data%CSAND_PX ( NCOLS,NROWS ), + & Grid_Data%FMSAND_PX ( NCOLS,NROWS ), & Grid_Data%NAME ( n_lufrac ), & Grid_Data%LU_Type ( n_lufrac ), + & Grid_Data%LUFRAC ( NCOLS,NROWS,n_lufrac ), & STAT = ALLOCSTAT ) If ( ALLOCSTAT .Ne. 0 ) Then XMSG = 'Failure allocating grid vars' Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) End If - Grid_Data%NAME = name_lu - Grid_Data%LU_Type = cat_lu - - If ( ABFLUX .Or. HGBIDI .Or. MOSAIC ) Then - ALLOCATE( Met_Data%SOIM2 ( NCOLS,NROWS ), - & Met_Data%SOIT2 ( NCOLS,NROWS ), + Grid_Data%NAME = name_lu + Grid_Data%LU_Type = cat_lu + Grid_Data%WWLT = 0.0 + Grid_Data%WSAT = 0.0 + Grid_Data%WFC = 0.0 + Grid_Data%CLAY_PX = 0.0 + Grid_Data%CSAND_PX = 0.0 + Grid_Data%FMSAND_PX = 0.0 + + If ( BIOGEMIS_BEIS ) Then + ALLOCATE( Met_Data%SOIT2 ( NCOLS,NROWS ), & STAT = ALLOCSTAT ) If ( ALLOCSTAT .Ne. 0 ) Then - XMSG = 'Failure allocating mosaic met vars' + XMSG = 'Failure allocating layer 2 soil temperature' Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) End If + End If - ALLOCATE( Grid_Data%WSAT ( NCOLS,NROWS ), - & Grid_Data%WWLT ( NCOLS,NROWS ), - & Grid_Data%BSLP ( NCOLS,NROWS ), - & Grid_Data%WRES ( NCOLS,NROWS ), - & Grid_Data%WFC ( NCOLS,NROWS ), - & Grid_Data%LUFRAC ( NCOLS,NROWS,n_lufrac ), + If ( ABFLUX .or. BIOGEMIS_MEGAN ) Then + ALLOCATE( Met_Data%SOIM2 ( NCOLS,NROWS ), & STAT = ALLOCSTAT ) If ( ALLOCSTAT .Ne. 0 ) Then - XMSG = 'Failure allocating mosaic grid vars' + XMSG = 'Failure allocating layer 2 soil moisture' Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) End If - Grid_Data%WSAT = 0.0 - Grid_Data%WWLT = 0.0 - Grid_Data%WFC = 0.0 - Grid_Data%WRES = 0.0 - Grid_Data%BSLP = 0.0 + END IF + + If ( ABFLUX .or. HGBIDI ) Then - ALLOCATE( Mosaic_Data%USTAR ( NCOLS,NROWS,n_lufrac ), - & Mosaic_Data%LAI ( NCOLS,NROWS,n_lufrac ), - & Mosaic_Data%DELTA ( NCOLS,NROWS,n_lufrac ), - & Mosaic_Data%VEG ( NCOLS,NROWS,n_lufrac ), - & Mosaic_Data%Z0 ( NCOLS,NROWS,n_lufrac ), - & Mosaic_Data%RA ( NCOLS,NROWS,n_lufrac ), - & Mosaic_Data%RSTW ( NCOLS,NROWS,n_lufrac ), - & Mosaic_Data%RINC ( NCOLS,NROWS,n_lufrac ), - & Mosaic_Data%NAME ( n_lufrac ), - & Mosaic_Data%LU_Type ( n_lufrac ), - & STAT = ALLOCSTAT ) - If ( ALLOCSTAT .Ne. 0 ) Then - XMSG = 'Failure allocating mosaic vars' - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - Mosaic_Data%USTAR = 0.0 - Mosaic_Data%LAI = 0.0 - Mosaic_Data%DELTA = 0.0 - Mosaic_Data%VEG = 0.0 - Mosaic_Data%Z0 = 0.000001 - Mosaic_Data%RSTW = 0.0 - Mosaic_Data%RINC = 0.0 - Mosaic_Data%NAME = name_lu - Mosaic_Data%LU_Type = cat_lu - - ALLOCATE( ChemMos_Data%Rb ( NCOLS,NROWS,n_lufrac,ltotg ), - & ChemMos_Data%Rst ( NCOLS,NROWS,n_lufrac,ltotg ), - & ChemMos_Data%Rcut ( NCOLS,NROWS,n_lufrac,ltotg ), - & ChemMos_Data%Rgc ( NCOLS,NROWS,n_lufrac,ltotg ), - & ChemMos_Data%Rgb ( NCOLS,NROWS,n_lufrac,ltotg ), - & ChemMos_Data%Rwat ( NCOLS,NROWS,n_lufrac,ltotg ), - & ChemMos_Data%CZ0 ( NCOLS,NROWS,n_lufrac,ltotg ), - & ChemMos_Data%Cleaf ( NCOLS,NROWS,n_lufrac,ltotg ), - & ChemMos_Data%Cstom ( NCOLS,NROWS,n_lufrac,ltotg ), - & ChemMos_Data%Ccut ( NCOLS,NROWS,n_lufrac,ltotg ), - & ChemMos_Data%Csoil ( NCOLS,NROWS,n_lufrac,ltotg ), - & ChemMos_Data%NAME ( n_lufrac ), - & ChemMos_Data%LU_Type ( n_lufrac ), - & ChemMos_Data%Subname ( n_lufrac ), + ALLOCATE( Grid_Data%BSLP ( NCOLS,NROWS ), + & Grid_Data%WRES ( NCOLS,NROWS ), & STAT = ALLOCSTAT ) If ( ALLOCSTAT .Ne. 0 ) Then - XMSG = 'Failure allocating chemistry dependent mosaic vars' + XMSG = 'Failure allocating Soil grid vars' Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) End If - ChemMos_Data%Rb = resist_max - ChemMos_Data%Rst = resist_max - ChemMos_Data%Rcut = resist_max - ChemMos_Data%Rgc = resist_max - ChemMos_Data%Rgb = resist_max - ChemMos_Data%Rwat = resist_max - ChemMos_Data%CZ0 = 0.0 - ChemMos_Data%Cleaf = 0.0 - ChemMos_Data%Cstom = 0.0 - ChemMos_Data%Ccut = 0.0 - ChemMos_Data%Csoil = 0.0 - ChemMos_Data%NAME = name_lu - ChemMos_Data%LU_Type = cat_lu - ChemMos_Data%SubName = subname + + Grid_Data%WRES = 0.0 + Grid_Data%BSLP = 0.0 End If -!> ccccccccccccccccccccc canopy shade option!ccccccccccccccccccccc +!> ccccccccccccccccccccc canopy shade option!ccccccccccccccccccccc (Wei Li) CANOPY_SHADE = ENVYN( 'CTM_CANOPY_SHADE', & 'Flag for in-line canopy shading', & .FALSE., IOSX ) @@ -671,16 +742,16 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) End If End If -!> ccccccccccccccccccccc Fengsha option!ccccccccccccccccccccc +!> ccccccccccccccccccccc Fengsha option!ccccccccccccccccccccc (Wei Li) FENGSHA = ENVYN( CTM_WBDUST_FENGSHA, & 'Flag for in-line fengsha ', & .FALSE., IOSX ) - + IF ( FENGSHA ) THEN XMSG = 'Using the Fengsha Wind-Blown dust emission model...' CALL M3MSG2( XMSG ) END IF - + If ( FENGSHA ) Then ALLOCATE( Met_Data%CLAYF ( NCOLS,NROWS ), & Met_Data%SANDF ( NCOLS,NROWS ), @@ -693,49 +764,22 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) End If End If -!> ccccccccccccccccccccc enable backward compatiblity ccccccccccccccccccccc - - If ( .Not. desc3( met_cro_2d ) ) Then - xmsg = 'Could not get ' // MET_CRO_2D // ' file description' - Call m3exit( pname, JDATE, JTIME, xmsg, xstat2 ) - End If - - SPC = INDEX1( 'RA', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) rinv = .FALSE. ! Ra and Rst are in units s/m - - SPC = INDEX1( 'WR', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) ifwr = .True. ! canopy wetness is in METCRO2D - - SPC = INDEX1( 'Q2', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) ifq2 = .True. ! two meter mixing ratio in METCRO2D - SPC = INDEX1( 'TSEASFC', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) ifsst = .True. ! two meter SST in METCRO2D - - SPC = INDEX1( 'LH', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) iflh = .True. ! LH in METCRO2D +!> ccccccccccccccccccccc enable backward compatiblity ccccccccccccccccccccc - SPC = INDEX1( 'RCA', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) Then + IF (RCA_AVAIL) THEN vname_rc = 'RCA' Else vname_rc = 'RC' End If - SPC = INDEX1( 'RNA', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) Then + IF (RNA_AVAIL) THEN vname_rn = 'RNA' Else vname_rn = 'RN' End If - If ( .Not. desc3( met_dot_3d ) ) Then - xmsg = 'Could not get ' // MET_DOT_3D // ' file description' - Call m3exit( pname, JDATE, JTIME, xmsg, xstat2 ) - End If - - SPC = INDEX1( 'UWINDC', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) Then + If (UWINDC_AVAIL) Then vname_uc = 'UWINDC' CSTAGUV = .TRUE. Else @@ -743,189 +787,65 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) CSTAGUV = .FALSE. End If - SPC = INDEX1( 'VWINDC', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) Then + If (VWINDC_AVAIL) Then vname_vc = 'VWINDC' Else vname_vc = 'VWIND' End If - If ( .Not. desc3( met_cro_3d ) ) Then - xmsg = 'Could not get ' // MET_CRO_3D // ' file description' - Call m3exit( pname, JDATE, JTIME, xmsg, xstat2 ) - End If - - V = INDEX1( 'PRES', NVARS3D, VNAME3D ) - If ( V .Ne. 0 ) Then - UNITSCK = UNITS3D( V ) - Else - XMSG = 'Could not get variable PRES from ' // MET_CRO_3D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - Select Case (UNITSCK) - Case ( 'PASCAL','pascal','Pascal','PA','pa','Pa' ) - CONVPA = 1.0 - P0 = 100000.0 - Case ( 'MILLIBAR','millibar','Millibar','MB','mb','Mb' ) - CONVPA = 1.0E-02 - P0 = 100000.0 * CONVPA - Case ( 'CENTIBAR','centibar','Centibar','CB','cb','Cb' ) - CONVPA = 1.0E-03 - P0 = 100000.0 * CONVPA - Case Default - XMSG = 'Units incorrect on ' // MET_CRO_3D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End Select - - MINKZ = .True. ! default - MINKZ = ENVYN( 'KZMIN', 'Kz min on flag', MINKZ, ALLOCSTAT ) - If ( ALLOCSTAT .Ne. 0 ) Write( LOGDEV,'(5X, A)' ) 'Kz min on flag' - Select Case( ALLOCSTAT ) - Case ( 1 ) - XMSG = 'Environment variable improperly formatted' - Call M3WARN( PNAME, JDATE, JTIME, XMSG ) - Case ( -1 ) - XMSG = 'Environment variable set, but empty ... Using default:' - Write( LOGDEV,'(5X, A)' ) XMSG - Case ( -2 ) - XMSG = 'Environment variable not set ... Using default:' - Write( LOGDEV,'(5X, A)' ) XMSG - End Select - If ( .Not. MINKZ ) Then XMSG = 'This run uses Kz0UT, *NOT* KZMIN in subroutine edyintb.' Write( LOGDEV,'(/5X, A, /)' ) XMSG End If -!> Open the met files - - Call SUBHFILE ( GRID_CRO_2D, GXOFF, GYOFF, - & STRTCOLGC2, ENDCOLGC2, STRTROWGC2, ENDROWGC2 ) - Call SUBHFILE ( MET_CRO_2D, GXOFF, GYOFF, - & STRTCOLMC2, ENDCOLMC2, STRTROWMC2, ENDROWMC2 ) - Call SUBHFILE ( MET_CRO_3D, GXOFF, GYOFF, - & STRTCOLMC3, ENDCOLMC3, STRTROWMC3, ENDROWMC3 ) - Call SUBHFILE ( MET_DOT_3D, GXOFF, GYOFF, - & STRTCOLMD3, ENDCOLMD3, STRTROWMD3, ENDROWMD3 ) - CALL SUBHFILE ( OCEAN_1, GXOFF, GYOFF, - & STRTCOL_O1, ENDCOL_O1, STRTROW_O1, ENDROW_O1 ) !> Get sigma coordinate variables - X3M => BUFF1D Do L = 1, NLAYS Grid_Data%DX3F( L ) = X3FACE_GD( L ) - X3FACE_GD( L-1 ) Grid_Data%RDX3F( L ) = 1.0 / Grid_Data%DX3F( L ) - X3M( L ) = 0.5 * ( X3FACE_GD( L ) + X3FACE_GD( L-1 ) ) + BUFF1D( L ) = 0.5 * ( X3FACE_GD( L ) + X3FACE_GD( L-1 ) ) End Do Do L = 1, NLAYS - 1 - Grid_Data%RDX3M( L ) = 1.0 / ( X3M( L+1 ) - X3M( L ) ) + Grid_Data%RDX3M( L ) = 1.0 / ( BUFF1D( L+1 ) - BUFF1D( L ) ) End Do Grid_Data%RDX3M( NLAYS ) = 0.0 -!> nullify pointer - Nullify( X3M ) - -!> reciprical of msfx2**2 -!> assign MSFX2 - MSFX2 => BUFF2D - VNAME = 'MSFX2' - If ( .Not. INTERPX( GRID_CRO_2D, VNAME, PNAME, - & STRTCOLGC2,ENDCOLGC2, STRTROWGC2,ENDROWGC2, 1,1, - & JDATE, JTIME, MSFX2 ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // GRID_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If +!> reciprocal of msfx2**2 Grid_Data%RMSFX4 = 1.0 / ( MSFX2**2 ) -!> nullify pointer - Nullify( MSFX2 ) - - VNAME = 'LON' - If ( .Not. INTERPX( GRID_CRO_2D, VNAME, PNAME, - & STRTCOLGC2,ENDCOLGC2, STRTROWGC2,ENDROWGC2, 1,1, - & JDATE, JTIME, Grid_Data%LON ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // GRID_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - VNAME = 'LAT' - If ( .Not. INTERPX( GRID_CRO_2D, VNAME, PNAME, - & STRTCOLGC2,ENDCOLGC2, STRTROWGC2,ENDROWGC2, 1,1, - & JDATE, JTIME, Grid_Data%LAT ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // GRID_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + Grid_Data%LON = LON - VNAME = 'LWMASK' - If ( .Not. INTERPX( GRID_CRO_2D, VNAME, PNAME, - & STRTCOLGC2,ENDCOLGC2, STRTROWGC2,ENDROWGC2, 1,1, - & JDATE, JTIME, Grid_Data%LWMASK ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // GRID_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + Grid_Data%LAT = LAT - VNAME = 'PURB' - If ( .Not. INTERPX( GRID_CRO_2D, VNAME, PNAME, - & STRTCOLGC2,ENDCOLGC2, STRTROWGC2,ENDROWGC2, 1,1, - & JDATE, JTIME, Grid_Data%PURB ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // GRID_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + Grid_Data%LWMASK = LWMASK - SOILCAT => BUFF2D - VNAME = 'SLTYP' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, SOILCAT ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + Grid_Data%PURB = PURB - Grid_Data%SLTYP = NINT( SOILCAT ) - Nullify( SOILCAT ) - - If ( ABFLUX .Or. MOSAIC ) Then - Do l = 1, n_lufrac - Write( vname,'( "LUFRAC_",I2.2 )' ) l - If ( .Not. INTERPX( GRID_CRO_2D, VNAME, PNAME, - & STRTCOLGC2,ENDCOLGC2, STRTROWGC2,ENDROWGC2, 1,1, - & JDATE, JTIME, Grid_Data%LUFRAC( :,:,l ) ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // GRID_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - End Do + Grid_Data%SLTYP = NINT( SOILCAT_A ) + Grid_Data%LUFRAC = LUFRAC - Forall( C = 1:MY_NCOLS, R = 1:MY_NROWS, Grid_Data%SLTYP(C,R) .Le. 11 ) - Grid_Data%WSAT( C,R ) = WSAT( Grid_Data%SLTYP( C,R ) ) + If ( (ABFLUX .or. HGBIDI .or. BIOGEMIS_MEGAN .or. BIOGEMIS_BEIS) .and. .not. PXSOIL_AVAIL) Then + Forall( C = 1:NCOLS, R = 1:NROWS, Grid_Data%SLTYP(C,R) .Le. N_SOIL_TYPE ) Grid_Data%WWLT( C,R ) = WWLT( Grid_Data%SLTYP( C,R ) ) + Grid_Data%WSAT( C,R ) = WSAT( Grid_Data%SLTYP( C,R ) ) + End Forall + End If + + If (.not. PXSOIL_AVAIL) Then + Forall( C = 1:NCOLS, R = 1:NROWS, Grid_Data%SLTYP(C,R) .Le. N_SOIL_TYPE ) Grid_Data%WFC ( C,R ) = WFC ( Grid_Data%SLTYP( C,R ) ) + End Forall + End If + + If ( ABFLUX .or. HGBIDI ) Then + Forall( C = 1:NCOLS, R = 1:NROWS, Grid_Data%SLTYP(C,R) .Le. N_SOIL_TYPE ) Grid_Data%WRES( C,R ) = WRES( Grid_Data%SLTYP( C,R ) ) Grid_Data%BSLP( C,R ) = BSLP( Grid_Data%SLTYP( C,R ) ) End Forall - End If - -!> Read fractional seawater and surf-zone coverage from the OCEAN file. -!> Store results in the OCEAN and SZONE arrays. - IF ( .NOT. OPEN3( OCEAN_1, FSREAD3, PNAME ) ) THEN - XMSG = 'Open failure for ' // OCEAN_1 - CALL M3WARN( PNAME, JDATE, JTIME, XMSG ) - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - END IF - - VNAME = 'OPEN' - If ( .Not. INTERPX( OCEAN_1, VNAME, PNAME, - & STRTCOL_O1,ENDCOL_O1, STRTROW_O1,ENDROW_O1, - & 1,1,JDATE, JTIME, Grid_Data%OCEAN ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // OCEAN_1 - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) End If - VNAME = 'SURF' - If ( .Not. INTERPX( OCEAN_1, VNAME, PNAME, - & STRTCOL_O1,ENDCOL_O1, STRTROW_O1,ENDROW_O1, - & 1,1,JDATE, JTIME, Grid_Data%SZONE ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // OCEAN_1 - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + Grid_Data%OCEAN = ocean + + Grid_Data%SZONE = szone MET_INITIALIZED = .true. @@ -933,7 +853,7 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) End Subroutine INIT_MET C======================================================================= - Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) + Subroutine GET_MET ( JDATE, JTIME, TSTEP ) C----------------------------------------------------------------------- C 30 Mar 01 J.Young: dyn alloc - Use HGRD_DEFN; replace INTERP3 with INTERPX; @@ -958,14 +878,10 @@ Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) Include SUBST_FILES_ID ! file name parameters Include SUBST_PE_COMM ! PE communication displacement and direction - Include SUBST_CONST ! constants C Arguments: Integer, Intent( IN ) :: JDATE, JTIME, TSTEP ! internal simulation date&time - Logical, Intent( IN ) :: MOSAIC - Logical, Intent( IN ) :: ABFLUX - Logical, Intent( IN ) :: HGBIDI C Parameters: Real, Parameter :: cond_min = 1.0 / resist_max ! minimum conductance [m/s] @@ -979,9 +895,6 @@ Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) Real FINT Real CPAIR, LV, QST Real TMPFX, TMPVTCON, TST, TSTV - Real, Pointer :: Es_Grnd ( :,: ) - Real, Pointer :: Es_Air ( :,: ) - Real, Pointer :: TV ( :,:,: ) Integer LP Integer C, R, L ! loop induction variables @@ -994,436 +907,148 @@ Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) C Interpolate file input variables and format for output C-------------------------------- MET_CRO_3D -------------------------------- - VNAME = 'ZH' - If ( .Not. INTERPX( MET_CRO_3D, VNAME, PNAME, - & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, - & JDATE, JTIME, Met_Data%ZH ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('ZH', jdate, jtime, Met_Data%ZH) - VNAME = 'PRES' - If ( .Not. INTERPX( MET_CRO_3D, VNAME, PNAME, - & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, - & JDATE, JTIME, Met_Data%PRES ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('PRES', jdate, jtime, Met_Data%PRES) - VNAME = 'PRESF' - If ( .Not. INTERPX( MET_CRO_3D, VNAME, PNAME, - & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS+1, - & JDATE, JTIME, Met_Data%PRESF ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('PRESF', jdate, jtime, Met_Data%PRESF) !(Wei Li) - VNAME = 'ZF' - If ( .Not. INTERPX( MET_CRO_3D, VNAME, PNAME, - & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, - & JDATE, JTIME, Met_Data%ZF ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - VNAME = 'DENS' - If ( .Not. INTERPX( MET_CRO_3D, VNAME, PNAME, - & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, - & JDATE, JTIME, Met_Data%DENS ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT 1 ) - End If + call interpolate_var ('UWINDA', jdate, jtime, Met_Data%UWINDA) !(Wei Li) + + call interpolate_var ('VWINDA', jdate, jtime, Met_Data%VWINDA) !(Wei Li) + + call interpolate_var ('ZF', jdate, jtime, Met_Data%ZF) + + call interpolate_var ('DENS', jdate, jtime, Met_Data%DENS) Met_Data%DENS1 = Met_Data%DENS( :,:,1 ) - VNAME = 'JACOBM' - If ( .Not. INTERPX( MET_CRO_3D, VNAME, PNAME, - & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, - & JDATE, JTIME, Met_Data%RJACM ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('JACOBM', jdate, jtime, Met_Data%RJACM) Met_Data%RJACM = 1.0 / Met_Data%RJACM - VNAME = 'JACOBF' - If ( .Not. INTERPX( MET_CRO_3D, VNAME, PNAME, - & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, - & JDATE, JTIME, Met_Data%RJACF ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('JACOBF', jdate, jtime, Met_Data%RJACF) Met_Data%RJACF = 1.0 / Met_Data%RJACF - VNAME = 'DENSA_J' - If ( .Not. INTERPX( MET_CRO_3D, VNAME, PNAME, - & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, - & JDATE, JTIME, Met_Data%RRHOJ ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('DENSA_J', jdate, jtime, Met_Data%RRHOJ) Met_Data%RRHOJ = 1.0 / Met_Data%RRHOJ - VNAME = 'TA' - IF ( .NOT. INTERPX( MET_CRO_3D, VNAME, PNAME, - & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, - & JDATE, JTIME, Met_Data%TA ) ) THEN - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D - CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - END IF - - VNAME = 'QV' - IF ( .NOT. INTERPX( MET_CRO_3D, VNAME, PNAME, - & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, - & JDATE, JTIME, Met_Data%QV ) ) THEN - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D - CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - END IF - - VNAME = 'QC' - IF ( .NOT. INTERPX( MET_CRO_3D, VNAME, PNAME, - & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, - & JDATE, JTIME, Met_Data%QC ) ) THEN - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D - CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - END IF + call interpolate_var ('TA', jdate, jtime, Met_Data%TA) - VNAME = 'UWINDA' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,NLAYS, - & JDATE, JTIME, Met_Data%UWINDA ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('QV', jdate, jtime, Met_Data%QV) - VNAME = 'VWINDA' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,NLAYS, - & JDATE, JTIME, Met_Data%VWINDA ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('QC', jdate, jtime, Met_Data%QC) C-------------------------------- MET_CRO_2D -------------------------------- C Vegetation and surface vars - VNAME = 'LAI' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%LAI ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('LAI', jdate, jtime, Met_Data%LAI) - VNAME = 'VEG' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%VEG ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('VEG', jdate, jtime, Met_Data%VEG) - VNAME = 'ZRUF' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%Z0 ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('ZRUF', jdate, jtime, Met_Data%Z0) -C Canopy vars - If ( CANOPY_SHADE ) Then - VNAME = 'FCH' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%FCH ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) +C Canopy vars (Wei Li) + If ( CANOPY_SHADE ) Then + call interpolate_var ('FCH', jdate, jtime, Met_Data%FCH) + call interpolate_var ('FRT', jdate, jtime, Met_Data%FRT) + call interpolate_var ('CLU', jdate, jtime, Met_Data%CLU) + call interpolate_var ('POPU', jdate, jtime, Met_Data%POPU) + call interpolate_var ('LAIE', jdate, jtime, Met_Data%LAIE) + call interpolate_var ('C1R', jdate, jtime, Met_Data%C1R) + call interpolate_var ('C2R', jdate, jtime, Met_Data%C2R) + call interpolate_var ('C3R', jdate, jtime, Met_Data%C3R) + call interpolate_var ('C4R', jdate, jtime, Met_Data%C4R) End If - VNAME = 'FRT' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2,STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%FRT ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) +C FENGSHA vars (Wei Li) + If ( CANOPY_SHADE ) Then + call interpolate_var ('CLAYF', jdate, jtime, Met_Data%CLAYF) + call interpolate_var ('SANDF', jdate, jtime, Met_Data%SANDF) + call interpolate_var ('DRAG', jdate, jtime, Met_Data%DRAG) + call interpolate_var ('UTHR', jdate, jtime, Met_Data%UTHR) End If - VNAME = 'CLU' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2,STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%CLU ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - VNAME = 'POPU' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2,STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%POPU ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - VNAME = 'LAIE' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2,STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%LAIE ) ) Then - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - VNAME = 'C1R' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2,STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%C1R ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - VNAME = 'C2R' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2,STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%C2R ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - VNAME = 'C3R' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2,STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%C3R ) ) Then - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - VNAME = 'C4R' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2,STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%C4R ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - End If - -C FENGSHA vars - If ( FENGSHA ) Then - VNAME = 'CLAYF' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%CLAYF ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - VNAME = 'SANDF' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%SANDF ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - VNAME = 'DRAG' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%DRAG ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - VNAME = 'UTHR' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%UTHR ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - End If C Soil vars - VNAME = 'SOIM1' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%SOIM1 ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - If ( ABFLUX .Or. HGBIDI .Or. MOSAIC ) Then - VNAME = 'SOIM2' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%SOIM2 ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('SOIM1', jdate, jtime, Met_Data%SOIM1) - VNAME = 'SOIT2' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%SOIT2 ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + If ( ABFLUX .or. BIOGEMIS_MEGAN) Then + call interpolate_var ('SOIM2', jdate, jtime, Met_Data%SOIM2) End If - VNAME = 'SOIT1' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%SOIT1 ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('SOIT1', jdate, jtime, Met_Data%SOIT1) - VNAME = 'SEAICE' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%SEAICE ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + If ( BIOGEMIS_BEIS ) Then + call interpolate_var ('SOIT2', jdate, jtime, Met_Data%SOIT2) End If + call interpolate_var ('SEAICE', jdate, jtime, Met_Data%SEAICE) + C met vars - VNAME = 'PRSFC' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%PRSFC ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('PRSFC', jdate, jtime, Met_Data%PRSFC) - VNAME = 'RGRND' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%RGRND ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('RGRND', jdate, jtime, Met_Data%RGRND) + + call interpolate_var ('SNOCOV', jdate, jtime, Met_Data%SNOCOV) - VNAME = 'SNOCOV' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%SNOCOV ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If Where( Met_Data%SNOCOV .Lt. 0.0 ) Met_Data%SNOCOV = 0.0 End Where - VNAME = 'TEMP2' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%TEMP2 ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('TEMP2', jdate, jtime, Met_Data%TEMP2) - VNAME = 'TEMPG' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%TEMPG ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('TEMPG', jdate, jtime, Met_Data%TEMPG) - VNAME = 'USTAR' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%USTAR ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('USTAR', jdate, jtime, Met_Data%USTAR) - VNAME = 'WSPD10' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%WSPD10 ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('WSPD10', jdate, jtime, Met_Data%WSPD10) - VNAME = 'HFX' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%HFX ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('HFX', jdate, jtime, Met_Data%HFX) - If ( iflh ) Then - VNAME = 'LH' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%LH ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + If ( LH_AVAIL ) Then + call interpolate_var ('LH', jdate, jtime, Met_Data%LH) Else ! for backward compatibility - VNAME = 'QFX' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%LH ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('QFX', jdate, jtime, Met_Data%LH) + End If + + call interpolate_var ('PBL', jdate, jtime, Met_Data%PBL) + + ! Update for WRFV4.1+ PX LSM runs that have soil texture in output for + ! CMAQ dust scheme. These are initialized to 0 if not present in MCIP. + ! DUST_EMIS.F will use table lookup values if 0 (old WRF or other LSMs). + If ( PXSOIL_AVAIL ) Then + call interpolate_var ('CLAY_PX', jdate, jtime, Grid_Data%CLAY_PX) + call interpolate_var ('CSAND_PX', jdate, jtime, Grid_Data%CSAND_PX) + call interpolate_var ('FMSAND_PX', jdate, jtime, Grid_Data%FMSAND_PX) + call interpolate_var ('WSAT_PX', jdate, jtime, Grid_Data%WSAT) + call interpolate_var ('WFC_PX', jdate, jtime, Grid_Data%WFC) + call interpolate_var ('WWLT_PX', jdate, jtime, Grid_Data%WWLT) End If - VNAME = 'PBL' - IF ( .NOT. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%PBL ) ) THEN - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - END IF C Met_cro_2D variables that have recently changed due to MCIP or WRF/CMAQ - If ( .Not. INTERPX( MET_CRO_2D, vname_rn, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%RN ) ) Then - XMSG = MSG1 // TRIM( vname_rn ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var (vname_rn, jdate, jtime, Met_Data%RN) - If ( .Not. INTERPX( MET_CRO_2D, vname_rc, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%RC ) ) Then - XMSG = MSG1 // TRIM( vname_rc ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - If ( ifwr ) Then - VNAME = 'WR' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%WR ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var (vname_rc, jdate, jtime, Met_Data%RC) + + call interpolate_var ('CFRAC', jdate, jtime, Met_Data%CFRAC) + + If ( WR_AVAIL ) Then + call interpolate_var ('WR', jdate, jtime, Met_Data%WR) End If - If ( ifsst ) Then - VNAME = 'TSEASFC' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%TSEASFC ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + If ( TSEASFC_AVAIL ) Then + call interpolate_var ('TSEASFC', jdate, jtime, Met_Data%TSEASFC) Else Met_Data%TSEASFC = Met_Data%TEMPG End If - If ( rinv ) Then - VNAME = 'RADYNI' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%RA ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + If ( .not. RA_RS_AVAIL ) Then + call interpolate_var ('RADYNI', jdate, jtime, Met_Data%RA) Where( Met_Data%RA .Gt. cond_min ) Met_Data%RA = 1.0/Met_Data%RA @@ -1431,13 +1056,7 @@ Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) Met_Data%RA = resist_max End Where - VNAME = 'RSTOMI' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%RS ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('RSTOMI', jdate, jtime, Met_Data%RS) Where( Met_Data%RS .Gt. cond_min ) Met_Data%RS = 1.0 / Met_Data%RS @@ -1447,73 +1066,49 @@ Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) Else - VNAME = 'RA' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%RA ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('RA', jdate, jtime, Met_Data%RA) - VNAME = 'RS' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%RS ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('RS', jdate, jtime, Met_Data%RS) End If - If ( ifq2 ) Then ! Q2 in METCRO2D - VNAME = 'Q2' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%Q2 ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + If ( Q2_AVAIL ) Then ! Q2 in METCRO2D + call interpolate_var ('Q2', jdate, jtime, Met_Data%Q2) Else Met_Data%Q2 = Met_Data%QV( :,:,1 ) End If - Es_Grnd => BUFF2D Where( Met_Data%TEMPG .Lt. stdtemp ) - Es_Grnd = vp0 *Exp( 22.514 - ( 6.15e3 / Met_Data%TEMPG ) ) + BUFF2D = vp0 *Exp( 22.514 - ( 6.15e3 / Met_Data%TEMPG ) ) Elsewhere - Es_Grnd = vp0 *Exp( svp2 * ( Met_Data%TEMPG -stdtemp ) / ( Met_Data%TEMPG -svp3 ) ) + BUFF2D = vp0 *Exp( svp2 * ( Met_Data%TEMPG -stdtemp ) / ( Met_Data%TEMPG -svp3 ) ) End Where - Met_Data%QSS_GRND = Es_Grnd * 0.622 / ( Met_Data%PRSFC - Es_Grnd ) - Nullify( Es_Grnd ) + Met_Data%QSS_GRND = BUFF2D * 0.622 / ( Met_Data%PRSFC - BUFF2D ) - Es_Air => BUFF2D Where( Met_Data%TEMP2 .Lt. stdtemp ) - Es_Air = vp0 *Exp( 22.514 - ( 6.15e3 / Met_Data%TEMP2 ) ) + BUFF2D = vp0 *Exp( 22.514 - ( 6.15e3 / Met_Data%TEMP2 ) ) Elsewhere - Es_Air = vp0 *Exp( svp2 * ( Met_Data%TEMP2 -stdtemp ) / ( Met_Data%TEMP2 -svp3 ) ) + BUFF2D = vp0 *Exp( svp2 * ( Met_Data%TEMP2 -stdtemp ) / ( Met_Data%TEMP2 -svp3 ) ) End Where - Met_Data%RH = Met_Data%Q2 / ( Es_Air * 0.622 / ( Met_Data%PRSFC - Es_Air ) ) * 100.0 - Where( Met_Data%RH .Gt. 100.0 ) - Met_Data%RH = 100.0 - Elsewhere( Met_Data%RH .lt. 0.0 ) - Met_Data%RH = 0.0 + + ! Calculate Relative Humidity at 2m + Met_Data%RH2 = Met_Data%Q2 / ( BUFF2D * 0.622 / ( Met_Data%PRSFC - BUFF2D ) ) * 100.0 + Where( Met_Data%RH2 .Gt. 100.0 ) + Met_Data%RH2 = 100.0 + Elsewhere( Met_Data%RH2 .lt. 0.0 ) + Met_Data%RH2 = 0.0 End Where - Nullify( Es_Air ) + + ! Calculate 3D Relative Humidity at Grid Scale + MET_DATA%RH = MET_DATA%QV * MET_DATA%PRES / ( MET_DATA%QV + 0.622015 ) / + & ( 610.94 * EXP( 17.625 * ( MET_DATA%TA - 273.15 ) / + & ( MET_DATA%TA - 273.15 + 243.04 ) ) ) + MET_DATA%RH = MIN( 0.9999, MAX( 0.001, MET_DATA%RH ) ) C-------------------------------- MET_DOT_3D -------------------------------- - If ( .Not. INTERPX( MET_DOT_3D, vname_uc, PNAME, - & STRTCOLMD3,ENDCOLMD3, STRTROWMD3,ENDROWMD3, 1,NLAYS, - & JDATE, JTIME, Met_Data%UWIND ) ) Then - XMSG = MSG1 // TRIM( vname_uc ) // ' from ' // MET_DOT_3D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT 1 ) - End If + call interpolate_var (vname_uc, jdate, jtime, Met_Data%UWIND) - If ( .Not. INTERPX( MET_DOT_3D, vname_vc, PNAME, - & STRTCOLMD3,ENDCOLMD3, STRTROWMD3,ENDROWMD3, 1,NLAYS, - & JDATE, JTIME, Met_Data%VWIND ) ) Then - XMSG = MSG1 // TRIM( vname_vc ) // ' from ' // MET_DOT_3D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT 1 ) - End If + call interpolate_var (vname_vc, jdate, jtime, Met_Data%VWIND) C get ghost values for wind fields in case of free trop. CALL SUBST_COMM ( Met_Data%UWIND, DSPL_N0_E1_S0_W0, DRCN_E ) @@ -1535,14 +1130,12 @@ Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) Met_Data%KZMIN = KZ0UT END IF - TV => BUFF3D - TV = Met_Data%TA * ( 1.0 + 0.608 * Met_Data%QV ) - Met_Data%THETAV = TV * ( P0 / Met_Data%PRES ) ** 0.286 - Nullify( TV ) + BUFF3D = Met_Data%TA * ( 1.0 + 0.608 * Met_Data%QV ) + Met_Data%THETAV = BUFF3D * ( P0 / Met_Data%PRES ) ** 0.286 C------ Updating MOL, then WSTAR, MOLI, HOL - DO R = 1, MY_NROWS - DO C = 1, MY_NCOLS + DO R = 1, NROWS + DO C = 1, NCOLS ! CPAIR = 1004.67 * ( 1.0 + 0.84 * Met_Data%QV( C,R,1 ) ) ! J/(K KG) CPAIR = CPD * ( 1.0 + 0.84 * Met_Data%QV( C,R,1 ) ) ! J/(K KG) TMPFX = Met_Data%HFX( C,R ) / ( CPAIR * Met_Data%DENS( C,R,1 ) ) @@ -1576,8 +1169,8 @@ Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) C------ Met_Data%CONVCT = .FALSE. - DO R = 1, MY_NROWS - DO C = 1, MY_NCOLS + DO R = 1, NROWS + DO C = 1, NCOLS DO L = 1, NLAYS IF ( Met_Data%PBL( C,R ) .LT. Met_Data%ZF( C,R,L ) ) THEN LP = L; EXIT @@ -1603,6 +1196,9 @@ Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) Met_Data%CONVCT = .True. End Where +! Calculate the cosine of the zenith angle + CALL CZANGLE(JDATE, JTIME, NCOLS, NROWS ) + Return End Subroutine GET_MET diff --git a/src/model/src/DUST_EMIS.F b/src/model/src/DUST_EMIS.F index a01d0696..2ba5a5ca 100644 --- a/src/model/src/DUST_EMIS.F +++ b/src/model/src/DUST_EMIS.F @@ -17,10 +17,6 @@ ! subject to their copyright restrictions. ! !------------------------------------------------------------------------! - -C RCS file, release, date & time of last delta, author, state, [and locker] -C $Header: /project/work/rep/arc/CCTM/src/emis/emis/DUST_EMIS.F,v 1.6 2011/10/21 16:10:45 yoj Exp $ - C::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: module dust_emis @@ -29,12 +25,6 @@ module dust_emis C * Extracts selected landuse categories from BELD01 and BELD03 and merges C * the selections into a dust-related landuse array (ULAND). -C Optionally, reads 3 gridded crop calendar file and calculates an -C erodible agriculture land fraction. (cropcal) - -C * Applies a predetermined removal fraction in and below canopy to -C * ULAND and determines a transport factor (TFB) for this regime. -C * = applies to tfbelow C Function: 3d point source emissions interface to the chemistry-transport model @@ -67,18 +57,23 @@ module dust_emis C Updated the dust diag output file accordingly. C 8 Jan 16 J.Young: Changes for computational efficiency C 2 Feb 16 J.Young: move dust aero speciation table to AERO_DATA +C 01 Feb 19 D.Wong: Implemented centralized I/O approach, removed all MY_N clauses +C 9 Jul 19 Gilliam: Removed a lot of old commented out legacy tables. +C Removed the direct read of FPAR MODIS file as this data comes +C directly from WRF LSM models that have access to MODIS veg data now. +C Number of soil types fixed to 16 to match WRF and tables updated. +C 3 Mar 22 Gilliam and Willison: Removed fugitive dust capture from canopies +C (tfa and tfb terms). Added soil texture information from PX when available. +C Removed deprecated option concerning erodable agland. Removed BELD as an option +C for input. C----------------------------------------------------------------------- use lus_defn use aero_data + use desid_vars implicit none -C windblown dust emissions rates - real, allocatable, save :: dustoutm( :,:,:,: ) ! mass emission rates [g/m**3/s] - real, allocatable, save :: dustoutn( :,:,: ) ! number emission rates [1/m**3/s] - real, allocatable, save :: dustouts( :,:,: ) ! surface-area emisrates [m2/m**3/s] - - public ndust_spc, dustoutm, dustoutn, dustouts, dust_spc, + public ndust_spc, dust_spc, & dust_emis_init, get_dust_emis private @@ -111,20 +106,17 @@ module dust_emis real, save :: factsrfj ! = pi * factm2j real, save :: factsrfk ! = pi * factm2k - real, save :: dustmode_dens( n_mode ) ! average modal density [kg/m**3] real :: sumsplit, sumfrac integer :: n, idx -C Number of soil types: For both WRF and MM5-PX met models, there are 16 types; -C the first 12 soil types are used and the rest lumped into Other. - integer, parameter :: nsltyp = 13 +C Number of soil types: For WRF there are 16 types; + integer, parameter :: nsltyp = 16 -C Variables for FENGSHA dust scheme +C Variables for FENGSHA dust scheme (Wei Li) real, save :: dust_alpha ! tuning parameter for FENGSHA dust emission flux C Variables for the windblown dust diagnostic file: - logical, save :: dustem_diag ! flag for dustemis diagnostic file - integer, parameter :: fndust_diag = 19 ! number of fixed diagnostic output vars + integer, parameter :: fndust_diag = 17 ! number of fixed diagnostic output vars integer, save :: ndust_diag ! number of diagnostic output vars real, allocatable, save :: diagv( : ) ! diagnostic output variables real, allocatable, save :: dustbf( :,:,: ) ! diagnostic accumulate buffer @@ -152,43 +144,34 @@ module dust_emis type( diag_type ), parameter :: fdiagnm( fndust_diag ) = (/ C var units desc C ---------------- -------- ------------------------------------------- - & diag_type( 'Cropland_Emis ', 'g/m**3/s', 'emissions for cropland landuse type '), - & diag_type( 'Desertland_Emis ', 'g/m**3/s', 'total emis for desert types and cropland '), - & diag_type( 'Cropland_Frac ', 'percent ', 'cropland erodible landuse fraction (%) '), - & diag_type( 'Desertland_Frac ', 'percent ', 'total desert fraction (%) '), - & diag_type( 'Cropland_Ustar ', 'm/s ', 'u* for cropland '), - & diag_type( 'Cropland_kvh ', '1/m ', 'cropland vert to horiz flux ratio '), - & diag_type( 'Cropland_Rough ', ' ', 'cropland surface roughness factor '), - & diag_type( 'Soil_Moist_Fac ', ' ', 'soil moisture factor for threshold u* '), - & diag_type( 'Soil_Erode_Pot ', ' ', 'soil -> dust erodiblity potential '), - & diag_type( 'Mx_Adsrb_H2O_Frc', ' ', 'max adsorbed water fraction '), - & diag_type( 'Vegetation_Frac ', ' ', 'vegetation land coverage '), - & diag_type( 'Urban_Cover ', 'percent ', 'urban land coverage '), - & diag_type( 'Forest_Cover ', 'percent ', 'forest land coverage '), - & diag_type( 'Trfac_Above_Can ', ' ', 'transport factor above canopy '), - & diag_type( 'Trfac_Inside_Can', ' ', 'transport factor in and below canopy '), - & diag_type( 'ANUMJ ', '#/s ', 'accumulation mode number '), - & diag_type( 'ANUMK ', '#/s ', 'coarse mode number '), - & diag_type( 'ASRFJ ', 'm**2/s ', 'accumulation mode surface area '), - & diag_type( 'ASRFK ', 'm**2/s ', 'coarse mode surface area ')/) + & diag_type( 'Cropland_Emis ', 'g m-3 s-1', 'emissions for cropland landuse type '), + & diag_type( 'Desertland_Emis ', 'g m-3 s-1', 'total emis for desert types and cropland '), + & diag_type( 'Cropland_Frac ', 'percent ', 'cropland erodible landuse fraction (%) '), + & diag_type( 'Desertland_Frac ', 'percent ', 'total desert fraction (%) '), + & diag_type( 'Cropland_Ustar ', 'm s-1 ', 'u* for cropland '), + & diag_type( 'Cropland_kvh ', 'm-1 ', 'cropland vert to horiz flux ratio '), + & diag_type( 'Cropland_Rough ', ' ', 'cropland surface roughness factor '), + & diag_type( 'Soil_Moist_Fac ', ' ', 'soil moisture factor for threshold u* '), + & diag_type( 'Soil_Erode_Pot ', '1 ', 'soil -> dust erodiblity potential '), + & diag_type( 'Mx_Adsrb_H2O_Frc', '1 ', 'max adsorbed water fraction '), + & diag_type( 'Vegetation_Frac ', '1 ', 'vegetation land coverage '), + & diag_type( 'Urban_Cover ', 'percent ', 'urban land coverage '), + & diag_type( 'Forest_Cover ', 'percent ', 'forest land coverage '), + & diag_type( 'ANUMJ ', 's-1', 'accumulation mode number '), + & diag_type( 'ANUMK ', 's-1', 'coarse mode number '), + & diag_type( 'ASRFJ ', 'm2 s-1 ', 'accumulation mode surface area '), + & diag_type( 'ASRFK ', 'm2 s-1 ', 'coarse mode surface area ')/) C Module shared variables: - real, allocatable, save :: agland( :,: ) ! agriculture land fraction real, allocatable, save :: wmax ( :,: ) ! max adsorb water percent real, allocatable, save :: kvh ( :,:,: ) ! ratio of vertical flux / horizontal (k factor) real, allocatable, save :: sd_ep ( :,: ) ! soil->dust erodiblity potential - real, allocatable, save :: tfb ( :,: ) ! transport fraction in and below canopy - real, allocatable, save :: fpar ( :,: ) ! modis fpar - - integer, save :: sdate, stime ! scenario start date & time real :: eropot( 3 ) = ! erodible potential of soil components & (/ 0.08, ! clay & 1.00, ! silt & 0.12 /) ! sand - integer, save :: logdev - CONTAINS C======================================================================= @@ -202,6 +185,8 @@ function dust_emis_init( jdate, jtime, tstep ) result( success ) use aero_data ! aerosol species definitions use asx_data_mod ! meteorology data use utilio_defn + use lus_data_module + use centralized_io_module C Arguments: integer, intent( in ) :: jdate ! current model date, coded YYYYDDD @@ -212,53 +197,68 @@ function dust_emis_init( jdate, jtime, tstep ) result( success ) C Includes: include SUBST_FILES_ID ! file name parameters -C External Functions: - integer, external :: setup_logdev - C Local variables: - character( 16 ) :: ctm_dustem_diag = 'CTM_DUSTEM_DIAG' ! env var for - ! diagnostic file - character( 16 ) :: ctm_erode_agland = 'CTM_ERODE_AGLAND' ! env var to - ! use erodible cropland character( 16 ) :: pname = 'DUST_EMIS_INIT' character( 16 ) :: vname character( 80 ) :: vardesc - character( 120 ) :: xmsg = ' ' - character( 16 ) :: modis_fpar_1 = 'MODIS_FPAR' - ! Fraction of Absorbed Photosynthetically Active Radiation + character( 250 ) :: xmsg = ' ' - logical :: erode_agland = .true. ! default integer status - integer c, r, i, j, k, l, n - integer idiag + integer c, r, i, j, k, l, n, im + integer idiag, idust, spc integer n_mass_emissions - integer gxoff, gyoff ! global origin offset from file - integer, save :: strtcol, endcol, strtrow, endrow - integer jdatemod + character( 16 ) :: sn type( diag_type ), allocatable :: diagnm_swap( : ) - interface - subroutine cropcal ( jdate, jtime, agland ) - integer, intent( in ) :: jdate, jtime - real, intent( out ) :: agland( :,: ) - end subroutine cropcal - subroutine tfbelow ( jdate, jtime, tfb ) - integer, intent( in ) :: jdate, jtime - real, intent( out ) :: tfb( :,: ) - end subroutine tfbelow - end interface C----------------------------------------------------------------------- - logdev = setup_logdev() success = .true. - - allocate ( dustoutm( ndust_spc,n_mode,ncols,nrows ), - & dustoutn( n_mode,ncols,nrows ), - & dustouts( n_mode,ncols,nrows ), stat = status ) + CALL LOG_MESSAGE( LOGDEV, 'Initialize Wind-Blown Dust Emissions' ) + +C...Populate Master Emissions Map Vector So That Diagnostics +C can be printed in EMIS_MAP + DESID_EMVAR( IDUSTSRM )%len = ndust_spc*2 + Allocate( DESID_EMVAR( IDUSTSRM )%arry( ndust_spc*2 ) ) + Allocate( DESID_EMVAR( IDUSTSRM )%units( ndust_spc*2 ) ) + Allocate( DESID_EMVAR( IDUSTSRM )%mw ( ndust_spc*2 ) ) + Allocate( DESID_EMVAR( IDUSTSRM )%used ( ndust_spc*2 ) ) + Allocate( DESID_EMVAR( IDUSTSRM )%conv ( ndust_spc*2 ) ) + Allocate( DESID_EMVAR( IDUSTSRM )%basis( ndust_spc*2 ) ) + Allocate( DESID_EMVAR( IDUSTSRM )%larea( ndust_spc*2 ) ) + Allocate( DESID_EMVAR( IDUSTSRM )%lareaadj( ndust_spc*2 ) ) + DESID_EMVAR( IDUSTSRM )%arry( : ) = 'NOT_AVAILABLE' + do i = 1,ndust_spc + IF ( dust_spc( i )%spcfac(1) .NE. 0.0 ) + & DESID_EMVAR( IDUSTSRM )%arry( i ) = + & 'PMFINE_' // dust_spc(i)%name + IF ( dust_spc( i )%spcfac(2) .NE. 0.0 ) + & DESID_EMVAR( IDUSTSRM )%arry( i+ndust_spc ) = + & 'PMCOARSE_' // dust_spc(i)%name + DESID_EMVAR( IDUSTSRM )%mw( i ) = dust_spc(i)%mw + DESID_EMVAR( IDUSTSRM )%mw( i+ndust_spc ) = dust_spc(i)%mw + end do + DESID_EMVAR( IDUSTSRM )%units( : ) = 'G/S' + DESID_EMVAR( IDUSTSRM )%used ( : ) = .FALSE. + DESID_EMVAR( IDUSTSRM )%conv ( : ) = 1.0 + DESID_EMVAR( IDUSTSRM )%basis( : ) = 'MASS' + DESID_EMVAR( IDUSTSRM )%larea( : ) = .FALSE. + DESID_EMVAR( IDUSTSRM )%lareaadj( : ) = .FALSE. + +C...Count the number of mass emissions species + n_mass_emissions = 0 + do i = 1, ndust_spc + do j = 1, 2 + if( dust_spc( i )%spcfac( j ) .gt. 0. ) + & n_mass_emissions = n_mass_emissions + 1 + end do + end do + allocate ( dustoutm( ndust_spc*2,ncols,nrows ), + & dustoutn( 2,ncols,nrows ), + & dustouts( 2,ncols,nrows ), stat = status ) if ( status .ne. 0 ) then xmsg = '*** Failure allocating DUSTOUTM, DUSTOUTN, or DUSTOUTS' call m3warn ( pname, jdate, jtime, xmsg ) @@ -273,77 +273,39 @@ end subroutine tfbelow success = .false.; return end if - if ( fengsha ) then + !add fengsha scheme (Wei Li) + if ( fengsha ) then C Disable diagnostic output if FENGSHA is used - dustem_diag = .false. + dustem_diag = .false. -C Allocate private arrays - allocate( tfb( ncols,nrows ), stat = status ) +C Allocate private arrays ! not used for now (Wei Li) + !allocate( tfb( ncols,nrows ), stat = status ) - if ( status .ne. 0 ) then - xmsg = '*** Failure allocating WMAX or TFB' - call m3warn( pname, jdate, jtime, xmsg ) - success = .false.; return - end if + if ( status .ne. 0 ) then + xmsg = '*** Failure allocating WMAX or TFB' + call m3warn( pname, jdate, jtime, xmsg ) + success = .false.; return + end if C Initialize land use/cover variables - if ( .not. lus_init( jdate, jtime ) ) then - xmsg = 'Failure initializing land use module' - call m3exit( pname, jdate, jtime, xmsg, xstat2 ) - end if + if ( .not. lus_init( jdate, jtime ) ) then + xmsg = 'Failure initializing land use module' + call m3exit( pname, jdate, jtime, xmsg, xstat2 ) + end if - else + else !else fengsha is off & default is on C Allocate private arrays - allocate( agland( ncols,nrows ), - & wmax ( ncols,nrows ), - & sd_ep ( ncols,nrows ), - & fpar ( ncols,nrows ), - & tfb ( ncols,nrows ), stat = status ) + allocate( wmax ( ncols,nrows ), + & sd_ep ( ncols,nrows ), stat = status) if ( status .ne. 0 ) then - xmsg = '*** Failure allocating AGLAND, WMAX, FPAR, SD_EP, or TFB' + xmsg = '*** Failure allocating WMAX, or SD_EP' call m3warn( pname, jdate, jtime, xmsg ) success = .false.; return end if - agland = 0.0 ! array assignment wmax = 0.0 ! array assignment sd_ep = 0.0 ! array assignment - fpar = 0.0 ! array assignment - -C Open MODIS file to get vegetation fraction - if ( .not. open3( modis_fpar_1, fsread3, pname ) ) then - xmsg = 'Could not open ' // modis_fpar_1 - call m3exit( pname, jdate, jtime, xmsg, xstat1 ) - end if - -C Get the file description - if ( .not. desc3( modis_fpar_1 ) ) then - xmsg = 'Could not get ' - & // trim( modis_fpar_1 ) - & // ' file description' - call m3exit( pname, jdate, jtime, xmsg, xstat1 ) - end if - -C To be able to use either climatological (2001-2010 averaged) or -C current fpar value. The year for the climatological fpar is 2005 in -C the input file. - if ( sdate3d .eq. 2005001 ) then ! climatological - jdatemod = 2005000 + mod( jdate,1000 ) - else ! current - jdatemod = jdate - end if - -C Get domain decomp info - call subhfile ( modis_fpar_1, gxoff, gyoff, - & strtcol, endcol, strtrow, endrow ) - -C Read in FPAR from MODIS file - xmsg = 'Could not read FPAR from ' // trim( modis_fpar_1 ) - if ( .not. xtract3( modis_fpar_1, 'MODIS_FPAR_T', 1,1, - & strtrow,endrow,strtcol,endcol, - & jdatemod, jtime, fpar( 1,1 ) ) ) - & call m3exit ( pname, jdate, jtime, xmsg, xstat1 ) C Initialize land use/cover variables if ( .not. lus_init( jdate, jtime ) ) then @@ -351,23 +313,6 @@ end subroutine tfbelow call m3exit( pname, jdate, jtime, xmsg, xstat2 ) end if -C Get env var for diagnostic output - dustem_diag = .false. ! default - vardesc = 'Flag for writing the windblown dust emission diagnostic file' - dustem_diag = envyn( ctm_dustem_diag, vardesc, dustem_diag, status ) - if ( status .ne. 0 ) write( logdev,'( 5x, a )' ) vardesc - if ( status .eq. 1 ) then - xmsg = 'Environment variable improperly formatted' - call m3warn( pname, jdate, jtime, xmsg ) - success = .false.; return - else if ( status .eq. -1 ) then - xmsg = 'Environment variable set, but empty ... Using default:' - write( logdev,'( 5x, a, i9 )' ) xmsg, jtime - else if ( status .eq. -2 ) then - xmsg = 'Environment variable not set ... Using default:' - write( logdev,'( 5x, a, i9 )' ) xmsg, jtime - end if - if ( dustem_diag ) then ! Open the emissions diagnostic file C Set up variable diagnostic names (from LUS_DEFN) @@ -387,15 +332,7 @@ end subroutine tfbelow vdiagnm_kvh = diag_type( ' ', ' ', ' ' ) ! array assignment vdiagnm_rough = diag_type( ' ', ' ', ' ' ) ! array assignment -C...Count the number of mass emissions species - n_mass_emissions = 0 - do i = 1, ndust_spc - do j = 1, n_mode - if( len_trim( dust_spc( i )%name( j ) ) .lt. 1 )cycle - n_mass_emissions = n_mass_emissions + 1 - end do - end do - +C...Set Up Diagnostic Species Variables ndust_diag = fndust_diag + 5 * n_dlcat + n_mass_emissions do i = 1, n_dlcat @@ -480,35 +417,30 @@ end subroutine tfbelow end do C...append diagnostic variables with mass emissions species - do j = 2, n_mode + do j = 1, 2 do i = 1, ndust_spc - n = len_trim( dust_spc( i )%name( j ) ) - if( n .lt. 1 )cycle ! assumes cmaq species names atleast one character long - n = 0 - do k = 1, idiag ! determine if dust emissions is already added to diagnostic output - if( dust_spc( i )%name( j ) .Eq. diagnm( k )%var )Then + if( dust_spc( i )%spcfac( j ) .eq. 0. ) cycle + n = 0 + do k = 1, idiag ! determine if dust emissions is already added to diagnostic output + if( trim( DESID_EMVAR( IDUSTSRM )%ARRY( (j-1)*ndust_spc+i )) + & .Eq. diagnm( k )%var ) Then n = k exit end if end do - if( n .gt. 0 )then ! skip already added - cycle - else - idiag = idiag + 1 - diagnm( idiag )%var = dust_spc( i )%name( j ) - end if + if( n .gt. 0 ) cycle ! skip already added + + idiag = idiag + 1 + diagnm( idiag )%var = DESID_EMVAR( IDUSTSRM )%ARRY( (j-1)*ndust_spc+i ) diagnm( idiag )%units = 'g/m**3/s' + Select Case( j ) ! assumes only two aerosol modes dust emissions -! Case( 1 ) -! diagnm( idiag )%desc = 'aitken mode' - Case( 2 ) - diagnm( idiag )%desc = 'accumulation mode' - Case( 3 ) - diagnm( idiag )%desc = 'coarse mode' -! Case Default -! diagnm( idiag )%des = 'Undefined mode ' - end Select - diagnm( idiag )%desc = Trim( diagnm( idiag )%desc ) + Case( 1 ) + diagnm( idiag )%desc = 'fine mode' + Case( 2 ) + diagnm( idiag )%desc = 'coarse mode' + end Select + diagnm( idiag )%desc = Trim( diagnm( idiag )%desc ) & // ' emissions for ' & // Trim( dust_spc( i )%description ) end do @@ -521,7 +453,7 @@ end subroutine tfbelow call m3warn( pname, jdate, jtime, xmsg ) success = .false.; return end if - diagnm_swap = diagnm + diagnm_swap = diagnm deallocate( diagnm ) @@ -535,47 +467,12 @@ end subroutine tfbelow diagnm( 1:ndust_diag ) = diagnm_swap( 1:ndust_diag ) deallocate( diagnm_swap ) - sdate = envint( 'CTM_STDATE', 'Scenario Start (YYYYJJJ)', 0, status ) - stime = envint( 'CTM_STTIME', 'Scenario Start (HHMMSS)', 0, status ) - if ( io_pe_inclusive ) - & call opdust_emis ( sdate, stime, tstep, ndust_diag, diagnm ) + & call opdust_emis ( stdate, sttime, tstep, ndust_diag, diagnm ) end if ! dustem_diag -C Get env var for erodible agriculture land fraction - erode_agland = .false. ! default - vardesc = 'Flag for calculating erodible agriculture land fraction' - erode_agland = envyn( ctm_erode_agland, vardesc, erode_agland, status ) - if ( status .ne. 0 ) write( logdev,'( 5x, a )' ) vardesc - if ( status .eq. 1 ) then - xmsg = 'Environment variable improperly formatted' - call m3warn( pname, jdate, jtime, xmsg ) - success = .false.; return - else if ( status .eq. -1 ) then - xmsg = 'Environment variable set, but empty ... Using default:' - write( logdev,'( 5x, a, i9 )' ) xmsg, jtime - else if ( status .eq. -2 ) then - xmsg = 'Environment variable not set ... Using default:' - write( logdev,'( 5x, a, i9 )' ) xmsg, jtime - end if - - if ( erode_agland ) then - call cropcal ( sdate, stime, agland ) - do r = 1, my_nrows - do c = 1, my_ncols - if ( agland( c,r ) .lt. 0.0 .or. agland( c,r ) .gt. 100.0 ) then - xmsg = '*** ERROR in AGLAND' - call m3exit( pname, jdate, jtime, xmsg, xstat1 ) - end if - end do - end do - end if - - end if ! dust scheme - -C Get transport factor within canopy and 4 land use type percents - call tfbelow ( jdate, jtime, tfb ) + end if ! end dust scheme (Wei Li) l2sgj = log( sigj ) * log( sigj ) l2sgk = log( sigk ) * log( sigk ) @@ -590,29 +487,12 @@ end subroutine tfbelow factsrfj = pi * factm2j factsrfk = pi * factm2k -C Calculate modal average dust particle densities (accum and coarse modes) [ kg/m**3 ] -C The following works because the dust_spc`s are a fixed split of the total emitted -C mass. - dustmode_dens( 1 ) = 0.0 - do n = 2, n_mode - sumsplit = 0.0; sumfrac = 0.0 - do i = 1, ndust_spc - idx = findAero( dust_spc( i )%name( n ), .true. ) - if( aerospc( idx )%tracer )cycle - if( dust_spc( i )%spcfac( n ) .lt. 1.0e-30 )cycle - sumsplit = sumsplit + dust_spc( i )%spcfac( n ) ! should = 1.0 - sumfrac = sumfrac + dust_spc( i )%spcfac( n ) / aerospc( idx )%density - end do - dustmode_dens( n ) = sumsplit / sumfrac - end do - #ifdef verbose_wbdust write( logdev,* ) ' ' write( logdev,* ) ' l2sgj,l2sgk: ', l2sgj, l2sgk write( logdev,* ) ' factnumj,factnumk: ', factnumj, factnumk write( logdev,* ) ' factm2j,factm2k: ', factm2j, factm2k write( logdev,* ) ' factsrfj,factsrfk: ', factsrfj, factsrfk - write( logdev,* ) ' modal avg dens(j/k): ', dustmode_dens( 2 ), dustmode_dens( 3 ) write( logdev,* ) ' ' #endif @@ -707,23 +587,29 @@ subroutine opdust_emis ( jdate, jtime, tstep, ndust_var, dust_var ) end subroutine opdust_emis C======================================================================= - subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt ) + subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt, + & l_desid_diag) use grid_conf ! horizontal & vertical domain specifications use asx_data_mod ! meteorology data use aero_data use utilio_defn + use lus_data_module + use centralized_io_module + use RUNTIME_VARS, only: WRF_V4P C 8/18/11 D.Wong: incorporated twoway model implementation and change C RC -> RCA and RN -> RNA and made it backward compatible C 8/12/15 D.Wong: added code to handle parallel I/O implementation C Arguments: - integer, intent( in ) :: jdate ! current model date, coded YYYYDDD - integer, intent( in ) :: jtime ! current model time, coded HHMMSS - integer, intent( in ) :: tstep( 3 ) ! output time step, sync step, 2way step + integer, intent( in ) :: jdate ! current model date, coded YYYYDDD + integer, intent( in ) :: jtime ! current model time, coded HHMMSS + integer, intent( in ) :: tstep( 3 ) ! output time step, sync step, 2way step real, intent( in ) :: rjacm( ncols,nrows ) ! reciprocal Jacobian [1/m] - real, intent( in ) :: cellhgt ! grid-cell height [sigma] + real, intent( in ) :: cellhgt ! grid-cell height [sigma] + logical, intent( in ) :: l_desid_diag ! flag determining whether or not DESID + ! is in diagnostic mode C Includes: include SUBST_FILES_ID ! file name parameters @@ -738,7 +624,6 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt ) ! 4 Clay real, parameter :: f6dpi = 6.0 / pi - real, parameter :: gpkg = 1.0e03 ! g/kg real, parameter :: mv = 0.16 real, parameter :: sigv = 1.45 @@ -751,13 +636,15 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt ) real, parameter :: sigb_mb = sigb * mb ! = 0.5 real, parameter :: betab_mb = betab * mb ! = 45.0 + !(Wei Li) character( 24 ) :: ctm_wbdust_fengsha_alpha = 'CTM_WBDUST_FENGSHA_ALPHA' ! env var to ! retrieve FENGSHA scaling factor + character( 16 ) :: pname = 'GET_DUST_EMIS' character( 16 ) :: vname character( 96 ) :: xmsg integer status - integer c, r, j, m, n, v + integer c, r, j, m, n, v, isd integer, save :: wstep = 0 ! local write counter integer :: mdate, mtime ! diagnostic file write date&time @@ -765,7 +652,6 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt ) ! automatic arrays real :: fmoit ( ncols,nrows ) ! factor of soil moisture on u*t real :: soimt ( ncols,nrows ) ! gravimetric soil moisture (Kg/Kg) - real :: tfa ( ncols,nrows ) ! transport fraction above canopy real :: wrbuf ( ncols,nrows ) ! diagnositc write buffer real :: vegfrac( ncols,nrows ) ! vegetation fraction real :: vegfree ! 1.0 - vegfrac for this col, row @@ -776,7 +662,7 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt ) real, allocatable, save :: elus ( :,:,: ) ! erodible landuse percent (0~100) real, allocatable, save :: fruf ( :,:,: ) ! surface roughness factor - real :: edust( n_mode ) ! mass emis rate [g/s] per mode (only accum & coarse) + real :: edust( 2 ) ! mass emis rate [g/s] per mode (only accum & coarse) real :: sumdfr ! sum var for desert fraction real :: rlay1hgt ! reciprocal of layer-1 height [1/m] real :: m3j ! 3rd moment accumulation (J) mode emis rates [m3/m3/s] @@ -791,30 +677,14 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt ) real :: lambdav ! vegetation roughness density - Shao et. al [Aus. J. Soil Res., 1996] real :: flxfac1, flxfac2 ! combined soli type mapping factors real :: hflux, vflux ! horizontal and vertical dust flux - real :: v2h ! vertical/horizontal dust flux ratio - real :: wm ! max adsorb water [%] + real :: v2h ! vertical/horizontal dust flux ratio !(Wei Li) + real :: wm ! max adsorb water [%] !(Wei Li) real :: jday integer :: emap( n_dlcat+1 ) C---Height for veg elements real :: hv( 4 ) -C---Vegetation fraction for 4 land types ! not used -C from Federal Geographic Data Committee [1997] -C Note: All other landuse types are mapped into these 4 types. -! real :: vegfra( 4 ) = -! & (/ 0.11, ! shrubland -! & 0.17, ! shrubgrass -! & 0.01, ! barrenland -! & 0.30 /) ! cropland - -C---Height for solid elements -! real :: hb( 4 ) = -! & (/ 0.01, ! shrubland -! & 0.02, ! shrubgrass -! & 0.005, ! barrenland -! & 0.02 /) ! cropland - C---Roughness density for solid elements C from Darmenova et al. [JGR,2009] and Xi and Sokolik [JGR,2015] real :: lambdab( 4 ) = @@ -830,48 +700,6 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt ) & 2.0e-06, ! barrenland & 3.0e-03 /) ! cropland -C Soil moisture limit: 13 types and 3 variables, which are: -C 1 - saturation moisture limit, (gravimetric units assumed, Kg/Kg) - !!!! This is probably volumetric-- NOAH -C 2 - fill capacity, and <- not used -C 3 - wilting point <- not used -C Modified values compatiable with both MM5 & NAM. -C Silt values are based on NAM documentation on soil types. -C Other includes all types higher than 12. The values of Other, serving as -C placeholders, are randomly chosen. Values of Other, however, have no effect -C on dust emissions as the threshold velocity of Other will be high. -C real :: soilml( nsltyp,3 ) = reshape ( -C & (/ 0.395, 0.135, 0.068, ! Sand -C & 0.410, 0.150, 0.075, ! Loamy Sand -C & 0.435, 0.195, 0.114, ! Sandy Loam -C & 0.485, 0.255, 0.179, ! Silt Loam -C & 0.476, 0.361, 0.084, ! Silt -C & 0.451, 0.240, 0.155, ! Loam -C & 0.420, 0.255, 0.175, ! Sandy Clay Loam -C & 0.477, 0.322, 0.218, ! Silty Clay Loam -C & 0.476, 0.325, 0.250, ! Clay Loam -C & 0.426, 0.310, 0.219, ! Sandy Clay -C & 0.482, 0.370, 0.283, ! Silty Clay -C & 0.482, 0.367, 0.286, ! Clay -C & 0.482, 0.367, 0.286 /), ! Other -C & (/ nsltyp,3 /), order = (/ 2,1 /) ) ! fill columns first - -C Since only soilml( nsltyp,1 ) is used, set the following: -! real :: soilml1( nsltyp ) = -! & (/ 0.395, ! Sand -! & 0.410, ! Loamy Sand -! & 0.435, ! Sandy Loam -! & 0.485, ! Silt Loam -! & 0.476, ! Silt -! & 0.451, ! Loam -! & 0.420, ! Sandy Clay Loam -! & 0.477, ! Silty Clay Loam -! & 0.476, ! Clay Loam -! & 0.426, ! Sandy Clay -! & 0.482, ! Silty Clay -! & 0.482, ! Clay -! & 0.482 /) ! Other - C converted to gravimetric [kg/kg] real :: soilml1( nsltyp ) = & (/ 0.242, ! Sand @@ -886,40 +714,10 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt ) & 0.284, ! Sandy Clay & 0.357, ! Silty Clay & 0.344, ! Clay - & 0.363 /) ! Other - -!! FROM NCAR LSM Group 17 Apr 2007 "volumetric" -!! ALSO in Spyrou, et al. [JGR,2010] -! real :: soilml1( nsltyp ) = -! & (/ 0.339, ! Sand -! & 0.421, ! Loamy Sand -! & 0.434, ! Sandy Loam -! & 0.476, ! Silt Loam -! & 0.476, ! Silt -! & 0.439, ! Loam -! & 0.404, ! Sandy Clay Loam -! & 0.464, ! Silty Clay Loam -! & 0.465, ! Clay Loam -! & 0.406, ! Sandy Clay -! & 0.468, ! Silty Clay -! & 0.468, ! Clay -! & 0.482 /) ! Other - -C convert to gravimetric [kg/kg] -! real :: soilml1( nsltyp ) = -! & (/ 0.208, ! Sand -! & 0.264, ! Loamy Sand -! & 0.286, ! Sandy Loam -! & 0.344, ! Silt Loam -! & 0.350, ! Silt -! & 0.299, ! Loam -! & 0.266, ! Sandy Clay Loam -! & 0.341, ! Silty Clay Loam -! & 0.324, ! Clay Loam -! & 0.271, ! Sandy Clay -! & 0.347, ! Silty Clay -! & 0.334, ! Clay -! & 0.363 /) ! Other + & 0.329, ! Organic Material + & 0.000, ! Water + & 0.170, ! BedRock + & 0.280 /) ! Other C---Soil texture: the amount of C 1: Coarse sand, 2: Fine-medium sand, 3: Silt, 4: Clay @@ -937,9 +735,13 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt ) & 0.00, 0.52, 0.06, 0.42, ! Sandy Clay & 0.00, 0.06, 0.47, 0.47, ! Silty Clay & 0.00, 0.22, 0.20, 0.58, ! Clay + & 0.00, 0.00, 0.00, 0.00, ! Organic Material + & 0.00, 0.00, 0.00, 0.00, ! Water + & 0.00, 0.00, 0.00, 0.00, ! BedRock & 0.00, 0.00, 0.00, 0.00 /), ! Other & (/ nsltyp,4 /), order = (/ 2,1 /) ) ! fill columns first + C---Mean mass median particle diameter (m) for each soil texture type C Chatenet et al. [Sedimentology,1996] and Menut et al. [JGR,2013] real :: dp( ndp ) = @@ -947,12 +749,10 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt ) & 210.0E-6, ! Fine-medium sand & 125.0E-6, ! Silt & 2.0E-6 /) ! Clay +C---Soil texture vars of the grid cell + real :: soiltxt_gcell( ndp ) + real :: clay, csand, fmsand, sandf, siltf - interface - subroutine tfabove ( tfa ) - real, intent( out ) :: tfa( :,: ) - end subroutine tfabove - end interface #ifdef verbose_wbdust integer dryhit @@ -963,38 +763,39 @@ end subroutine tfabove if ( firstime ) then firstime = .false. - if ( fengsha ) then + !call dust_alpha from env variable (Wei Li) + if ( fengsha ) then dust_alpha = 0.05 ! default dust_alpha = envreal( ctm_wbdust_fengsha_alpha, - & 'Emission global scaling factor for FENGSHA dust scheme', - & dust_alpha, status ) + & 'Emission global scaling factor for FENGSHA dust scheme', + & dust_alpha, status ) if ( status .ne. 0 ) then xmsg = '*** Failure retrieving FENGSHA scaling factor' call m3exit( pname, jdate, jtime, xmsg, xstat1 ) end if write(xmsg,'("Using FENGSHA alpha = ",g12.5)') dust_alpha - call m3msg2 ( xmsg ) - else + call m3msg2 ( xmsg ) !from AQM/src/io/ioapi/m3msg2.F90 + !if envreal is not found (from IOAPI app); try below from 'get_env_module' + !The ctm_wbdust_fengsha_alpha = 'CTM_WBDUST_FENGSHA_ALPHA' can be deleted + !call GET_ENV(dust_alpha, 'CTM_WBDUST_FENGSHA_ALPHA', dust_alpha, VARDEV) + else !else is default scheme allocate ( ustr( ncols,nrows,n_dlcat+1 ), - & qam( ncols,nrows,n_dlcat+1 ), - & fruf( ncols,nrows,n_dlcat+1 ), - & kvh( ncols,nrows,n_dlcat+1 ), - & elus( ncols,nrows,n_dlcat+1 ), stat = status ) + & qam( ncols,nrows,n_dlcat+1 ), + & fruf( ncols,nrows,n_dlcat+1 ), + & kvh( ncols,nrows,n_dlcat+1 ), + & elus( ncols,nrows,n_dlcat+1 ), stat = status ) if ( status .ne. 0 ) then xmsg = '*** Failure allocating USTR, QAM, FRUF, KVH, or ELUS' call m3exit( pname, jdate, jtime, xmsg, xstat1 ) end if - end if + end if !end fengsha end if -C---Calculate transport factor above the canopy - call tfabove ( tfa ) - C---Select dust scheme - if ( fengsha ) then + if ( fengsha ) then - do r = 1, my_nrows - do c = 1, my_ncols + do r = 1, nrows + do c = 1, ncols dust_em( c,r ) = 0.0 soimt( c,r ) = 0.0 @@ -1041,15 +842,15 @@ end subroutine tfabove vflux = v2h * hflux ! [g/m**2/s] rlay1hgt = rjacm ( c,r ) / cellhgt - - dust_em( c,r ) = dust_alpha * vflux * rlay1hgt * tfa(c,r) * tfb(c,r) + !tfb and tfa not used for now (Wei Li) + dust_em( c,r ) = dust_alpha * vflux * rlay1hgt !* tfa(c,r) * tfb(c,r) end if ! if rain & land & snow & drag end do ! c end do ! r - else ! default dust scheme + else ! default dust scheme C---Get Julian day number in year jday = float( mod( jdate,1000 ) ) @@ -1083,7 +884,7 @@ end subroutine tfabove #endif C Initialize windblown dust diagnostics output buffer - if ( dustem_diag .and. wstep .eq. 0 ) then + if ( dustem_diag .and. wstep .eq. 0 .and. .not. l_desid_diag ) then dustbf = 0.0 ! array assignment #ifdef verbose_wbdust sdiagv = 0.0 ! array assignment @@ -1095,11 +896,20 @@ end subroutine tfabove emap( m ) = dmap( m ) ! dmap maps to one of the 3 BELD3 desert types end do emap( n_dlcat+1 ) = 4 +C Check PX soil texture data flag and log a message if or if not used in WB dust + if(PXSOIL_AVAIL) then + CALL LOG_MESSAGE( LOGDEV, '================== Windblown Dust Message =====================' ) + CALL LOG_MESSAGE( LOGDEV, ' WRFV4.1+ inputs have extra PX LSM soil texture and props used.' ) + CALL LOG_MESSAGE( LOGDEV, ' Clay, coarse and fine-medium sand from PX LSM not lookup tables.' ) + else + CALL LOG_MESSAGE( LOGDEV, '================== Windblown Dust Message =====================' ) + CALL LOG_MESSAGE( LOGDEV, ' Clay, coarse and fine-medium sand from internal lookup table.' ) + end if C --------- ###### Start Main Loop ###### --------- - do r = 1, my_nrows - do c = 1, my_ncols + do r = 1, nrows + do c = 1, ncols dust_em( c,r ) = 0.0 soimt( c,r ) = 0.0 fmoit( c,r ) = 0.0 ! for diagnostic output visualization @@ -1114,8 +924,36 @@ end subroutine tfabove rlay1hgt = rjacm ( c,r ) / cellhgt -C---Vegetation fraction based on the MODIS FPAR - vegfrac( c,r ) = max( min( fpar( c,r ), 0.95 ), 0.005 ) + +C--- Set Clay, coarse and fine/medium sand fractions. +C--- If value from WRF is missing (-9999.) use old table values +C-- If value from WRF is from WRFV4.1 PX LSM csand_px, etc use those + j = Grid_Data%sltyp( c,r ) + + if (.not. WRF_V4P) then +C Adjust WRF soil definitions to match internal Menut et al. [JGR,2013] Table + if ( j .gt. 4 ) j = j + 1 + if ( j .gt. 13 ) j = 13 + end if + + if(PXSOIL_AVAIL) then + clay = Grid_Data%clay_px(c,r) + csand = Grid_Data%csand_px(c,r) + fmsand = Grid_Data%fmsand_px(c,r) + else + csand = soiltxt(j,1) + fmsand = soiltxt(j,2) + clay = soiltxt(j,4) + end if + + sandf = csand + fmsand + siltf = 1.0 - clay - sandf + + +C---Vegetation fraction based on the WRF/MCIP VEG variable. In WRF that would be VEGF_PX +C-- for the case of PX and VEGFRA in the case of other LSMs. In more recent WRFv4+ versions +C-- high resolution MODIS veg data is availiable and can be used in PX with pxlsm_modis_veg = 1 + vegfrac( c,r ) = max( min( Met_Data%veg(c,r), 0.95 ), 0.005) vegfree = 1.0 - vegfrac( c,r ) lambdav = -0.35 * log( vegfree ) ! Shao et al. [Aus. J. Soil Res.,1996] @@ -1132,23 +970,17 @@ end subroutine tfabove & ( Met_Data%snocov( c,r ) .lt. 0.001 ) ) then ! less than 0.1% snow coverage C---Dust possiblity 1,2,3 - j = Grid_Data%sltyp( c,r ) - -C kludge (fixed in wrf-px after 4 Mar 11) - if ( j .gt. 4 ) j = j + 1 ! PX combines "silt" with "silt loam" - if ( j .gt. 13 ) j = 13 ! = ? C Calculate maximum amount of the adsorbed water C w` = 0.0014(%clay)**2 + 0.17(%clay) - w` in % C Fecan et al. [1999,Annales Geophys.,17,144-157] - wmax( c,r ) = ( 14.0 * soiltxt( j,4 ) + 17.0 ) * soiltxt( j,4 ) ! [%] + wmax( c,r ) = ( 14.0 * clay + 17.0 ) * clay ! [%] ! write( logdev,'( 2x, a, i8.6, f12.5 )' ) 'max wmax:', jtime, maxval( wmax ) C Change soil moisture units from volumetric (m**3/m**3) to gravimetric (Kg/Kg) - soimt( c,r ) = Met_Data%soim1( c,r ) ! <- [m**3/m**3] - & * 1000.0 / ( 2650.0 * ( 0.511 + 0.126 - & * ( soiltxt( j,1 ) + soiltxt( j,2 ) ) ) ) + soimt( c,r ) = Met_Data%soim1( c,r ) + & * 1000.0 / ( 2650.0 * ( 0.511 + 0.126 * sandf ) ) if ( soimt( c,r ) .le. soilml1( j ) ) then C---Dust possiblity 4 @@ -1166,9 +998,8 @@ end subroutine tfabove end if C---Erodibility potential of soil component - sd_ep( c,r ) = soiltxt( j,4 ) * eropot( 1 ) - & + soiltxt( j,3 ) * eropot( 2 ) - & + ( soiltxt( j,1 ) + soiltxt( j,2 ) ) * eropot( 3 ) + sd_ep( c,r ) = clay * eropot( 1 ) + & + siltf * eropot( 2 ) + sandf * eropot( 3) C---Lu and Shao [JGR,1999] and Kang et al. [JGR,2011] C First, mapping soil types into 4 main soil types following Kang et al. [JGR,2011] @@ -1218,7 +1049,6 @@ end subroutine tfabove do m = 1, n_dlcat ! desert type landuse category elus( c,r,m ) = ladut( c,r,m ) * vegfree ! desert land [%] end do - elus( c,r,n_dlcat+1 ) = agland( c,r ) * vegfree ! crop land [%] C ------- Start Loop Over Erodible Landuse ---- @@ -1263,8 +1093,12 @@ end subroutine tfabove ! kvh( c,r,m ) = ( calpha * 9.81 * pfrac * 1000.0 / 2.0 / pp ) ! & * ( 0.24 + 2.09 * ustr( c,r,m ) * sqrt( 2650.0 / pp ) ) kvh( c,r,m ) = flxfac1 * ( 0.24 + flxfac2 * ustr( c,r,m ) ) + soiltxt_gcell(1) = csand + soiltxt_gcell(2) = fmsand + soiltxt_gcell(3) = siltf + soiltxt_gcell(4) = clay hflux = dust_hflux( ndp, dp, - & soiltxt( j,: ), + & soiltxt_gcell( : ), & fmoit( c,r ), & fruf( c,r,m ), & ustr( c,r,m ), @@ -1286,10 +1120,6 @@ end subroutine tfabove C ------- End Loop Over Erodible Landuse ---- -C Dust removal by surrounding vegetation <-??? -C Adjust dust emissions for transport factors - - dust_em( c,r ) = dust_em( c,r ) * tfa( c,r ) * tfb( c,r ) end if ! if soil moisture end if ! if rain & land & snow @@ -1304,46 +1134,52 @@ end subroutine tfabove & out of total cells:', & dryhit, (c-1)*(r-1) #endif + end if ! dust scheme (Wei Li) - end if ! dust scheme - - do r = 1, my_nrows - do c = 1, my_ncols + do r = 1, nrows + do c = 1, ncols C J/K mass emis rate [g/s] (edust( 1 ) not used) - edust( 2 ) = fracmj * dust_em( c,r ) - edust( 3 ) = fracmk * dust_em( c,r ) + edust( 1 ) = fracmj * dust_em( c,r ) + edust( 2 ) = fracmk * dust_em( c,r ) - do v = 1, ndust_spc - dustoutm( v,1,c,r ) = 0.0 - end do - - do n = 2, n_mode + do n = 1,2 do v = 1, ndust_spc - dustoutm( v,n,c,r ) = edust( n ) * dust_spc( v )%spcfac( n ) + dustoutm( (n-1)*ndust_spc+v,c,r ) = + & edust( n ) * dust_spc( v )%spcfac( n ) end do end do C J/K 3rd moment emis rate [m3/s] (needed for number and surface) - m3j = edust( 2 ) * f6dpi / ( gpkg * dustmode_dens( 2 ) ) - m3k = edust( 3 ) * f6dpi / ( gpkg * dustmode_dens( 3 ) ) + m3j = edust( 1 ) * f6dpi / ( gpkg * dust_dens( 1 ) ) + TINY(0.0) + m3k = edust( 2 ) * f6dpi / ( gpkg * dust_dens( 2 ) ) + TINY(0.0) C Mode-specific emission rates of particle number [1/s] - dustoutn( 1,c,r ) = 0.0 - dustoutn( 2,c,r ) = m3j * factnumj - dustoutn( 3,c,r ) = m3k * factnumk + dustoutn( 1,c,r ) = m3j * factnumj + dustoutn( 2,c,r ) = m3k * factnumk C Mode-specific dry surface area emission rates [m**2/s]. C 2nd moment multiplied by PI to obtain the surface area emissions rate. - dustouts( 1,c,r ) = 0.0 - dustouts( 2,c,r ) = m3j * factsrfj - dustouts( 3,c,r ) = m3k * factsrfk + dustouts( 1,c,r ) = m3j * factsrfj + dustouts( 2,c,r ) = m3k * factsrfk + +! Propagate Number and Surface Area Scaling Factors back to Emissions +! Module so that the dust emissions can be scaled appropriately + ISD = INDEX1( 'FINE', DESID_STREAM_AERO( IDUSTSRM )%LEN, + & DESID_STREAM_AERO( IDUSTSRM )%NAME ) + DESID_STREAM_AERO( IDUSTSRM )%FACNUM( ISD,2 ) = FACTNUMJ + DESID_STREAM_AERO( IDUSTSRM )%FACSRF( ISD,2 ) = FACTSRFJ + + ISD = INDEX1( 'COARSE', DESID_STREAM_AERO( IDUSTSRM )%LEN, + & DESID_STREAM_AERO( IDUSTSRM )%NAME ) + DESID_STREAM_AERO( IDUSTSRM )%FACNUM( ISD,3 ) = FACTNUMK + DESID_STREAM_AERO( IDUSTSRM )%FACSRF( ISD,3 ) = FACTSRFK #ifdef verbose_wbdust if ( m3j .ne. 0.0 ) dusthit = dusthit + 1 #endif - if ( dustem_diag ) then + if ( dustem_diag .and. .not. l_desid_diag ) then do m = 1, n_dlcat+1 diagv( m ) = qam( c,r,m ) ! g/m**3/s end do @@ -1379,37 +1215,34 @@ end subroutine tfabove diagv( n+4 ) = vegfrac( c,r ) ! 'Vegetation_Frac ' diagv( n+5 ) = uland( c,r,3 ) ! 'Urban_Cover ' diagv( n+6 ) = uland( c,r,4 ) ! 'Forest_Cover ' - diagv( n+7 ) = tfa ( c,r ) ! 'Trfac_Above_Can ' - diagv( n+8 ) = tfb ( c,r ) ! 'Trfac_Inside_Can' - n = n + 8 + n = n + 6 ! accum and coarse mode number density emissions - diagv( n+1 ) = dustoutn( 2,c,r ) - diagv( n+2 ) = dustoutn( 3,c,r ) + diagv( n+1 ) = dustoutn( 1,c,r ) + diagv( n+2 ) = dustoutn( 2,c,r ) ! accum and coarse mode surface area density emissions - diagv( n+3 ) = dustouts( 2,c,r ) - diagv( n+4 ) = dustouts( 3,c,r ) + diagv( n+3 ) = dustouts( 1,c,r ) + diagv( n+4 ) = dustouts( 2,c,r ) n = n + 4 m = 0 do v = 1, ndust_spc - if ( trim( dust_spc( v )%name( 2 ) ) .ne. ' ' ) then ! accum. mode mass emissions + if ( dust_spc( v )%spcfac( 1 ) .gt. 0. ) then ! accum. mode mass emissions m = m + 1 - diagv( m+n ) = dustoutm( v,2,c,r ) + diagv( m+n ) = dustoutm( v,c,r ) end if end do do v = 1, ndust_spc - if ( trim( dust_spc( v )%name( 3 ) ) .ne. ' ' ) then ! coarse mode mass emissions + if ( dust_spc( v )%spcfac( 2 ) .gt. 0. ) then ! coarse mode mass emissions m = m + 1 - diagv( m+n ) = dustoutm( v,3,c,r ) + diagv( m+n ) = dustoutm( v+ndust_spc,c,r ) end if end do n = n + m - C Multiply by sync step because when write to output we divide by the output step C to get a timestep average. do v = 1, ndust_diag @@ -1429,7 +1262,7 @@ end subroutine tfabove & dusthit, (c-1)*(r-1) #endif - if ( dustem_diag ) then + if ( dustem_diag .and. .not. l_desid_diag ) then C If last call this hour, write out the windblown dust emissions dignostics. C Then reset the emissions array and local write counter. @@ -1437,7 +1270,7 @@ end subroutine tfabove wstep = wstep + time2sec( tstep( 2 ) ) if ( wstep .ge. time2sec( tstep( 1 ) ) ) then - if ( .not. currstep( jdate, jtime, sdate, stime, tstep( 1 ), + if ( .not. currstep( jdate, jtime, stdate, sttime, tstep( 1 ), & mdate, mtime ) ) then xmsg = 'Cannot get step date and time' call m3exit( pname, jdate, jtime, xmsg, xstat3 ) @@ -1457,8 +1290,8 @@ end subroutine tfabove sdiagv = 0.0 ! array assignment #endif do v = 1, ndust_diag - do r = 1, my_nrows - do c = 1, my_ncols + do r = 1, nrows + do c = 1, ncols wrbuf( c,r ) = dustbf( v,c,r ) / float( wstep ) end do end do @@ -1491,7 +1324,7 @@ function dust_hflux( ndp, dp, soiltxt, fmoit, fruf, ustr, sd_ep, dens ) & result( hflux ) C usage: hflux = dust_flux( ndp, dp, -C soiltxt( j,: ), +C soiltxt2( : ), C fmoit( c,r ), C fruf( c,r,m ), C ustr( c,r,m ), @@ -1547,6 +1380,7 @@ function dust_hflux( ndp, dp, soiltxt, fmoit, fruf, ustr, sd_ep, dens ) end function dust_hflux + ! add a new function for fengsha (Wei Li) function dust_hflux_fengsha( ustar, fmoit, drag, uthr, ssm, dens ) & result( hflux ) @@ -1560,19 +1394,19 @@ function dust_hflux_fengsha( ustar, fmoit, drag, uthr, ssm, dens ) real u_sum real u_thresh real fac - + real, parameter :: amen = 1.0 ! Marticorena and Bergametti [JGR,1997] real, parameter :: cfac = 1000.0 * amen / grav fac = cfac * dens hflux = 0.0 - - rustar = ustar * drag + + rustar = ustar * drag u_thresh = uthr * fmoit u_sum = rustar * u_thresh hflux = max(0., rustar - u_thresh) * u_sum * u_sum * fac * ssm end function dust_hflux_fengsha - end module dust_emis + diff --git a/src/model/src/RUNTIME_VARS.F b/src/model/src/RUNTIME_VARS.F new file mode 100644 index 00000000..64e76e08 --- /dev/null +++ b/src/model/src/RUNTIME_VARS.F @@ -0,0 +1,1201 @@ + +!------------------------------------------------------------------------! +! The Community Multiscale Air Quality (CMAQ) system software is in ! +! continuous development by various groups and is based on information ! +! from these groups: Federal Government employees, contractors working ! +! within a United States Government contract, and non-Federal sources ! +! including research institutions. These groups give the Government ! +! permission to use, prepare derivative works of, and distribute copies ! +! of their work in the CMAQ system to the public and to permit others ! +! to do so. The United States Environmental Protection Agency ! +! therefore grants similar permission to use the CMAQ system software, ! +! but users are requested to provide copies of derivative works or ! +! products designed to operate in the CMAQ system to the United States ! +! Government without restrictions as to use by others. Software ! +! that is used with the CMAQ system but distributed under the GNU ! +! General Public License or the GNU Lesser General Public License is ! +! subject to their copyright restrictions. ! +!------------------------------------------------------------------------! + +!.................................................................... +! The RUNTIME_VARS module contains file unit identifiers for the log files, +! input files, and the values of all environment variables. +! +! It also contains routines for reading environment variables, and +! opening input files. +! +! History: +! 07/19/18, D. Wong: removed some of the ifdef clause for twoway model +! and added new logical environment variables +! ncd_64bit_offset and cell_num for MPAS coupling scheme +! 31 Jan 2019 (David Wong) +! -- removed all twoway related environment variables in this file +! 01 Feb 2019 (David Wong) +! -- implemented invocation of GET_ENV call directly, removed unnecessay +! interface block and unnecessary functions +! 02 May 2019 (David Wong) +! -- set BIOGEMIS_SEASON = .FALSE. as the default value +! 13 May 2019 (David Wong) +! -- setup environment variable ISAM_NEW_START +! 14 May 2019 (David Wong) +! -- updated environment variable ISAM_NEW_START with default value 'Y' +! 15 May 2019 (David Wong) +! -- included check for using marine gas emission or not +! 13 June 2019 (F. Sidi) +! -- Set the default for ERODE_AGLAND to FALSE. No longer supported feature +! in CMAQv5.3 +! 25 July 2019 (D. Wong) +! -- Included a logic to determine whether met data was created from +! WRF V4+ is used +! 01 Aug 2019 (D. Wong) +! -- Modified code to work with two-way model +! 07 Nov 2019 (D. Wong) +! -- Made RUNLEN environment variable avilable to two-way model as well +! 22 Nov 2019 (F. Sidi) +! -- Re-introduced master switch to overide emissions file date for +! representative day files +! 10 Feb 2020 (D. Wong) +! -- Added new environmental variable, MET_TSTEP, to enable +! running with temporally finer meteorology +! 10 Jun 2021 (G. Sarwar) +! -- Added 'CB6R5M' and deleted "CB6R3M" +! 4 Mar 2022 (G. Sarwar) +! -- Added 'CB6R5' +!.................................................................... + + MODULE RUNTIME_VARS + + use get_env_module + + IMPLICIT NONE + + SAVE + + PUBLIC + + INTEGER :: OUTDEV = 6 ! File Unit for Standard Output + INTEGER :: LOGDEV = -1 ! File Unit for Ascii Log File + INTEGER :: TOTPE = 1 ! Number of Total Processors + INTEGER :: NPROCS = 1 ! Number of Total Processors + INTEGER :: MYPE = -1 ! Processor Number + CHARACTER( 3 ) :: CMYPE = "" ! Processor Number + + !----------------------------------------------------------------------------------- + !>> Parameters for formatting output log files + !----------------------------------------------------------------------------------- + + INTEGER, PARAMETER :: CTM_DIAG_LVL = 0 + + INTEGER :: LOG_LINE_LENGTH = 80 ! Cut the log offs at this character if possible + INTEGER :: LOG_MAJOR_TAB = 5 ! Left tab for all text including headings + INTEGER :: LOG_MINOR_TAB = 2 ! Tab for indenting subsequent lines of text in + ! a paragraph for instance. + + CHARACTER( 10 ) :: WEEKDAY( 7 ) = (/'Monday ','Tuesday ','Wednesday', + & 'Thursday ','Friday ','Saturday ','Sunday ' /) + + +! this is for MPAS + LOGICAL :: ncd_64bit_offset = .FALSE. + INTEGER :: cell_num = 1 !(Wei Li; tested ) + !----------------------------------------------------------------------------------- + !>> Define Environment Variables for Controlling CMAQ Processes + !----------------------------------------------------------------------------------- + + ! Met model version + LOGICAL :: WRF_V4P = .FALSE. ! Indicator of whether WRF version is 4+ or not + + ! Convective scheme in met model + LOGICAL :: CONVECTIVE_SCHEME = .TRUE. + ! Flag for column model + LOGICAL :: COLUMN_MODEL = .FALSE. + + ! Grid and High-Level Model Parameters + LOGICAL :: NEW_START = .TRUE. ! Start New Simulation. Not a Restart + LOGICAL :: IGNORE_SOILINP = .FALSE. ! In case you don't have prev day + CHARACTER(300):: EXECUTION_ID = '' ! Execution ID + CHARACTER(16) :: GRID_NAME = '' ! grid name selected from GRIDDESC + CHARACTER(16) :: PROGNAME = 'DRIVER' ! Program name selected from GRIDDESC + INTEGER :: RUNLEN = 480000 ! Run Length + INTEGER :: STDATE = 1995192 ! Start Date + INTEGER :: STTIME = 000000 ! Start Time + INTEGER :: LOCAL_TSTEP = 010000 ! set to TSTEP( 1 ) in initscen.F + INTEGER :: MET_TSTEP ! set meterology input temporal frequency + INTEGER :: NPCOL = 1 ! no. of processors across grid columns + INTEGER :: NPROW = 1 ! no. of processors across grid rows + INTEGER :: MAXSYNC = 720 ! force max TSTEP(2) (sec) + INTEGER :: MINSYNC = 60 ! force min TSTEP(2) (sec) + + INTEGER, PARAMETER :: MAXLEN_CCTM_APPL = 200 ! Length of Logfile Names + CHARACTER( MAXLEN_CCTM_APPL ) :: APPL_NAME = 'APPL' ! Logfile Names + CHARACTER( MAXLEN_CCTM_APPL ) :: BLDFOLD = '' ! Build Directory + CHARACTER( MAXLEN_CCTM_APPL ) :: OUTDIR = '' ! Output Directory + + ! General; Multiprocess control, output and error checking + LOGICAL :: PRINT_PROC_TIME = .FALSE. ! Flag to print elapsed time for all + ! science submodules + LOGICAL :: FL_ERR_STOP=.TRUE. ! Flag to stop run if errors are found. + LOGICAL :: CKSUM = .TRUE. ! flag for cksum on, default = [T] + LOGICAL :: END_TIME = .FALSE. ! Override default beginning ACON timestamp + + INTEGER :: N_ACONC_VARS = 0 ! Number of species saved to avg conc file + INTEGER :: N_CONC_VARS = 0 ! Number of species saved to conc file + INTEGER :: ACONC_BLEV= 0 ! Beginning level saved to avg conc file + INTEGER :: ACONC_ELEV= 0 ! Ending level saved to avg conc file + INTEGER :: CONC_BLEV = 0 ! Beginning level saved to conc file + INTEGER :: CONC_ELEV = 0 ! Ending level saved to conc file + CHARACTER( 16 ) :: ACONC_FILE_SPCS( 900 ) = '' ! avg conc file species list + CHARACTER( 16 ) :: CONC_FILE_SPCS(900 ) = '' ! conc file species list + LOGICAL :: PWRTFLAG = .TRUE. ! Print confirmation of successful output + ! to logfile + LOGICAL :: LVEXT = .FALSE. ! Flag to perform vertical Extraction + CHARACTER( 1000 ) :: VEXT_COORD_PATH = "" ! File Path for Lon-Lat Text file specifying + ! locations for vertical extraction + + CHARACTER(256) :: GC_NAMELIST = '' ! Gas Species Namelist + CHARACTER(256) :: AE_NAMELIST = '' ! Aerosol Species Namelist + CHARACTER(256) :: NR_NAMELIST = '' ! Nonreactive Species Namelist + CHARACTER(256) :: TR_NAMELIST = '' ! Tracer Species Namelist + + ! Chemistry and Photolysis + LOGICAL :: PHOTDIAG = .FALSE. ! Flag for PHOTDIAG file + INTEGER :: NLAYS_DIAG = 0 ! Number of Diagnostic Layers to write out for photolysis + INTEGER :: NWAVE = 0 ! Number of Diagnostic Wavelengths + CHARACTER(16) :: WAVE_ENV(100) ! Targeted wavelengths for diagnostic output + LOGICAL :: CORE_SHELL= .FALSE. ! flag for using core-shell mixing model for aerosol optics + LOGICAL :: MIE_CALC = .FALSE. ! flag for using Mie Theory in aerosol optics calculation + REAL :: GEAR_ATOL = 1.0E-9 ! Absolute Tolerance for Gear Solver + REAL :: GEAR_RTOL = 1.0E-3 ! Relative Tolerance for Gear Solver + REAL :: GLBL_ATOL = 1.0E-7 ! Absolute Tolerance for Rosenbrock Solver + REAL :: GLBL_RTOL = 1.0E-3 ! Relative Tolerance for Rosenbrock Solver + + ! Aerosols + LOGICAL :: IC_AERO_M2WET=.FALSE.! flag for specifying wet aerosol size parameters + ! for initial conditions. FALSE = dry + LOGICAL :: BC_AERO_M2WET=.FALSE.! flag for specifying wet aerosol size parameters + ! for boundary conditions. FALSE = dry + LOGICAL :: IC_AERO_M2USE=.TRUE. ! flag for using the second moment from the input file + ! for initial conditions. TRUE = use input 2nd moment + LOGICAL :: BC_AERO_M2USE=.TRUE. ! flag for using the second moment from the input file + ! for boundary conditions.TRUE = use input 2nd moment + + ! Cloud Parameters + LOGICAL :: CLD_DIAG = .FALSE. ! flag to output cloud diagnostic files + + ! Air-Surface Exchange + LOGICAL :: ABFLUX = .FALSE. ! flag for ammonia bi-directional flux with in-lining depv + LOGICAL :: MOSAIC = .FALSE. ! flag for STAGE mosaic - output land use specific deposition and deposition velocity + LOGICAL :: SFC_HONO = .FALSE. ! flag for HONO interaction with surfaces + LOGICAL :: PX_LSM = .TRUE. ! flag for WRF PX land surface model + LOGICAL :: CLM_LSM = .FALSE. ! flag for WRF CLM land surface model + LOGICAL :: NOAH_LSM = .TRUE. ! flag for WRF NOAH land surface model + LOGICAL :: DEPV_DIAG = .FALSE. ! flag for grid cell deposition velocity diagnostic file + Logical :: HGBIDI = .FALSE. ! flag for Hg bidirectional exchange + Logical :: BIDI_FERT_NH3 = .TRUE. ! flag to remove fertilizer ammonia from Bidirectional emissions + Logical :: STAGE_E20 = .TRUE. ! flag for the Emerson et al. 2020 Aerosol deposition model PNAS https://www.pnas.org/cgi/doi/10.1073/pnas.2014761117 + Logical :: STAGE_P22 = .FALSE. ! flag for the Pleim et al. 2022 Aerosol deposition model + Logical :: STAGE_S22 = .FALSE. ! flag for the Shu et al. 2022 Aerosol deposition model + CHARACTER(16) :: DUST_LAND_SCHEME = "UNKNOWN" ! NLCD, USGS, etc + + + ! Transport Processes + LOGICAL :: VDIFFDIAG = .FALSE. ! flag for VDIFF diagnostic files + REAL :: SIGST = 0.7 ! sigma_sync_top value + REAL :: HDIV_LIM = 0.9 ! cutoff for max horizontal divergence step adj + REAL :: CFL = 0.75 ! maximum Courant-Friedrichs-Lewy number allowed + Logical :: MINKZ = .TRUE. ! flag for minimum Kz + LOGICAL :: W_VEL = .FALSE. ! flag for vertical velocity + LOGICAL :: GRAV_SETL = .TRUE. ! flag for aerosol gravitational setling + + + ! Emissions Processes + CHARACTER( MAXLEN_CCTM_APPL ) :: STAGECTRL = 'STAGECTRL_NML' ! STAGE Deposition Control Filename + CHARACTER( MAXLEN_CCTM_APPL ) :: MISC_CTRL = 'MISC_CTRL_NML' ! Emission Control Filename + CHARACTER( MAXLEN_CCTM_APPL ) :: DESID_CTRL = 'DESID_CTRL_NML' ! Emission Control Filename + CHARACTER( MAXLEN_CCTM_APPL ) :: DESID_CHEM_CTRL = 'DESID_CHEM_CTRL_NML' ! Emission Control Filename + INTEGER :: EMLAYS_MX = 0 ! Emission Layers + INTEGER :: N_FILE_GR = 0 ! Number of Gridded Emission Files + INTEGER :: N_FILE_TR = 0 ! NUmber of Tracer Emission Files + LOGICAL :: EMISCHK = .TRUE. ! flag for checking that surrogate emissions + ! are present on emission files + LOGICAL :: BIOGEMIS_BEIS = .FALSE. ! flag to in-line biogenic VOC emissions + LOGICAL :: BIOGEMIS_MEGAN= .FALSE. ! flag to in-line MEGAN biogenic emissions + LOGICAL :: USE_MEGAN_LAI = .FALSE. ! flag to use MEGAN LAI values + LOGICAL :: MGN_ONLN_DEP = .FALSE. ! flag to use ONLINE N deposition in BDSNP + LOGICAL :: BDSNP_MEGAN = .FALSE. ! flag to use BDSNP for soil NO + CHARACTER(16) :: SPPRO = 'DEFAULT' ! requested speciation profile name + LOGICAL :: BEMIS_DIAG = .TRUE. ! true: write diagnostic emiss file + LOGICAL :: MGEMDIAG = .FALSE. ! flag for MGEM diagnostic file + LOGICAL :: OCEAN_CHEM = .TRUE. ! Flag for ocean halogen chemistry and sea spray aerosol emissions + LOGICAL :: WB_DUST = .FALSE. ! flag for On-Line Dust Emission Calculation + LOGICAL :: DUSTEM_DIAG = .FALSE. ! flag for dustemis diagnostic file + LOGICAL :: SSEMDIAG = .FALSE. ! flag for SSEMIS diagnostic file + LOGICAL :: LTNG_NO = .FALSE. ! flag for online calculation of NO from lightning + INTEGER :: LT_ASM_DT = 0 ! Lightning Input Time Interval + LOGICAL :: NLDNSTRIKE = .FALSE. ! flag to use NLDN STRIKE directly + LOGICAL :: LTNGDIAG = .FALSE. ! flag to turn on lightning NO diagnostics + REAL :: MOLSNCG = 350.0 ! Lightning NO Production Rate + REAL :: MOLSNIC = 350.0 ! Lightning NO Production Rate + CHARACTER(250) :: LTNG_FNAME = 'InLine' ! Lightning NO Input Name + + INTEGER :: NPTGRPS = 0 ! no. pt src input file groups + LOGICAL :: PT3DDIAG = .FALSE. ! Write point source 3d emis diagnostic file + LOGICAL :: PT3DFRAC = .FALSE. ! Write layer fractions diagnostic file, if true + INTEGER :: PT_NSTEPS = 1 + INTEGER :: PT_DATE = 1995192 ! Julian start date (YYYYDDD) + INTEGER :: PT_TIME = 0 ! start time (HHMMSS) + INTEGER :: IPVERT = 0 ! Numerical flag for plume vertical spread method + INTEGER :: REP_LAYR = -1 ! Minimum layer for reporting srcs w/ high plumes + LOGICAL :: EMIS_SYM_DATE = .FALSE. ! Overrider CMAQ not to check + ! if the dates on the emissions file match that of + ! the interal model (representative day case) + CHARACTER( 16 ), SAVE, ALLOCATABLE :: PLAY_BASE( : ) ! Use for Plume Rise Calculation + + LOGICAL :: USE_MARINE_GAS_EMISSION = .FALSE. + + ! Process Analysis + LOGICAL :: PROCAN = .FALSE. ! flag for process analysis + INTEGER :: PA_BEGCOL = 0 ! Starting PA output + INTEGER :: PA_ENDCOL = 0 ! ending column for PA output + INTEGER :: PA_BEGROW = 0 ! Starting row for PA output + INTEGER :: PA_ENDROW = 0 ! ending row for PA output + INTEGER :: PA_BEGLEV = 0 ! Starting layer for PA output + INTEGER :: PA_ENDLEV = 0 ! ending layer for PA output + + ! Sulfur tracking + LOGICAL :: STM = .FALSE. ! flag for sulfur tracking option + LOGICAL :: ADJ_STMSPC = .TRUE. ! flag for normalizing sulfur tracking species + + ! ISAM + CHARACTER(1) :: ISAM_NEW_START = 'Y' ! Start New Simulation. Not a Restart for ISAM + INTEGER :: ISAM_BLEV = 0 ! Beginning level saved to conc file + INTEGER :: ISAM_ELEV = 0 ! Ending level saved to conc file + INTEGER :: SA_NLAYS = 0 ! Number of layers saved to conc file + INTEGER :: AISAM_BLEV = 0 ! Beginning level saved to sa_aconc file + INTEGER :: AISAM_ELEV = 0 ! Ending level saved to sa_aconc file + INTEGER :: AVGSA_LAYS = 0 ! Number of layers saved to conc file + INTEGER :: ISAM_CHEM_BIAS = 5 ! which chemistry are biased in apportioning reaction yields + ! to source reactant + ! 1 for none so divided equally between sources' reactant + ! 2 for all products apportioned to sources with NO, NO2, NO3, HONO, ANO3 + ! -equally if reactants are neither or both + ! 3 for all products apportioned to sources with Case 2 plus select OVOC species + ! and radicals + ! -equally if reactants are neither or both + ! 4 for all products apportioned to sources with select OVOC species + ! and radicals + ! -equally if reactants are neither or both + ! 5 to switch between Cases 2 and 3 based on whether + ! production H2O2 over production HNO3 less than VOC_NOX_TRANS + + REAL :: VOC_NOX_TRANS = 0.35 ! H2O2 to HNO3 marking transition from NOx to VOC limiting O3 production + INTEGER :: ISAM_NOX_CASE = 2 ! option of ISAM_CHEM_BIAS representing NOx limiting O3 production + INTEGER :: ISAM_VOC_CASE = 4 ! option of ISAM_CHEM_BIAS representing VOC limiting O3 production + + CONTAINS + +!......................................................................... + SUBROUTINE INIT_ENV_VARS( JDATE, JTIME ) + +! Defines and retrieves values for all environment variable input to +! CMAQ. +!......................................................................... + + USE RXNS_DATA, ONLY : MECHNAME + USE M3UTILIO + + IMPLICIT NONE + + INCLUDE SUBST_FILES_ID ! file name parameters + +#ifdef parallel + include 'mpif.h' +#endif + + INTEGER, INTENT( In ) :: JDATE + INTEGER, INTENT( In ) :: JTIME + CHARACTER( 16 ) :: V_LIST2( 20 ) + CHARACTER( 240 ) :: XMSG = '' + INTEGER :: NV + + + INTEGER :: STATUS ! ENV... status + CHARACTER( 400 ) :: STRTEMP + CHARACTER( 80 ) :: PBASE + INTEGER, PARAMETER :: EXIT_STATUS = 1 + INTEGER :: ERROR + INTEGER :: VARDEV = -1 + + LOGICAL :: FOUND + LOGICAL :: EFLAG = .FALSE. + INTEGER :: LOC, STR_LEN + CHARACTER(10) :: WRF_VERSION + + CHARACTER( 16 ) :: PNAME = 'RUNTIME_VARS' + + !------------------------------------------------------------------------------------------------------- + !>> Grid and High-Level Model Parameters + !------------------------------------------------------------------------------------------------------- +#ifdef parallel + CALL MPI_COMM_RANK ( MPI_COMM_WORLD, MYPE, ERROR ) + CALL MPI_COMM_SIZE ( MPI_COMM_WORLD, TOTPE, ERROR ) +#else + MYPE = 0 + TOTPE = 0 +#endif + + IF ( MYPE .EQ. 0 ) VARDEV = OUTDEV + + ! Get Simulation Scenario Name to Label Log Files, etc + CALL GET_ENV( APPL_NAME, 'CTM_APPL', APPL_NAME, VARDEV ) + + ! Start I/O-API and set up log file(s) + CALL SETUP_LOGDEV() + IF ( MYPE .EQ. 0 ) THEN + CALL LOG_HEADING( OUTDEV, "Environment Variable Report" ) + CALL LOG_SUBHEADING( OUTDEV, "Grid and High-Level Model Parameters" ) + WRITE( OUTDEV, '(6x,A)' ),'--Env Variable-- | --Value--' + WRITE( OUTDEV, '(6x,A)' ), REPEAT( '-',80 ) + END IF + + ! Get Logfile Directory + CALL GET_ENV ( BLDFOLD, 'BLD', BLDFOLD, VARDEV ) + + ! Get Logfile Directory + CALL GET_ENV ( OUTDIR, 'OUTDIR', OUTDIR, VARDEV ) + + ! Determine if this run is a new start or a restart + CALL GET_ENV ( NEW_START, 'NEW_START', NEW_START, VARDEV ) + + ! Determine if prev day soilinp is available for MEGAN + CALL GET_ENV ( IGNORE_SOILINP, 'IGNORE_SOILINP', IGNORE_SOILINP, VARDEV ) + + ! Get Execution ID + CALL GET_ENV ( STRTEMP, 'EXECUTION_ID', EXECUTION_ID, VARDEV ) + EXECUTION_ID = STRTEMP(1:300) + + ! Get Grid Name + CALL GET_ENV ( STRTEMP, 'GRID_NAME', GRID_NAME, VARDEV ) + GRID_NAME = STRTEMP(1:16) + + ! Output Time Step + CALL GET_ENV ( LOCAL_TSTEP, 'CTM_TSTEP', LOCAL_TSTEP, VARDEV ) + + ! Run Duration + CALL GET_ENV ( RUNLEN, 'CTM_RUNLEN', RUNLEN, VARDEV ) + +#ifndef twoway + ! Main Program Name + CALL GET_ENV ( STRTEMP, 'CTM_PROGNAME', PROGNAME, VARDEV ) + PROGNAME = STRTEMP( 1:16 ) + + ! Starting Date + CALL GET_ENV ( STDATE, 'CTM_STDATE', STDATE, VARDEV ) + + ! Starting Time + CALL GET_ENV ( STTIME, 'CTM_STTIME', STTIME, VARDEV ) + + ! Retrieve the domain decomposition processor array + IF ( NPROCS .GT. 1 ) THEN + CALL GET_ENV ( 'NPCOL_NPROW', NV, V_LIST2, VARDEV ) + IF ( NV .NE. 2 ) THEN + XMSG = 'Environment variable problem for NPCOL_NPROW' + & // ' using default 1X1' + CALL M3WARN ( 'INIT_ENV_VARS', 0, 0, XMSG ) + NV = 2 + V_LIST2( 1 ) = '1' + V_LIST2( 2 ) = '1' + END IF + READ( V_LIST2( 1 ), '( I4 )' ) NPCOL + READ( V_LIST2( 2 ), '( I4 )' ) NPROW + END IF + +#endif + + ! MAXSYNC + CALL GET_ENV ( MAXSYNC, 'CTM_MAXSYNC', MAXSYNC, VARDEV ) + + ! MINSYNC + CALL GET_ENV ( MINSYNC, 'CTM_MINSYNC', MINSYNC, VARDEV ) + + + !------------------------------------------------------------------------------------------------------- + !>> General; Multiprocess control, output and error checking + !------------------------------------------------------------------------------------------------------- + + IF ( MYPE .EQ. 0 ) THEN + CALL LOG_SUBHEADING( OUTDEV, "Multiprocess control, output and error checking" ) + WRITE( OUTDEV, '(6x,A)' ),'--Env Variable-- | --Value--' + WRITE( OUTDEV, '(6x,A)' ), REPEAT( '-',80 ) + END IF + + ! PRINT_PROC_TIME + CALL GET_ENV ( PRINT_PROC_TIME, 'PRINT_PROC_TIME', PRINT_PROC_TIME, VARDEV ) + + ! FL_ERR_STOP + CALL GET_ENV ( FL_ERR_STOP, 'FL_ERR_STOP', FL_ERR_STOP, VARDEV ) + + ! CKSUM + CALL GET_ENV ( CKSUM, 'CTM_CKSUM', CKSUM, VARDEV ) + + ! Override default beginning time timestamp for ACONC? + CALL GET_ENV ( END_TIME, 'AVG_FILE_ENDTIME', END_TIME, VARDEV ) + + ! ACONC File Species List + CALL GET_ENV ( 'AVG_CONC_SPCS', N_ACONC_VARS, ACONC_FILE_SPCS, VARDEV ) + + ! CONC File Species List + CALL GET_ENV ( 'CONC_SPCS', N_CONC_VARS, CONC_FILE_SPCS, VARDEV ) + + ! ACONC Layer Specification + CALL GET_ENV ( 'ACONC_BLEV_ELEV', NV, V_LIST2, VARDEV ) + IF ( NV .LE. 0 ) THEN ! assume 1:NLAYS + ACONC_BLEV = 1 + ACONC_ELEV = -1 + ELSE IF ( NV .EQ. 1 ) THEN ! Assume 1:CONC_BLEV_ELEV + ACONC_BLEV = 1 + READ( V_LIST2( 2 ), '( I4 )' ) ACONC_ELEV + ELSE IF ( NV .EQ. 2 ) THEN ! Correct Input + READ( V_LIST2( 1 ), '( I4 )' ) ACONC_BLEV + READ( V_LIST2( 2 ), '( I4 )' ) ACONC_ELEV + ELSE + XMSG = 'Environment variable error for ACONC_BLEV_ELEV' + CALL M3EXIT( 'INIT_ENV_VARS', JDATE, JTIME, XMSG, EXIT_STATUS ) + END IF + + ! CONC File Vertical Layer Range and Speciation + CALL GET_ENV ( 'CONC_BLEV_ELEV', NV, V_LIST2, VARDEV ) + IF ( NV .LE. 0 ) THEN ! assume 1:NLAYS + CONC_BLEV = 1 + CONC_ELEV = -1 + ELSE IF ( NV .EQ. 1 ) THEN ! Assume 1:CONC_BLEV_ELEV + CONC_BLEV = 1 + READ( V_LIST2( 2 ), '( I4 )' ) CONC_ELEV + ELSE IF ( NV .EQ. 2 ) THEN ! Correct Input + READ( V_LIST2( 1 ), '( I4 )' ) CONC_BLEV + READ( V_LIST2( 2 ), '( I4 )' ) CONC_ELEV + ELSE + XMSG = 'Environment variable error for CONC_BLEV_ELEV' + CALL M3EXIT( 'INIT_ENV_VARS', JDATE, JTIME, XMSG, EXIT_STATUS ) + END IF + + ! PWRTFLAG + CALL GET_ENV ( PWRTFLAG, 'IOAPI_LOG_WRITE', PWRTFLAG, VARDEV ) + + ! Get Flag for Vertical Extraction + CALL GET_ENV ( LVEXT, 'VERTEXT', LVEXT, VARDEV ) +#ifdef parallel + ! Get Filepath for File Specifying Lon-Lat Coordinates for + ! Vertical Extraction + CALL GET_ENV ( VEXT_COORD_PATH, 'VERTEXT_COORD_PATH', VEXT_COORD_PATH, VARDEV ) +#else + IF( LVEXT ) THEN + LVEXT = .FALSE. + WRITE( OUTDEV,'(A)')'Option to extract a Vertical Column of Ouptut Data set to YES' + WRITE( OUTDEV,'(A)')'However, the serial version cannot execute the option' + WRITE( LOGDEV,'(A)')'Option to extract a Vertical Column of Ouptut Data set to YES' + WRITE( LOGDEV,'(A)')'However, the serial version cannot execute the option' + END IF +#endif + + ! Get Filename for Gas Species Namelist + CALL GET_ENV ( GC_NAMELIST, 'gc_matrix_nml', GC_NAMELIST, VARDEV ) + + ! Get Filename for Aerosol Species Namelist + CALL GET_ENV ( AE_NAMELIST, 'ae_matrix_nml', AE_NAMELIST, VARDEV ) + + ! Get Filename for Nonreactive Species Namelist + CALL GET_ENV ( NR_NAMELIST, 'nr_matrix_nml', NR_NAMELIST, VARDEV ) + + ! Get Filename for Tracer Species Namelist + CALL GET_ENV ( TR_NAMELIST, 'tr_matrix_nml', TR_NAMELIST, VARDEV ) + +#ifdef isam + !------------------------------------------------------------------------------------------------------- + !>> ISAM + !------------------------------------------------------------------------------------------------------- + IF ( MYPE .EQ. 0 ) THEN + CALL LOG_SUBHEADING( OUTDEV, "ISAM setting and output options" ) + WRITE( OUTDEV, '(6x,A)' ),'--Env Variable-- | --Value--' + WRITE( OUTDEV, '(6x,A)' ), REPEAT( '-',80 ) + END IF + + + ! Determine if this ISAM run is a new start or a restart + CALL GET_ENV ( ISAM_NEW_START, 'ISAM_NEW_START', ISAM_NEW_START, VARDEV ) + + ! SA_ACONC Layer Specification + CALL GET_ENV ( 'AISAM_BLEV_ELEV', NV, V_LIST2, VARDEV ) + IF ( NV .LE. 0 ) THEN ! assume 1:NLAYS + AISAM_BLEV = 1 + AISAM_ELEV = -1 + ELSE IF ( NV .EQ. 1 ) THEN ! Assume 1:AISAM_BLEV_ELEV + AISAM_BLEV = 1 + READ( V_LIST2( 2 ), '( I4 )' ) AISAM_ELEV + ELSE IF ( NV .EQ. 2 ) THEN ! Correct Input + READ( V_LIST2( 1 ), '( I4 )' ) AISAM_BLEV + READ( V_LIST2( 2 ), '( I4 )' ) AISAM_ELEV + ELSE + XMSG = 'Environment variable error for AISAM_BLEV_ELEV' + CALL M3EXIT( 'INIT_ENV_VARS', JDATE, JTIME, XMSG, EXIT_STATUS ) + END IF + + ! SA_CONC File Vertical Layer Range and Speciation + CALL GET_ENV ( 'ISAM_BLEV_ELEV', NV, V_LIST2, VARDEV ) + IF ( NV .LE. 0 ) THEN ! assume 1:NLAYS + ISAM_BLEV = 1 + ISAM_ELEV = -1 + ELSE IF ( NV .EQ. 1 ) THEN ! Assume 1:ISAM_BLEV_ELEV + ISAM_BLEV = 1 + READ( V_LIST2( 2 ), '( I4 )' ) ISAM_ELEV + ELSE IF ( NV .EQ. 2 ) THEN ! Correct Input + READ( V_LIST2( 1 ), '( I4 )' ) ISAM_BLEV + READ( V_LIST2( 2 ), '( I4 )' ) ISAM_ELEV + ELSE + XMSG = 'Environment variable error for ISAM_BLEV_ELEV' + CALL M3EXIT( 'INIT_ENV_VARS', JDATE, JTIME, XMSG, EXIT_STATUS ) + END IF + + ! Get species bias case + CALL GET_ENV ( ISAM_CHEM_BIAS, 'ISAM_O3_WEIGHTS', ISAM_CHEM_BIAS, VARDEV ) + IF ( ISAM_CHEM_BIAS .LT. 1 .OR. ISAM_CHEM_BIAS .GT. 5 ) THEN + XMSG = 'ISAM_O3_WEIGHTS must equal 1 thru 5' + WRITE( OUTDEV, '(A)' )TRIM( XMSG ) + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + IF ( ISAM_CHEM_BIAS .EQ. 5 ) THEN + EFLAG = .FALSE. + ! VOC_NOX_TRANS value, ratio of H2O2 over HNO3 production rates or concentration + CALL GET_ENV ( VOC_NOX_TRANS, 'VOC_NOX_TRANS', VOC_NOX_TRANS, VARDEV ) + CALL GET_ENV ( ISAM_NOX_CASE, 'ISAM_NOX_CASE', ISAM_NOX_CASE, VARDEV ) + CALL GET_ENV ( ISAM_VOC_CASE, 'ISAM_VOC_CASE', ISAM_VOC_CASE, VARDEV ) + IF ( ISAM_NOX_CASE .LT. 1 .OR. ISAM_NOX_CASE .GT. 4 ) THEN + XMSG = 'ISAM_NOX_CASE must equal 1 thru 4' + WRITE( OUTDEV, '(A)' )TRIM( XMSG ) + EFLAG = .TRUE. + END IF + IF ( ISAM_VOC_CASE .LT. 1 .OR. ISAM_VOC_CASE .GT. 4 ) THEN + XMSG = 'ISAM_VOC_CASE must equal 1 thru 4' + WRITE( OUTDEV, '(A)' )TRIM( XMSG ) + EFLAG = .TRUE. + END IF + IF ( ISAM_VOC_CASE .EQ. ISAM_NOX_CASE ) THEN + XMSG = 'ISAM_VOC_CASE must NOT equal ISAM_NOX_CASE' + WRITE( OUTDEV, '(A)' )TRIM( XMSG ) + XMSG = 'Set ISAM_O3_WEIGHTS to their value.' + WRITE( OUTDEV, '(A)' )TRIM( XMSG ) + EFLAG = .TRUE. + END IF + IF ( EFLAG ) CALL M3EXIT ( PNAME, 0, 0, 'Found errors in ISAM options', XSTAT1 ) + END IF +#endif + + !------------------------------------------------------------------------------------------------------- + !>> Chemistry and Photolysis + !------------------------------------------------------------------------------------------------------- + + IF ( MYPE .EQ. 0 ) THEN + CALL LOG_SUBHEADING( OUTDEV, "Chemistry and Photolysis" ) + WRITE( OUTDEV, '(6x,A)' ),'--Env Variable-- | --Value--' + WRITE( OUTDEV, '(6x,A)' ), REPEAT( '-',80 ) + END IF + + ! Get photolysis rate diagnostic file flag + CALL GET_ENV ( PHOTDIAG, 'CTM_PHOTDIAG', PHOTDIAG, VARDEV ) + + IF( PHOTDIAG ) THEN + ! Get desired number of layers for PHOTDIAG2 and PHOTDIAG3 files + CALL GET_ENV ( NLAYS_DIAG, 'NLAYS_PHOTDIAG', NLAYS_DIAG, VARDEV ) + + ! Get Desired Wavelengths for Diagnostic Output + CALL GET_ENV( 'NWAVE_PHOTDIAG', NWAVE, WAVE_ENV, VARDEV ) + END IF + + ! Get flag to use core-shell mixing model for aerosol optical properties + CALL GET_ENV ( CORE_SHELL, 'CORE_SHELL_OPTICS', CORE_SHELL, VARDEV ) + + ! Get flag to use fast optics for volume mixing model for aerosol optical properties + CALL GET_ENV ( MIE_CALC, 'OPTICS_MIE_CALC', MIE_CALC, VARDEV ) + + !Absolute Tolerance for SMVGEAR + CALL GET_ENV ( GEAR_ATOL, 'GEAR_ATOL', GEAR_ATOL, VARDEV ) + + !Relative Tolerance for SMVGEAR + CALL GET_ENV ( GEAR_RTOL, 'GEAR_RTOL', GEAR_RTOL, VARDEV ) + + ! Tolerances for Rosenbrock Solver + CALL GET_ENV ( GLBL_RTOL, 'RB_RTOL', GLBL_RTOL, VARDEV ) + + ! Absolute Tolerance for RB Solver + CALL GET_ENV ( GLBL_ATOL, 'RB_ATOL', GLBL_ATOL, VARDEV ) + + !------------------------------------------------------------------------------------------------------- + !>> Aerosols + !------------------------------------------------------------------------------------------------------- + + IF ( MYPE .EQ. 0 ) THEN + CALL LOG_SUBHEADING( OUTDEV, "Aerosols" ) + WRITE( OUTDEV, '(6x,A)' ),'--Env Variable-- | --Value--' + WRITE( OUTDEV, '(6x,A)' ), REPEAT( '-',80 ) + END IF + + ! Get flag for interpreting initial condition aerosol size distributions as dry + CALL GET_ENV ( IC_AERO_M2WET, 'IC_AERO_M2WET', IC_AERO_M2WET, VARDEV ) + + ! Get flag for interpreting initial condition aerosol size distributions as dry + CALL GET_ENV ( BC_AERO_M2WET, 'BC_AERO_M2WET', BC_AERO_M2WET, VARDEV ) + + ! Get flag for using initial condition aerosol second moment + CALL GET_ENV ( IC_AERO_M2USE, 'IC_AERO_M2USE', IC_AERO_M2USE, VARDEV ) + + ! Get flag for using initial condition aerosol second moment + CALL GET_ENV ( BC_AERO_M2USE, 'BC_AERO_M2USE', BC_AERO_M2USE, VARDEV ) + + !------------------------------------------------------------------------------------------------------- + !>> sulfur tracking option + !------------------------------------------------------------------------------------------------------- + + ! Flag for sulfur tracking option + CALL GET_ENV ( STM, 'STM_SO4TRACK', STM, VARDEV ) + + IF ( STM ) THEN + ! Get sulfur tracking normalization flag + CALL GET_ENV ( ADJ_STMSPC, 'STM_ADJSO4', ADJ_STMSPC, VARDEV ) + END IF + + !------------------------------------------------------------------------------------------------------- + !>> Cloud Parameters + !------------------------------------------------------------------------------------------------------- + + IF ( MYPE .EQ. 0 ) THEN + CALL LOG_SUBHEADING( OUTDEV, "Cloud Processes" ) + WRITE( OUTDEV, '(6x,A)' ),'--Env Variable-- | --Value--' + WRITE( OUTDEV, '(6x,A)' ), REPEAT( '-',80 ) + END IF + + ! FLag for outputting cloud diagnostics + CALL GET_ENV ( CLD_DIAG, 'CLD_DIAG', CLD_DIAG, VARDEV ) + + !------------------------------------------------------------------------------------------------------- + !>> Air-Surface Exchange Parameters + !------------------------------------------------------------------------------------------------------- + + IF ( MYPE .EQ. 0 ) THEN + CALL LOG_SUBHEADING( OUTDEV, "Air-Surface Exchange Processes" ) + WRITE( OUTDEV, '(6x,A)' ),'--Env Variable-- | --Value--' + WRITE( OUTDEV, '(6x,A)' ), REPEAT( '-',80 ) + END IF + + ! Check if using PX version of MCIP + CALL GET_ENV ( PX_LSM, 'PX_VERSION', PX_LSM, VARDEV ) + + ! Flag for Ammonia bi-directional flux with in-line deposition + ! velocities calculation + CALL GET_ENV ( ABFLUX, 'CTM_ABFLUX', ABFLUX, VARDEV ) + + ! Flag for Mosaic method to get land-use specific deposition velocities + CALL GET_ENV ( MOSAIC, 'CTM_MOSAIC', MOSAIC, VARDEV ) + + ! Flag for HONO interaction with leaf and building surfaces + CALL GET_ENV ( SFC_HONO, 'CTM_SFC_HONO', SFC_HONO, VARDEV ) + + ! Flag CLM LSM + CALL GET_ENV ( CLM_LSM, 'CLM_VERSION', CLM_LSM, VARDEV ) + + ! Flag for NOAH LSM + CALL GET_ENV ( NOAH_LSM, 'NOAH_VERSION', NOAH_LSM, VARDEV ) + + ! CTM_DEPV_FILE + CALL GET_ENV ( DEPV_DIAG, 'CTM_DEPV_FILE', DEPV_DIAG, VARDEV ) + + ! CTM_HGBIDI + CALL GET_ENV ( HGBIDI, 'CTM_HGBIDI', HGBIDI, VARDEV ) + + ! CTM_IGNORE_FERT_NH3 + CALL GET_ENV ( BIDI_FERT_NH3, 'CTM_BIDI_FERT_NH3', BIDI_FERT_NH3, VARDEV ) + + ! Flag for using BELD Land Use for WindBlown Dust + CALL GET_ENV ( STRTEMP, 'CTM_WBDUST_BELD', DUST_LAND_SCHEME, VARDEV ) + DUST_LAND_SCHEME = STRTEMP( 1:16) + + ! Get Name of STAGE Control File + CALL GET_ENV ( STAGECTRL, 'STAGECTRL_NML', STAGECTRL, VARDEV ) + + ! Flag for Surface Tiled Aerosol and Gaseous Exchange (STAGE) model Pleim et al. 2022 Aerosol Deposition Option + CALL GET_ENV ( STAGE_P22, 'CTM_STAGE_P22', STAGE_P22, VARDEV ) + + ! Flag for Surface Tiled Aerosol and Gaseous Exchange (STAGE) model Emerson et al. 2020 Aerosol Deposition Option + CALL GET_ENV ( STAGE_E20, 'CTM_STAGE_E20', STAGE_E20, VARDEV ) + + ! Flag for Surface Tiled Aerosol and Gaseous Exchange (STAGE) model Shu et al. 2022 (CMAQ v5.3) Aerosol Deposition Option + CALL GET_ENV ( STAGE_S22, 'CTM_STAGE_S22', STAGE_S22, VARDEV ) + + !------------------------------------------------------------------------------------------------------- + !>> Transport Processes + !------------------------------------------------------------------------------------------------------- + + IF ( MYPE .EQ. 0 ) THEN + CALL LOG_SUBHEADING( OUTDEV, "Transport Processes" ) + WRITE( OUTDEV, '(6x,A)' ),'--Env Variable-- | --Value--' + WRITE( OUTDEV, '(6x,A)' ), REPEAT( '-',80 ) + END IF + + ! CTM_VDIFF_DIAG_FILE + CALL GET_ENV ( VDIFFDIAG, 'CTM_VDIFF_DIAG_FILE', VDIFFDIAG, VARDEV ) + + ! Get Minimum Layer for Advection Time Step Adjustment + CALL GET_ENV ( SIGST, 'SIGMA_SYNC_TOP', SIGST, VARDEV ) + + ! Get Maximum Horizontal Div Limit for Advection Adjustment + CALL GET_ENV ( HDIV_LIM, 'ADV_HDIV_LIM', HDIV_LIM, VARDEV ) + + ! CFL Criteria + CALL GET_ENV ( CFL, 'CTM_ADV_CFL', CFL, VARDEV ) + + ! CTM_KZMIN + CALL GET_ENV ( MINKZ, 'KZMIN', MINKZ, VARDEV ) + + ! CTM_WVEL + CALL GET_ENV ( W_VEL, 'CTM_WVEL', W_VEL, VARDEV ) + + ! CTM_GRAV_SETL + CALL GET_ENV ( GRAV_SETL, 'CTM_GRAV_SETL', GRAV_SETL, VARDEV ) + + !------------------------------------------------------------------------------------------------------- + !>> Emission Environment Variables + !------------------------------------------------------------------------------------------------------- + + IF ( MYPE .EQ. 0 ) THEN + CALL LOG_SUBHEADING( OUTDEV, "Emissions Parameters" ) + WRITE( OUTDEV, '(6x,A)' ),'--Env Variable-- | --Value--' + WRITE( OUTDEV, '(6x,A)' ), REPEAT( '-',80 ) + END IF + + ! Number of Layers for Emissions + CALL GET_ENV ( EMLAYS_MX, 'CTM_EMLAYS', EMLAYS_MX, VARDEV ) + + ! Get Name of Emission Control File + CALL GET_ENV ( MISC_CTRL, 'MISC_CTRL_NML', MISC_CTRL, VARDEV ) + CALL GET_ENV ( DESID_CTRL, 'DESID_CTRL_NML', DESID_CTRL, VARDEV ) + CALL GET_ENV ( DESID_CHEM_CTRL,'DESID_CHEM_CTRL_NML', DESID_CHEM_CTRL, VARDEV ) + + ! Get number of different Gridded File Emissions Streams + CALL GET_ENV ( N_FILE_GR, 'N_EMIS_GR', N_FILE_GR, VARDEV ) + + ! Get number of different Gridded File Emissions Streams + CALL GET_ENV ( N_FILE_TR, 'N_EMIS_TR', N_FILE_TR, VARDEV ) + + ! Flag for checking emissions surrogates against species actually + ! present on emissions files + CALL GET_ENV ( EMISCHK, 'CTM_EMISCHK', EMISCHK, VARDEV ) + + ! CTM_BIOGEMIS_BE + CALL GET_ENV ( BIOGEMIS_BEIS, 'CTM_BIOGEMIS_BE', BIOGEMIS_BEIS, VARDEV ) + + ! CTM_BIOGEMIS_MG + CALL GET_ENV(BIOGEMIS_MEGAN, 'CTM_BIOGEMIS_MG', BIOGEMIS_MEGAN,VARDEV ) + CALL GET_ENV(USE_MEGAN_LAI, 'USE_MEGAN_LAI',USE_MEGAN_LAI,VARDEV ) + CALL GET_ENV(MGN_ONLN_DEP, 'MGN_ONLN_DEP',MGN_ONLN_DEP,VARDEV ) + CALL GET_ENV(BDSNP_MEGAN, 'BDSNP_MEGAN',BDSNP_MEGAN,VARDEV ) + + ! Get the speciation profile to use + CALL GET_ENV ( SPPRO, 'BIOG_SPRO', SPPRO, VARDEV ) + + ! Biogenic Emission Diag File + CALL GET_ENV ( BEMIS_DIAG, 'B3GTS_DIAG', BEMIS_DIAG, VARDEV ) + + ! Get marine gas emission diagnostic output file flag. + CALL GET_ENV ( MGEMDIAG, 'CTM_MGEMDIAG', MGEMDIAG, VARDEV ) + + ! Flag for ocean halogen chemistry and sea spray aerosol emissions + CALL GET_ENV ( OCEAN_CHEM, 'CTM_OCEAN_CHEM', OCEAN_CHEM, VARDEV ) + + ! Flag for Online Calculation of Windblown dust emissions + CALL GET_ENV ( WB_DUST, 'CTM_WB_DUST', WB_DUST, VARDEV ) + + ! Get env var for diagnostic output + CALL GET_ENV ( DUSTEM_DIAG, 'CTM_DUSTEM_DIAG', DUSTEM_DIAG, VARDEV ) + + ! Get sea spray emission diagnostic output file flag. + CALL GET_ENV ( SSEMDIAG, 'CTM_SSEMDIAG', SSEMDIAG, VARDEV ) + + ! Set LTNG_NO to Y or T to turn on lightning NO production + CALL GET_ENV ( LTNG_NO, 'CTM_LTNG_NO', LTNG_NO, VARDEV ) + + ! Get Lightning Input Time Interval + CALL GET_ENV ( LT_ASM_DT, 'LTNG_ASSIM_DT', LT_ASM_DT, VARDEV ) + + ! Get Lightning NO File Name + CALL GET_ENV ( LTNG_FNAME, 'LTNGNO', LTNG_FNAME, VARDEV ) + + ! Flag for using NLDN data for Lightning Strikes + CALL GET_ENV ( NLDNSTRIKE, 'USE_NLDN', NLDNSTRIKE, VARDEV ) + + ! Flag for Outputing Lightning Diagnostic File + CALL GET_ENV ( LTNGDIAG, 'LTNGDIAG', LTNGDIAG, VARDEV ) + + ! Get Lightning NO Production Rate + CALL GET_ENV ( MOLSNCG, 'MOLSNCG', 350.0, VARDEV ) + + ! Get Lightning NO Production Rate + CALL GET_ENV ( MOLSNIC, 'MOLSNIC', 350.0, VARDEV ) + + ! get number of different file groups (sectors) + CALL GET_ENV ( NPTGRPS, 'N_EMIS_PT', NPTGRPS, VARDEV ) + + ! PT3DDIAG +! CALL GET_ENV ( PT3DDIAG, 'PT3DDIAG', PT3DDIAG, VARDEV ) + + ! PT3DFRAC +! CALL GET_ENV ( PT3DFRAC, 'PT3DFRAC', PT3DFRAC, VARDEV ) + + ! Point Source Time Steps +! CALL GET_ENV ( PT_NSTEPS, 'LAYP_NSTEPS', PT_NSTEPS, VARDEV ) + + ! Point Source Date +! CALL GET_ENV ( PT_DATE, 'LAYP_STDATE', PT_DATE, VARDEV ) + + ! Point Source Time +! CALL GET_ENV ( PT_TIME, 'LAYP_STTIME', PT_TIME, VARDEV ) + + ! IPVERT + CALL GET_ENV ( IPVERT, 'IPVERT', IPVERT, VARDEV ) + + ! REP_LAYR +! CALL GET_ENV ( REP_LAYR, 'REP_LAYER_MIN', REP_LAYR, VARDEV ) + +! ALLOCATE( PLAY_BASE( NPTGRPS ) ) +! PLAY_BASE( : ) = '' +! DO NV = 1,NPTGRPS +! WRITE( PBASE,'( "PLAY_BASE", "_", I2.2 )' ) NV +! CALL GET_ENV ( STRTEMP, PBASE, PLAY_BASE( NV ), VARDEV ) +! PLAY_BASE( NV ) = STRTEMP +! END DO + + ! Determine user-defined default for emissions date override for representative days + CALL GET_ENV ( EMIS_SYM_DATE, 'EMIS_SYM_DATE', EMIS_SYM_DATE, VARDEV ) + + !------------------------------------------------------------------------------------------------------- + !>> Process Analysis + !------------------------------------------------------------------------------------------------------- + + IF ( MYPE .EQ. 0 ) THEN + CALL LOG_SUBHEADING( OUTDEV, "Process Analysis Parameters" ) + WRITE( OUTDEV, '(6x,A)' ),'--Env Variable-- | --Value--' + WRITE( OUTDEV, '(6x,A)' ), REPEAT( '-',80 ) + END IF + + ! Flag for Using Process Analysis + CALL GET_ENV ( PROCAN, 'CTM_PROCAN', PROCAN, VARDEV ) + + ! Get the Beginning and Ending Columns for Process Analysis + CALL GET_ENV ( 'PA_BCOL_ECOL', NV, V_LIST2, VARDEV ) + IF ( NV .LE. 0 ) THEN + PA_BEGCOL = 1; PA_ENDCOL = 0 + ELSE IF ( NV .EQ. 2 ) THEN + READ( V_LIST2( 1 ), '( I4 )' ) PA_BEGCOL + READ( V_LIST2( 2 ), '( I4 )' ) PA_ENDCOL + ELSE + XMSG = 'Environment variable error for PA_BCOL_ECOL' + CALL M3EXIT( 'INIT_ENV_VARS', JDATE, JTIME, XMSG, EXIT_STATUS ) + END IF + + ! Get the Beginning and Ending Rows for Process Analysis + CALL GET_ENV ( 'PA_BROW_EROW', NV, V_LIST2, VARDEV ) + IF ( NV .LE. 0 ) THEN + PA_BEGROW = 1; PA_ENDROW = 0 + ELSE IF ( NV .EQ. 2 ) THEN + READ( V_LIST2( 1 ), '( I4 )' ) PA_BEGROW + READ( V_LIST2( 2 ), '( I4 )' ) PA_ENDROW + ELSE + XMSG = 'Environment variable error for PA_BROW_EROW' + CALL M3EXIT( 'INIT_ENV_VARS', JDATE, JTIME, XMSG, EXIT_STATUS ) + END IF + + ! Get the Beginning and Ending Layers for Process Analysis + CALL GET_ENV ( 'PA_BLEV_ELEV', NV, V_LIST2, VARDEV ) + IF ( NV .LE. 0 ) THEN + PA_BEGLEV = 1; PA_ENDLEV = 0 + ELSE IF ( NV .EQ. 2 ) THEN + READ( V_LIST2( 1 ), '( I4 )' ) PA_BEGLEV + READ( V_LIST2( 2 ), '( I4 )' ) PA_ENDLEV + ELSE + XMSG = 'Environment variable error for PA_BLEV_ELEV' + CALL M3EXIT( 'INIT_ENV_VARS', JDATE, JTIME, XMSG, EXIT_STATUS ) + END IF + + IF ( OCEAN_CHEM ) THEN + IF ( (INDEX( MECHNAME, 'CB6R5M_AE7_AQ') .GT. 0 ) .OR. + & (INDEX( MECHNAME, 'CB6R5_AE7_AQ' ) .GT. 0) ) then + USE_MARINE_GAS_EMISSION = .TRUE. + ENDIF + ENDIF + +! for MPAS +#ifdef mpas + call get_env (ncd_64bit_offset, 'ncd_64bit_offset', .false., vardev) + call get_env( cell_num, 'cell_num', 1, vardev) +#endif + +#ifdef twoway + WRF_V4P = .TRUE. +#else +! to obtain WRF version information + IF ( .NOT. OPEN3( MET_CRO_3D, FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open '// MET_CRO_3D // ' file' + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + IF ( .NOT. DESC3( MET_CRO_3D ) ) THEN + XMSG = 'Could not get ' // MET_CRO_3D //' file description' + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + ! Get environ. variable met_tstep to control meteorology frequency + CALL GET_ENV ( MET_TSTEP, 'MET_TSTEP', TSTEP3D, VARDEV) + + ! Ensure users cannot pick a met_tstep that is not smaller than the + ! file time step and something that is not a multiple of that tstep + + IF (MOD(TIME2SEC(MET_TSTEP), TIME2SEC(TSTEP3D)) .NE. 0) then + XMSG = 'MET_TSTEP environmental variable not equal to or a + & multiple greater than time step of met file ' // MET_CRO_3D + CALL M3EXIT(PNAME, 0, 0, XMSG, XSTAT1) + end if + + FOUND = .FALSE. + NV = 0 + Do WHILE ((.NOT. FOUND) .AND. (NV .LT. MXDESC3)) + NV = NV + 1 + LOC = INDEX (FDESC3D(NV), 'WRF ARW V') + IF (LOC > 0) THEN + FOUND = .TRUE. + STR_LEN = LEN_TRIM(FDESC3D(NV)) + READ (FDESC3D(NV)(LOC+9:STR_LEN), *) WRF_VERSION + IF (WRF_VERSION .GE. '4.1') THEN + WRF_V4P = .TRUE. + END IF + END IF + END DO + + XMSG = 'MET data determined based on WRF ARW version ' + IF( MYPE .EQ. 0 ) THEN + WRITE(OUTDEV,'(/,5X,2(A,1X),/)')TRIM( XMSG ), TRIM( FDESC3D(NV)(LOC+9:STR_LEN) ) + WRITE(LOGDEV,'(/,5X,2(A,1X),/)')TRIM( XMSG ), TRIM( FDESC3D(NV)(LOC+9:STR_LEN) ) + ELSE + WRITE(LOGDEV,'(/,5X,2(A,1X),/)')TRIM( XMSG ), TRIM( FDESC3D(NV)(LOC+9:STR_LEN) ) + END IF + + IF ( .NOT. CLOSE3( MET_CRO_3D ) ) THEN + XMSG = 'Could not close ' // MET_CRO_3D + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF +#endif + + END SUBROUTINE INIT_ENV_VARS + +!......................................................................... + SUBROUTINE LOG_HEADING( FUNIT, CHEAD_IN ) + +! Formats and writes a user-supplied heading to a specific log file. +! This approach is intended to standardize the log files that are +! created by CMAQ. The length of the input array is set at 80 because +! we would like to try limiting lines to 80 characters and a heading +! should probably just be one line. +!......................................................................... + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: FUNIT + CHARACTER( * ), INTENT( IN ) :: CHEAD_IN + CHARACTER( len=: ), ALLOCATABLE :: CHEAD + CHARACTER( 20 ) :: FMT + CHARACTER( 20 ) :: FMT2 + INTEGER :: LDASH + + ! Capitalize the heading + CHEAD = CHEAD_IN + CALL UPCASE( CHEAD ) + + ! Write the heading to the log file + WRITE( FUNIT, * ) + WRITE( FMT, '("(", I0, "x,A,A,A)")' ) LOG_MAJOR_TAB + WRITE( FMT2,'("(", I0, "x,A,)")' ) LOG_MAJOR_TAB + + LDASH = 2*8 + LEN_TRIM( CHEAD ) + WRITE( FUNIT, FMT2 ), REPEAT( '=', LDASH ) + WRITE( FUNIT, FMT ), + & '|>--- ',TRIM( CHEAD ),' ---<|' + WRITE( FUNIT, FMT2 ), REPEAT( '=', LDASH ) + + END SUBROUTINE LOG_HEADING + +!......................................................................... + SUBROUTINE LOG_SUBHEADING( FUNIT, CHEAD ) + +! Formats and writes a user-supplied sub-heading to a specific log file. +! This approach is intended to standardize the log files that are +! created by CMAQ. The length of the input array is set at 80 because +! we would like to try limiting lines to 80 characters and a sub-heading +! should probably just be one line. +!......................................................................... + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: FUNIT + CHARACTER( * ), INTENT( IN ) :: CHEAD + CHARACTER( 20 ) :: FMT + INTEGER :: LDASH + + ! Write the sub-heading to the log file + WRITE( FMT, '("(/,", I0, "x,A,A,A)")' ) LOG_MAJOR_TAB + WRITE( FUNIT, FMT ),'|> ',TRIM( CHEAD ),':' + LDASH = 2*3 - 1 + LEN_TRIM( CHEAD ) + + WRITE( FMT, '("(", I0, "x,A,A)")' ) LOG_MAJOR_TAB + WRITE( FUNIT, FMT ) '+',REPEAT( '=', LDASH ) + + END SUBROUTINE LOG_SUBHEADING + +!......................................................................... + SUBROUTINE LOG_MESSAGE( FUNIT, CMSG_IN ) + +! Formats and writes a user-supplied message to a specific log file. +! This approach is intended to standardize the log files that are +! created by CMAQ. +!......................................................................... + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: FUNIT + CHARACTER( * ), INTENT( IN ) :: CMSG_IN + CHARACTER( len=: ), ALLOCATABLE :: CMSG + CHARACTER( 20 ) :: FMT + + CHARACTER( LOG_LINE_LENGTH ) :: CTEMP + INTEGER :: MSG_SIZE + INTEGER :: NLINE1, NLINE2, NLINE, NTAB, LAST_SPACE + + CMSG = CMSG_IN + + ! Write the message to the log file, while trimming to 80 + ! characters (while accounting for tab-length) + NLINE1 = LOG_LINE_LENGTH - LOG_MAJOR_TAB + NLINE2 = LOG_LINE_LENGTH - LOG_MAJOR_TAB - LOG_MINOR_TAB + NLINE = NLINE1 + NTAB = LOG_MAJOR_TAB + + ! Determine Length of Total Message + MSG_SIZE = LEN_TRIM( CMSG ) + + DO WHILE ( MSG_SIZE .GT. LOG_LINE_LENGTH ) + ! Isolate One Line of Text + LAST_SPACE = INDEX( CMSG( 1:NLINE+1 ), " ", BACK=.TRUE. ) + + CTEMP = CMSG( 1:LAST_SPACE-1 ) + + WRITE( FMT, '("(", I0, "x,A)")' ) NTAB + WRITE( FUNIT, FMT ), CTEMP + + CMSG = CMSG( LAST_SPACE+1:LEN( CMSG ) ) + MSG_SIZE = LEN_TRIM( CMSG ) + + IF ( NTAB .EQ. LOG_MAJOR_TAB ) NTAB = NTAB + LOG_MINOR_TAB + IF ( NLINE.EQ. NLINE1 ) NLINE = NLINE2 + END DO + + ! Write Last Line + WRITE( FMT, '("(", I0, "x,A)")' ) NTAB + WRITE( FUNIT, FMT ), TRIM( CMSG ) + + + END SUBROUTINE LOG_MESSAGE + +!......................................................................... + SUBROUTINE TIMING_SPLIT( CPU_TIME_START, IMSG, CPROCIN ) + +! This subroutine provides a split for the MPI timing functions and +! then prints out a message for how much time has passed using a +! character string input for customizing that message. +!......................................................................... + + IMPLICIT NONE + +#ifdef parallel + INCLUDE 'mpif.h' +#endif + REAL( 8 ) :: CPU_TIME_START + REAL( 8 ) :: CPU_TIME_FINISH + INTEGER :: IMSG ! What kind of checkpoint this is + ! 1 = 'PROCESS' + ! 2 = 'MASTER TIME STEP' + ! 3 = 'OUTPUT' + CHARACTER( * ), INTENT(IN), OPTIONAL :: CPROCIN + CHARACTER( len=: ), ALLOCATABLE :: CPROC + CHARACTER( 250 ) :: XMSG + +#ifndef parallel + REAL :: REAL_TIME +#endif + + + IF ( PRESENT( CPROCIN ) ) THEN + CPROC = CPROCIN + ELSE + CPROC = ' ' + END IF + + ! Record Time at this Checkpoint +#ifdef parallel + CPU_TIME_FINISH = MPI_WTIME() +#else + CALL CPU_TIME( REAL_TIME ) + CPU_TIME_FINISH = REAL( REAL_TIME,8 ) +#endif + + + ! Assemble the statement requested by the calling program + SELECT CASE ( IMSG ) + CASE ( 1 ) + ! Write Out The Time to Complete Each Sub-Process + WRITE( XMSG, 1002 ),TRIM( CPROC ), CPU_TIME_FINISH-CPU_TIME_START +1002 FORMAT ( 2x, A15, ' completed... ', F12.4, ' seconds' ) + + CASE ( 2 ) + ! Write out the time to complete the entire master time step + WRITE( XMSG, '(7x,A16)' ),'Master Time Step' + CALL LOG_MESSAGE( LOGDEV, XMSG ) +#ifndef twoway + IF ( MYPE .EQ. 0 ) CALL LOG_MESSAGE( OUTDEV, XMSG ) +#endif + WRITE( XMSG, '(7x,A24,F12.4,A8)' ),'Processing completed... ', + & (CPU_TIME_FINISH-CPU_TIME_START),' seconds' + CALL LOG_MESSAGE( LOGDEV, XMSG ) + WRITE( LOGDEV, * ) + + CASE ( 3 ) + ! Write out the time to complete the output procedure + WRITE( XMSG, '(1x,A32,F10.4,A)' ), '=--> Data Output completed... ', + & (CPU_TIME_FINISH-CPU_TIME_START),' seconds' + CALL LOG_MESSAGE( LOGDEV, XMSG ) + WRITE( LOGDEV, * ) +#ifndef twoway + IF ( MYPE .EQ. 0 ) WRITE( OUTDEV, * ) +#endif + + END SELECT + + ! Write out the timing statement +#ifndef twoway + IF ( MYPE .EQ. 0 ) CALL LOG_MESSAGE( OUTDEV, XMSG ) +#endif +#ifdef parallel + CPU_TIME_START = MPI_WTIME() +#else + CALL CPU_TIME( REAL_TIME ) + CPU_TIME_START = REAL( REAL_TIME,8 ) +#endif + END SUBROUTINE TIMING_SPLIT + + END MODULE RUNTIME_VARS diff --git a/src/model/src/centralized_io_module.F b/src/model/src/centralized_io_module.F new file mode 100644 index 00000000..e2f0ebda --- /dev/null +++ b/src/model/src/centralized_io_module.F @@ -0,0 +1,6987 @@ +!------------------------------------------------------------------------! +! The Community Multiscale Air Quality (CMAQ) system software is in ! +! continuous development by various groups and is based on information ! +! from these groups: Federal Government employees, contractors working ! +! within a United States Government contract, and non-Federal sources ! +! including research institutions. These groups give the Government ! +! permission to use, prepare derivative works of, and distribute copies ! +! of their work in the CMAQ system to the public and to permit others ! +! to do so. The United States Environmental Protection Agency ! +! therefore grants similar permission to use the CMAQ system software, ! +! but users are requested to provide copies of derivative works or ! +! products designed to operate in the CMAQ system to the United States ! +! Government without restrictions as to use by others. Software ! +! that is used with the CMAQ system but distributed under the GNU ! +! General Public License or the GNU Lesser General Public License is ! +! subject to their copyright restrictions. ! +!------------------------------------------------------------------------! + +!------------------------------------------------------------------------! +! This module contains essential data structure and functions for +! centralized I/O implementation + +! Revision History: +! 02/01/19, D. Wong: initial implementation +! 02/11/19, D. Wong: Updated to accommodate STAGE option +! 03/06/19, D. Wong: fixed a bug to handle 3D emission data structure +! correctly and fixed a bug to deal with the case of +! ABFLUX turned off +! 04/01/19, D. Wong: -- enhanced robustness to handle time independent or +! dependent boundary condition file +! -- used two different CPP flags, m3dry_opt and stage_opt +! to distinguish these two deposition options +! -- reorganized the code to read in certain files when +! they are available as well as based on environmental +! variable setting +! 05/02/19, D. Wong: -- added a logic to call soilinp_setup when BIOGEMIS is true +! 05/03/19, D. Wong: -- reorganized the flow of reading in LUS data +! 05/06/19, D. Wong: -- added a new logic to read in INIT_MEDC_1 when it is not NEW_START +! 05/07/19, D. Wong: -- removed duplicated array allocation for NH4ps1 and NH4ps2 +! 05/13/19, D. Wong: -- expanded implementation to hanndle ISAM model +! 05/15/19, D. Wong: -- used USE_MARINE_GAS_EMISSION variable defined in RUNTIME_VAR.F +! to turn on a block of code related to marine gas emssion +! 06/18/19, D. Wong: -- modified cio implementation to handle: +! * emission file date is differ from simulation date +! * region files for scaling purposes +! 06/19/19, D. Wong: -- fixed a bug in the EMIS regions subroutine +! 07/08/19, F. Sidi: -- Renamed E2C_FERT -> E2C_CHEM & BELD4_LU -> E2C_LU +! 07/09/19, T. Spero: -- Changed file for fractional land use from +! GRIDCRO2D to LUFRAC_CRO. Allow backward +! compatibility. +! 07/17/19, R. Gilliam:- Removed the FPAR file call for windblow dust. MCIP VEG is used. +! 08/12/19, F. Sidi: -- Allowed lus_setup to use fractional land use from +! GRIDCRO2D or LUFRAC_CRO. Allows backward compatibility. +! 08/01/19, D. Wong:- Made modification so centralized I/O works with two-way model +! - used new variable type descriptor +! 09/10/19, D. Wong:- Extended to handle BC file with non 1-hr time step +! 09/19/19, D. Wong:- Used the start simulation time to pick up the very first emission +! data point rather than the start time in the emission file +! 09/20/19, D. Wong:- Extended the capability to handle 3D emission files with various +! number of layers less than of equal to the model number of layers +! 10/04/19, D. Wong:- fixed the time advancement, NEXTIME, for a multi-day run +! 11/22/19, F. Sidi:- Updated cio with new algorithm (developed by D. Wong) +! to enable running CMAQ with different files having +! different time steps, cleaned up code no longer needed +! & two-way model bugfixes +! 01/30/20, D. Wong:- fixed IC file interpolation time stamp issue by bypassing the +! check whether the new request falls within the circular buffer +! for IC variable which only has one time step of data. +! 02/10/20, F. Sidi:- Changed file_tstep from tstep3d to met_tstep an environment +! variable the flexlible allows users to toggle the temporal +! frequency of their input meterology. +! 03/05/20, D. Wong: Expanded CIO functionalities to MPAS as well +! 07/24/20, D. Wong: Fixed a bug, the code did not handle calling NEXTIME properly in +! an extreme case, i.e. simulation runs in a hourly basis, in the +! retrieve_boundary_data subroutine. +! 08/06/20, D. Wong:- fixed excessive reading of time independent boundary file data +! 02/23/21, D. Wong:- used KZMIN setting to determine reading in PURB or not +! 03/23/21. D. Wong:- modified code to accommodate a flexibility to allow each input +! can have different XORIG and YORIG settings than the simulation +! domain if it can be overlapped with the simulation domain +! perfectly w.r.t. domain resolution +! 11/17/21, G. Sarwar: Changed minimum values from 0.0 to 0.001 for ocean and szone +! to ensure values are nonnegative and greater than 0.001 +! 01/17/22, D. Wong: Added SAVE attribute to variable FIRSTIME +! 03/31/22, J. Willison: Removed wb_dust_setup and modified lus_setup to remove +! BELD as an option for desert land information. +! 04/12/22, G. Sarwar: Revised to include "DMS" into cb6r5_ae7_aq +!------------------------------------------------------------------------! + +!------------------------------------------------------------------------! +! Variable type notation: +! 'mc2' denote met cro 2d variable +! 'mc3' denote 3d variable +! 'md3' denote dot variable +! 'wb' denote wind blown dust +! 'ic' denote initial condition variable +! 'is' denote ISAM initial condition variable +! 'e2d' denote emission 2d variable +! 'e3d' denote emission 3d variable +! 'lnt' denote lightning variable +! 'mb' denote met 3D boundary variable +! 'bct' denote time dependent 3D boundary variable +! 'bc' denote time independent 3D boundary variable +!------------------------------------------------------------------------! + + MODULE CENTRALIZED_IO_MODULE + + use RUNTIME_VARS, only : LTNG_NO, STDATE, STTIME, ABFLUX, MOSAIC, + & NPTGRPS, USE_MARINE_GAS_EMISSION, logdev, + & CONVECTIVE_SCHEME, EMIS_SYM_DATE + use CENTRALIZED_IO_UTIL_MODULE + use get_env_module + USE UTILIO_DEFN +#ifdef mpas +! use coupler_module !(Wei Li) +! use mio_module !(Wei Li) +#endif + + implicit none + + integer, parameter :: max_nfiles = 500 + + character (20), parameter :: biogemis_fname = 'BEIS_NORM_EMIS' + +! to recognize the time step in each file could be different, in the new revised +! implementation will address that and here is the algorithm. When open a new file, +! n_opened_file will be incremented by one to keep track of how many have been +! opened. Each file has a unique f_name except met files which will be shared with +! one f_met since their tsteps should be the same. Then n_opened_file is assigned +! to an opened time dependent file (defined below) and time information will be +! stored accordingly. + + integer :: n_opened_file = 0 + integer :: f_met, f_ltng, f_bcon, f_icon, f_is_icon,f_mbiog + integer, allocatable :: f_emis(:), f_stk_emis(:) + + integer :: file_sdate(max_nfiles) = -1 + integer :: file_stime(max_nfiles) = -1 + integer :: file_tstep(max_nfiles) = -1 + real*8 :: file_xcell(max_nfiles) = 0.0d0 + real*8 :: file_ycell(max_nfiles) = 0.0d0 + logical :: file_sym_date(max_nfiles) + + CHARACTER( 40 ), parameter :: NLDN_STRIKES = 'NLDN_STRIKES' + CHARACTER( 40 ), parameter :: ICFILE = 'INIT_CONC_1' + CHARACTER( 40 ), parameter :: BCFILE = 'BNDY_CONC_1' + CHARACTER( 40 ), parameter :: ISAM_PREVDAY = 'ISAM_PREVDAY' + +! time independent data + real, allocatable :: MSFX2(:,:), ! from GRID_CRO_2D data + & LWMASK(:,:), ! from GRID_CRO_2D data + & HT(:,:), ! from GRID_CRO_2D data + & LAT(:,:), ! from GRID_CRO_2D data + & LON(:,:), ! from GRID_CRO_2D data + & PURB(:,:), ! from GRID_CRO_2D data + & LUFRAC(:,:,:), ! from LUFRAC_CRO data + & SOILCAT_A(:,:), ! from MET_CRO_2D + & MSFD2(:,:), ! from GRID_DOT_2D data + & X3HT0M(:,:), ! from GRID_CRO_3D data + & X3HT0F(:,:), ! from GRID_CRO_3D data + & ocean(:,:), ! from OCEAN data + & szone(:,:), ! from OCEAN data + & chlr(:,:), ! from OCEAN data + & dmsl(:,:), ! from OCEAN data + & OCEAN_MASK(:,:), ! from LTNG parameter data + & SLOPE(:,:), ! from LTNG parameter data + & INTERCEPT(:,:), ! from LTNG parameter data + & SLOPE_lg(:,:), ! from LTNG parameter data + & INTERCEPT_lg(:,:), ! from LTNG parameter data + & ICCG_SUM(:,:), ! from LTNG parameter data + & ICCG_WIN(:,:), ! from LTNG parameter data + & AVGEMIS(:,:,:,:), ! from BIOGEMIS data + & GROWAGNO(:,:), ! from BEIS_NORM_EMIS data + & NGROWAGNO(:,:), ! from BEIS_NORM_EMIS data + & NONAGNO(:,:), ! from BEIS_NORM_EMIS data + & RAINFALL(:,:,:), ! from SOILINP data + & HRNO_SW(:,:,:), ! from SOILINP data + & HRNO_T2M(:,:,:), ! from SOILINP data + & LDF(:,:,:), ! from MEGANMAP data + & LAI_M(:,:,:), ! from MEGANMAP data + & EFMAPS(:,:,:), ! from MEGANMAP data + & CTF(:,:,:), ! from MEGANMAP data + & BDSNP_NDEP(:,:,:), ! from MEGAN_BDSNP data + & BDSNP_FERT(:,:), ! from MEGAN_BDSNP data + & DRYPERIOD(:,:), ! from BDSNPINP data + & NDEPRES(:,:), ! from BDSNPINP data + & NDEPRATE(:,:), ! from BDSNPINP data + & PFACTOR(:,:), ! from BDSNPINP data + & SOILMPREV(:,:), ! from BDSNPINP data + & T24y(:,:), ! from MEGAN_SOILINP data + & SW24y(:,:), ! from MEGAN_SOILINP data + & lai_y(:,:) ! from MEGAN_SOILINP data + + + integer, allocatable :: PTYPE(:,:), ! from SOILINP data + & PULSEDATE(:,:), ! from SOILINP data + & PULSETIME(:,:), ! from SOILINP data + & BDSNP_LANDTYPE(:,:),! from MEGAN_BDSNP data + & BDSNP_ARID(:,:), ! from MEGAN_BDSNP data + & BDSNP_NONARID(:,:) ! from MEGAN_BDSNP data + + character( 16 ), allocatable :: DDTTM( : ) ! for SOILINP data, description date and time + +! time dependent data: +! gridded + integer :: n_grid_cro_data_vars + integer :: n_cio_grid_vars + real, allocatable :: cio_grid_data(:) + character (24), allocatable :: cio_grid_var_name(:,:) ! stores variable name, variable type and met variable + ! or not information for each variable + integer, allocatable :: cio_grid_data_inx (:,:,:), + & head_grid(:), tail_grid(:), ! head and tail of the gridded data circular buffer + & cio_grid_data_tstamp(:,:,:) + + character (16) :: cio_dust_land_scheme + character (20), allocatable :: cio_mpas_grid_data_tstamp(:,:) + +! boundary data + integer :: n_cio_bndy_vars, n_cio_bc_file_vars + real, allocatable :: cio_bndy_data(:) + character (16), allocatable :: cio_bndy_var_name(:,:), cio_bc_file_var_name(:) + integer, allocatable :: cio_bndy_data_inx (:,:,:), + & head_bndy(:), tail_bndy(:), ! head and tail of the boundary data circular buffer + & cio_bndy_data_tstamp(:,:,:) + +! emission data +! - gridded emission data + character (16), allocatable :: cio_emis_file_name(:), + & cio_emis_var_name(:,:) + integer, allocatable :: cio_emis_file_loc(:) + integer, allocatable :: cio_emis_nvars(:) + integer, allocatable :: cio_emis_file_layer(:) + integer, allocatable :: cio_emis_file_startcol(:) + integer, allocatable :: cio_emis_file_endcol(:) + integer, allocatable :: cio_emis_file_startrow(:) + integer, allocatable :: cio_emis_file_endrow(:) + integer :: cio_emis_nlays ! max value among cio_emis_file_layer + +! this is for MPAS only + integer, allocatable :: num_dist_layers(:,:) ! number of layers in MPAS grid has re-distributed emission data + real, allocatable :: dist_frac(:,:,:) ! calculated layer distribution fraction + real, allocatable :: emis_file_layer_frac(:,:) ! given layer faction information + integer :: mpas_tstep ! this is assigned in CMAQ_DRIVER + +! - stack emission data + real, allocatable :: cio_stack_data(:) + character (16), allocatable :: cio_stack_file_name(:), + & cio_stack_var_name(:,:), + & STKGNAME( : ), ! stack groups file name + & cio_mpas_stack_emis_timestamp(:) ! for MPAS only + + integer, allocatable :: n_cio_stack_emis_vars(:), + & cio_stack_file_loc(:), + & n_cio_stack_emis_lays(:), + & n_cio_stack_emis_pts(:), + & cio_stack_emis_data_inx (:,:,:,:), + & head_stack_emis(:,:), tail_stack_emis(:,:), ! head and tail of the stack emis data circular buffer + & cio_stack_emis_data_tstamp(:,:,:,:) + + integer :: modis_data_sdate ! modis dust data start date + + integer :: cio_model_sdate, + & cio_model_stime ! model start date and time + + logical, private :: cio_LTNG_NO + + real :: CONVPA ! Pressure conversion factor file units to Pa + Real :: P0 ! reference pressure (100000.0 Pa) for Potential Temperature, + ! note that in meteorology they do not use the SI 1 ATM. + +! availability of various variable + logical :: CFRAC_3D_AVAIL = .true., ! CFRAC_3D is available or not + & PV_AVAIL = .false., ! Potential Vorticity is available or not + & TSEASFC_AVAIL = .false., ! SST is available or not + & WSPD10_AVAIL, ! WSPD10 is available or not + & UWINDC_AVAIL, ! UWINDC is available in DOT file or not + & VWINDC_AVAIL, ! VWINDC is available in DOT file or not + & QG_AVAIL = .true., ! flag for QG available in MET_CRO_3D + & QI_AVAIL, ! flag for QI available in MET_CRO_3D + & QS_AVAIL, ! flag for QS available in MET_CRO_3D + & QC_AVAIL = .true., ! flag for QC and it is always set to .true. + & JACOBF_AVAIL, ! flag for JACOBF available in MET_CRO_3D + & RNA_AVAIL = .false., ! flag for RNA available in MET_CRO_2D + & RCA_AVAIL = .false., ! flag for RCA available in MET_CRO_2D + & RA_RS_AVAIL = .true., ! flag for RA and RS available in MET_CRO_2D + & Q2_AVAIL = .true., ! flag for Q2, two meter mixing ratio available in MET_CRO_2D + & LH_AVAIL, ! flag for LH, two meter mixing ratio available in MET_CRO_2D + & HAS_SEAICE, ! flag for SEAICE in MET_CRO_2D + & WR_AVAIL = .true., ! flag for WR, canopy wetness available in MET_CRO_2D + & MEDC_AVAIL = .true., ! file INIT_MEDC_1 is available + & E2C_CHEM_AVAIL = .true., ! file E2C_CHEM is available + & GMN_AVAIL = .false., ! variable GMN available in E2C_CHEM or not + & LUCRO_AVAIL, ! file LUFRAC_CRO is available + & PXSOIL_AVAIL ! flag for WRFv4.1+ PX LSM soil extras in MET_CRO_2D + +! Met data is large enough to cover boundary and no MET_BDY_3D will be used + logical :: window + + logical :: east_pe, south_pe, west_pe, north_pe + + INTEGER :: TEMPG_LOC + INTEGER :: TSEASFC_LOC + + integer :: STRTCOLSTD, ENDCOLSTD, STRTROWSTD, ENDROWSTD, ! this is for standard domain useful for coupled model + & STRTCOLMC2, ENDCOLMC2, STRTROWMC2, ENDROWMC2, + & STRTCOLMC2x, ENDCOLMC2x, STRTROWMC2x, ENDROWMC2x, ! extension setup for READMC2 + & STRTCOLMC3, ENDCOLMC3, STRTROWMC3, ENDROWMC3, + & STRTCOLMD3, ENDCOLMD3, STRTROWMD3, ENDROWMD3, + & STRTCOLMD3x, ENDCOLMD3x, STRTROWMD3x, ENDROWMD3x, ! extension setup for READMD3 + & STRTCOLIC, ENDCOLIC, STRTROWIC, ENDROWIC, ! for ICFILE + & STRTCOLISIC, ENDCOLISIC, STRTROWISIC, ENDROWISIC, ! for ISAM ICFILE + & STRTCOLLNT, ENDCOLLNT, STRTROWLNT, ENDROWLNT ! for lightning strike file + + private :: gridded_files_setup, + & retrieve_lufrac_cro_data +#ifdef mpas +! & ,retrieve_ocean_data_mpas +#else + & ,boundary_files_setup, + & retrieve_grid_cro_2d_data, + & retrieve_grid_dot_2d_data, + & retrieve_ocean_data +#endif + + integer, private :: count = 0 + integer, private :: cio_logdev, + & size_s2d, ! standard 2d cro file size (in twoway model, size_s2d not equal to size_c2d + & size_s3d, ! standard 3d file size + & n_c2d, size_c2d, ! cro 2d file info: # of variables and a variable size + & size_c2dx, ! extended cro 2d variable size + & size_d2d, ! a 2d dot variable size + & size_d2dx, ! extended 2d dot variable spatial size + & n_c3d, size_c3d, ! cro 3d file info: # of variables and a variable size + & n_d3d, size_d3d, ! dot 3d file info: # of variables and a variable size + & size_d3dx, ! extended dot 3d variable size + & n_i3d, ! # of initial condition 3d variables + & n_is3d, ! # of initial condition 3d variables for ISAM + & n_e2d, ! # of 2d emission variables + & n_e3d, size_e3d, ! # of 3d emission variables and a variable size + & n_mb3d, ! # of 3d met boundary variables + & n_b3d, ! # of 3d boundary variables + & size_b3d, ! a 3d boundary variable size + & size_b2d, ! a 2d boundary variable size + & n_l2d, ! # of lightning strikes file variables + & size_lt ! lightning file variable size + + integer, private :: cro_ncols, cro_nrows, ! cro file nools and nrows + & w_cro_ncols, w_cro_nrows, ! window cro file nools and nrows + & x_cro_ncols, x_cro_nrows, ! extended cro file nools and nrows + & s_cro_ncols, s_cro_nrows, ! standard cro file nools and nrows (this is used to distinguish + ! met cro and regular cro file in twoway coupled model + & dot_ncols, dot_nrows, ! dot file nools and nrows + & x_dot_ncols, x_dot_nrows ! extended dot file nools and nrows + + integer, private :: cio_LTLYRS ! number of layers in lightning strike dataset + CHARACTER( 16 ) :: LT_NAME ! LNT name: old Cis NLDNstrk and new is LNT + + interface interpolate_var +!#ifdef mpas +! module procedure r_interpolate_var_1ds, +! & r_interpolate_var_2d, +! & i_interpolate_var_2d, +! & r_interpolate_var_3d +!#else + module procedure r_interpolate_var_1ds, ! Interpolation for Stack Group Real 1-D Data + & r_interpolate_var_2d, ! Interpolation for generic Real 2-D Data + & i_interpolate_var_2d, ! Interpolation for generic Integer 2-D Data + & r_interpolate_var_2db, ! Interpolation for Boundary Real 2-D Data + & r_interpolate_var_3d ! Interpolation for generic Real 3-D Data +!#endif + end interface + +! MPAS only routines: + +! stack_files_setup_mpas +! retrieve_stack_data_mpas +! retrieve_ocean_data_mpas + +! r_interpolate_var_1d ? +! r_interpolate_var_1ds +! r_interpolate_var_2d +! i_interpolate_var_2d +! r_interpolate_var_2dx ? +! r_interpolate_var_3d + +! Non MPAS routines: + +! boundary_files_setup +! stack_files_setup +! biogemis_setup +! beis_norm_emis_setup +! depv_data_setup +! medc_file_setup +! soilinp_setup +! retrieve_grid_cro_2d_data +! retrieve_grid_dot_2d_data +! retrieve_ocean_data +! retrieve_ltng_param_data +! retrieve_boundary_data +! retrieve_stack_data + +! r_interpolate_var_1ds +! r_interpolate_var_2d +! i_interpolate_var_2d +! r_interpolate_var_2db +! r_interpolate_var_3d + +! Common routines: + +! gridded_files_setup +! retrieve_time_dep_gridded_data +! retrieve_lufrac_cro_data +! lus_setup +! centralized_io_init +! INIT_EMIS_REGIONS +! DESID_READ_NAMELIST + + contains + +! ------------------------------------------------------------------------- + subroutine gridded_files_setup + + USE UTILIO_DEFN + use HGRD_DEFN, only : ncols, nrows, mype, colsx_pe, rowsx_pe + USE VGRD_DEFN, only : VGTYP_GD, nlays + USE RUNTIME_VARS, only : N_FILE_GR, BIOGEMIS_BEIS, + & STDATE, WB_DUST, ISAM_NEW_START, + & local_tstep, met_tstep, NLDNSTRIKE + use LSM_Mod, only : LAND_SCHEME + use cgrid_spcs, only : n_gc_spcd, n_ae_spc +!#ifdef mpas (Wei Li) +! use centralized_io_util_module, only : ext_layer_info, cal_distribution , +! & binary_search, quicksort, +! & mpas_date_time_to_julian +! use util_module, only : secsdiff, sec2time, index1 +!#endif + + INCLUDE SUBST_FILES_ID ! file name parameters + + Character( 40 ), parameter :: pname = 'gridded_files_setup' + + CHARACTER( 120 ) :: XMSG = ' ' + INTEGER :: GXOFF, GYOFF, stat, n, v, d_size, begin, end, adj, + & n_dust_vars, idx, t, ldate, ltime, + & nl, s, e, c, time, floc + character( 32 ) :: tname, fname + + character( 24 ), allocatable :: c2d_name(:, :), c3d_name(:, :), + & d3d_name(:,:), emis_name(:,:), + & i3d_name(:,:), is3d_name(:,:), + & l2d_name(:,:), medc_name(:,:) + logical :: done = .false. + logical :: found + + integer, allocatable :: bottom(:), top(:) + integer :: emis_file_dist_layer, tdate(2), ttime(2), diffsec + + logical :: layer_exist + +#ifdef mpas +! n_c2d = 0 +! n_c3d = 0 +! n_d3d = 0 +! size_d3dx = 1 +! +! if (binary_search( 'LH', vname_2d, n2d_data) .gt. 0) then +! lh_avail = .true. +! else +! lh_avail = .false. +! end if +! +! n_opened_file = n_opened_file + 1 +! f_met = n_opened_file +! file_tstep(f_met) = mpas_tstep +! +! wspd10_avail = .true. +#else +! met grid cro 2d file + IF ( .NOT. OPEN3( GRID_CRO_2D, FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open '// GRID_CRO_2D // ' file' + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + IF ( .NOT. DESC3( GRID_CRO_2D ) ) THEN + XMSG = 'Could not get ' // GRID_CRO_2D //' file description' + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + n_grid_cro_data_vars = nvars3d + + LAND_SCHEME = 'UNKNOWN' + + v = 0 + DO WHILE ((v .LT. NVARS3D) .and. (.not. done)) + v = v + 1 + IF ( VNAME3D( v ) .EQ. 'DLUSE' ) THEN + IF ( INDEX( VDESC3D( v ), 'USGS24' ) .NE. 0 ) THEN + LAND_SCHEME = 'USGS24' + cio_dust_land_scheme = 'USGS24' + ELSE IF ( INDEX( VDESC3D( v ), 'NLCD40' ) .NE. 0 ) THEN + LAND_SCHEME = 'NLCD40' + cio_dust_land_scheme = 'NLCD40' + ELSE IF ( INDEX( VDESC3D( v ), 'NLCD50' ) .NE. 0 ) THEN + LAND_SCHEME = 'NLCD50' + cio_dust_land_scheme = 'NLCD50' + ELSE IF ( INDEX( VDESC3D( v ), 'NLCD-MODIS' ) .NE. 0 ) THEN + LAND_SCHEME = 'NLCD50' + cio_dust_land_scheme = 'NLCD-MODIS' + ELSE IF ( INDEX( VDESC3D( v ), 'MODIS' ) .NE. 0 ) THEN + LAND_SCHEME = 'MODIS' + IF ( INDEX( VDESC3D( v ), 'MODIS NOAH' ) .ne. 0) THEN + cio_dust_land_scheme = 'MODIS_NOAH' + ELSE + cio_dust_land_scheme = 'MODIS' + END IF + END IF + done = .true. + END IF + END DO + + IF ( .NOT. OPEN3( GRID_DOT_2D, FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open '// GRID_DOT_2D // ' file' + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + +! lufrac cro file + IF ( .NOT. OPEN3( LUFRAC_CRO, FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open '// LUFRAC_CRO // ' file' + CALL M3WARN ( PNAME, 0, 0, XMSG ) + LUCRO_AVAIL = .FALSE. + XMSG = 'Solution: Reading Land Use Fractions from GRID_CRO_2D file' + WRITE(LOGDEV,'(5X,A)')TRIM( XMSG ) + ELSE + n_opened_file = n_opened_file + 1 + LUCRO_AVAIL = .TRUE. + IF ( .NOT. DESC3( LUFRAC_CRO ) ) THEN + XMSG = 'Could not get ' // LUFRAC_CRO //' file description' + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + END IF + +! met cro 2d file + IF ( .NOT. OPEN3( MET_CRO_2D, FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open '// MET_CRO_2D // ' file' + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + n_opened_file = n_opened_file + 1 + f_met = n_opened_file + IF ( .NOT. DESC3( MET_CRO_2D ) ) THEN + XMSG = 'Could not get ' // MET_CRO_2D //' file description' + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + file_sdate(f_met) = sdate3d + file_stime(f_met) = stime3d +#ifdef twoway + file_tstep(f_met) = tstep3d +#else + file_tstep(f_met) = met_tstep ! offline model controlled by runtime var MET_TSTEP +#endif + file_xcell(f_met) = xcell3d + file_ycell(f_met) = ycell3d + + IF (INDEX1( 'TSEASFC', NVARS3D, VNAME3D ) .gt. 0) then + TSEASFC_AVAIL = .true. + adj = 0 + else + TSEASFC_AVAIL = .false. + adj = 1 + end if + + HAS_SEAICE = (INDEX1( 'SEAICE', NVARS3D, VNAME3D ) .gt. 0) + +! include an additional variable TSEASFC when MET_CRO_2D does not have it and CMAQ code is looking for it + n_c2d = nvars3d + adj + allocate (c2d_name(n_c2d, 3), stat=stat) + if (stat .ne. 0) then + xmsg = 'Failure allocating c2d_name ' + call m3exit (pname, 0, 0, xmsg, xstat1 ) + end if + +! only met data has 'm' distinction and since twoway model does not provide +! boundary data, so this distinction only apply to non boundary met data + + c2d_name(1:nvars3d,1) = vname3d(1:nvars3d) + c2d_name(:,2) = 'mc2' ! denote 2d variable + c2d_name(:,3) = 'm' ! denote met variable + if (adj .eq. 1) then + c2d_name(n_c2d,1) = 'TSEASFC' + end if + + WSPD10_AVAIL = (INDEX1( 'WSPD10', NVARS3D, VNAME3D ) .gt. 0) + RNA_AVAIL = (INDEX1( 'RNA', NVARS3D, VNAME3D ) .gt. 0) + RCA_AVAIL = (INDEX1( 'RCA', NVARS3D, VNAME3D ) .gt. 0) + RA_RS_AVAIL = (INDEX1( 'RA', NVARS3D, VNAME3D ) .gt. 0) + WR_AVAIL = (INDEX1( 'WR', NVARS3D, VNAME3D ) .gt. 0) + Q2_AVAIL = (INDEX1( 'Q2', NVARS3D, VNAME3D ) .gt. 0) + LH_AVAIL = (INDEX1( 'LH', NVARS3D, VNAME3D ) .gt. 0) + PXSOIL_AVAIL = (INDEX1( 'CLAY_PX', NVARS3D, VNAME3D ) .gt. 0) + + CALL SUBHFILE ( MET_CRO_2D, GXOFF, GYOFF, + & STRTCOLMC2, ENDCOLMC2, STRTROWMC2, ENDROWMC2 ) + +#ifdef twoway + STRTCOLMC2x = STRTCOLMC2 + STRTROWMC2x = STRTROWMC2 + ENDCOLMC2x = ENDCOLMC2 + ENDROWMC2x = ENDROWMC2 +#else + STRTCOLMC2x = STRTCOLMC2 + STRTROWMC2x = STRTROWMC2 + if (north_pe .and. east_pe) then + ENDCOLMC2x = ENDCOLMC2 + ENDROWMC2x = ENDROWMC2 + else if (north_pe) then + ENDCOLMC2x = ENDCOLMC2 + 1 + ENDROWMC2x = ENDROWMC2 + else if (east_pe) then + ENDCOLMC2x = ENDCOLMC2 + ENDROWMC2x = ENDROWMC2 + 1 + else + ENDROWMC2x = ENDROWMC2 + 1 + ENDCOLMC2x = ENDCOLMC2 + 1 + end if +#endif + +! met cro 3d file + IF ( .NOT. OPEN3( MET_CRO_3D, FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open '// MET_CRO_3D // ' file' + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + IF ( .NOT. DESC3( MET_CRO_3D ) ) THEN + XMSG = 'Could not get ' // MET_CRO_3D //' file description' + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + n_c3d = nvars3d + allocate (c3d_name(n_c3d, 3), stat=stat) + if (stat .ne. 0) then + xmsg = 'Failure allocating c3d_name ' + call m3exit (pname, 0, 0, xmsg, xstat1 ) + end if + c3d_name(:,1) = vname3d(1:n_c3d) + c3d_name(:,2) = 'mc3' ! denote 3d variable + c3d_name(:,3) = 'm' ! denote met variable + + CFRAC_3D_AVAIL = (INDEX1( 'CFRAC_3D', NVARS3D, VNAME3D ) .gt. 0) + PV_AVAIL = (INDEX1( 'PV', NVARS3D, VNAME3D ) .gt. 0) + QI_AVAIL = (INDEX1( 'QI', NVARS3D, VNAME3D ) .gt. 0) + QS_AVAIL = (INDEX1( 'QS', NVARS3D, VNAME3D ) .gt. 0) + QG_AVAIL = (INDEX1( 'QG', NVARS3D, VNAME3D ) .gt. 0) + JACOBF_AVAIL = (INDEX1( 'JACOBF', NVARS3D, VNAME3D ) .gt. 0) + QC_AVAIL = .true. + + CALL SUBHFILE ( MET_CRO_3D, GXOFF, GYOFF, + & STRTCOLMC3, ENDCOLMC3, STRTROWMC3, ENDROWMC3 ) + + IF ( (ENDCOLMC3 - STRTCOLMC3 + 1) .NE. NCOLS .OR. + & (ENDROWMC3 - STRTROWMC3 + 1) .NE. NROWS ) THEN + WRITE( XMSG,'( A, 4I8 )' ) 'Local Columns or Rows incorrect', + & (ENDCOLMC3 - STRTCOLMC3 + 1), NCOLS, (ENDROWMC3 - STRTROWMC3 + 1), NROWS + CALL M3EXIT ( PNAME, cio_model_sdate, cio_model_stime, XMSG, XSTAT1 ) + END IF + +#ifdef twoway + window = .TRUE. + + STRTCOLMC3 = STRTCOLMC3 - 1 + ENDCOLMC3 = ENDCOLMC3 + 1 + STRTROWMC3 = STRTROWMC3 - 1 + ENDROWMC3 = ENDROWMC3 + 1 + w_cro_ncols = ENDCOLMC3 - STRTCOLMC3 + 1 + w_cro_nrows = ENDROWMC3 - STRTROWMC3 + 1 + +#else + IF ( GXOFF .NE. 0 .AND. GYOFF .NE. 0 ) THEN + window = .TRUE. ! windowing from file + STRTCOLMC3 = STRTCOLMC3 - 1 + ENDCOLMC3 = ENDCOLMC3 + 1 + STRTROWMC3 = STRTROWMC3 - 1 + ENDROWMC3 = ENDROWMC3 + 1 + w_cro_ncols = ENDCOLMC3 - STRTCOLMC3 + 1 + w_cro_nrows = ENDROWMC3 - STRTROWMC3 + 1 + ELSE + window = .FALSE. + w_cro_ncols = -1 + w_cro_nrows = -1 + if (.not. east_pe) then + ENDCOLMC3 = ENDCOLMC3 + 1 + end if + if (.not. north_pe) then + ENDROWMC3 = ENDROWMC3 + 1 + end if + END IF +#endif + + V = INDEX1( 'PRES', NVARS3D, VNAME3D ) + If ( V .eq. 0 ) Then + XMSG = 'Could not get variable PRES from ' // MET_CRO_3D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + End If + + Select Case (UNITS3D( V )) + Case ( 'PASCAL','pascal','Pascal','PA','pa','Pa' ) + CONVPA = 1.0 + P0 = 100000.0 + Case ( 'MILLIBAR','millibar','Millibar','MB','mb','Mb' ) + CONVPA = 1.0E-02 + P0 = 100000.0 * CONVPA + Case ( 'CENTIBAR','centibar','Centibar','CB','cb','Cb' ) + CONVPA = 1.0E-03 + P0 = 100000.0 * CONVPA + Case Default + XMSG = 'PRES units incorrect on ' // MET_CRO_3D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + End Select + +! met dot 3d file + IF ( .NOT. OPEN3( MET_DOT_3D, FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open '// MET_DOT_3D // ' file' + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + IF ( .NOT. DESC3( MET_DOT_3D ) ) THEN + XMSG = 'Could not get description of file '// MET_DOT_3D + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + n_d3d = nvars3d + allocate (d3d_name(n_d3d, 3), stat=stat) + if (stat .ne. 0) then + xmsg = 'Failure allocating d3d_name ' + call m3exit (pname, 0, 0, xmsg, xstat1 ) + end if + d3d_name(:,1) = vname3d(1:n_d3d) + d3d_name(:,2) = 'md3' ! denote dot variable + d3d_name(:,3) = 'm' ! denote met variable + + CALL SUBHFILE ( MET_DOT_3D, GXOFF, GYOFF, + & STRTCOLMD3, ENDCOLMD3, STRTROWMD3, ENDROWMD3 ) + +#ifdef twoway + STRTCOLMD3x = STRTCOLMD3 + STRTROWMD3x = STRTROWMD3 + ENDROWMD3x = ENDROWMD3 + ENDCOLMD3x = ENDCOLMD3 +#else + STRTCOLMD3x = STRTCOLMD3 + STRTROWMD3x = STRTROWMD3 + if (north_pe .and. east_pe) then + ENDCOLMD3x = ENDCOLMD3 + ENDROWMD3x = ENDROWMD3 + else if (north_pe) then + ENDCOLMD3x = ENDCOLMD3 + 1 + ENDROWMD3x = ENDROWMD3 + else if (east_pe) then + ENDCOLMD3x = ENDCOLMD3 + ENDROWMD3x = ENDROWMD3 + 1 + else + ENDROWMD3x = ENDROWMD3 + 1 + ENDCOLMD3x = ENDCOLMD3 + 1 + end if +#endif + + dot_ncols = ENDCOLMD3 - STRTCOLMD3 + 1 + dot_nrows = ENDROWMD3 - STRTROWMD3 + 1 + size_d3d = dot_ncols * dot_nrows * nlays + + x_dot_ncols = ENDCOLMD3x - STRTCOLMD3x + 1 + x_dot_nrows = ENDROWMD3x - STRTROWMD3x + 1 + size_d2dx = x_dot_ncols * x_dot_nrows + size_d3dx = size_d2dx * nlays + + UWINDC_AVAIL = (INDEX1( 'UWINDC', NVARS3D, VNAME3D ) .gt. 0) + VWINDC_AVAIL = (INDEX1( 'VWINDC', NVARS3D, VNAME3D ) .gt. 0) +#endif + +! emission file, could be one or multiple layer + + call desid_read_namelist() + call desid_init_regions() + + allocate (cio_emis_file_name(N_FILE_GR), + & cio_emis_file_loc(N_FILE_GR), + & cio_emis_nvars(N_FILE_GR), + & f_emis(N_FILE_GR), +#ifndef mpas +! & cio_emis_file_startcol(N_FILE_GR), +! & cio_emis_file_endcol(N_FILE_GR), +! & cio_emis_file_startrow(N_FILE_GR), +! & cio_emis_file_endrow(N_FILE_GR), +#endif + & stat=stat) + +#ifdef mpas +! allocate (num_dist_layers(ncols, n_file_gr), +! & dist_frac(nlays, ncols, n_file_gr), +! & bottom(nlays), +! & top(nlays), +! & emis_file_layer_frac(nlays, n_file_gr), +! & stat=stat) + +#endif + + n_e2d = 0 + n_e3d = 0 + do n = 1, N_FILE_GR + + n_opened_file = n_opened_file + 1 + f_emis(n) = n_opened_file + +! Check whether file is a representative day type + file_sym_date(f_emis(n)) = emis_sym_date ! Master switch to change default + write (fname, '(a15, i3.3)') "GR_EM_SYM_DATE_", n + call get_env(file_sym_date(f_emis(n)), fname, + & file_sym_date(f_emis(n)), logdev ) + + write (fname, '(a8, i3.3)') "GR_EMIS_", n + cio_emis_file_name(n) = fname + +#ifdef mpas +! floc = search_fname (cio_emis_file_name(n)) +! cio_emis_file_loc(n) = floc +! +! call mpas_date_time_to_julian (mio_file_data(floc)%timestamp(1), tdate(1), ttime(1)) +! call mpas_date_time_to_julian (mio_file_data(floc)%timestamp(2), tdate(2), ttime(2)) +! +! file_sdate(f_emis(n)) = tdate(1) +! file_stime(f_emis(n)) = ttime(1) +! +! diffsec = secsdiff (tdate(1), ttime(1), tdate(2), ttime(2)) +! +! file_tstep(f_emis(n)) = sec2time(diffsec) +! mio_file_data(floc)%tstep = file_tstep(f_emis(n)) +! +! layer_exist = .false. +! do v = 1, mio_file_data(floc)%n_global_atts +! if (mio_file_data(floc)%glo_att_name(v) .eq. 'layers') then +! layer_exist = .true. +! s = mio_file_data(floc)%glo_catt_range(2*v-1) +! e = mio_file_data(floc)%glo_catt_range(2*v) +! call ext_layer_info (mio_file_data(floc)%glo_att_cval(s:e), +! & emis_file_dist_layer, bottom, top, +! & emis_file_layer_frac(:,n)) +! end if +! end do +! +! if (layer_exist) then +! do c = 1, ncols +! call cal_distribution (bottom, top, g3ddata(c,1,:,zh_ind), +! & emis_file_layer_frac(:,n), +! & emis_file_dist_layer, +! & num_dist_layers(c,n), +! & dist_frac(:,c,n)) +! end do +! else +! num_dist_layers(:,n) = 1 +! dist_frac(:,:,n) = 1.0 +! end if +! +! cio_emis_nvars(n) = mio_file_data(floc)%nvars +! if (mio_file_data(floc)%nlays .eq. 1) then +! n_e2d = n_e2d + cio_emis_nvars(n) +! else +! n_e3d = n_e3d + cio_emis_nvars(n) +! end if +! +! call mpas_date_time_to_julian (mio_file_data(floc)%timestamp(1), file_sdate(f_emis(n)), time) +#else + IF ( .NOT. OPEN3( fname, FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open '// fname // ' file' + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + IF ( .NOT. DESC3( fname ) ) THEN + XMSG = 'Could not get description of file '// fname + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + call subhfile ( cio_emis_file_name(n), gxoff, gyoff, + & cio_emis_file_startcol(n), cio_emis_file_endcol(n), + & cio_emis_file_startrow(n), cio_emis_file_endrow(n) ) + + file_sdate(f_emis(n)) = sdate3d + file_stime(f_emis(n)) = stime3d + file_tstep(f_emis(n)) = tstep3d + file_xcell(f_emis(n)) = xcell3d + file_ycell(f_emis(n)) = ycell3d + + found = .false. + ldate = sdate3d + ltime = stime3d + if (ldate == stdate) then + found = .true. + else + t = 1 + do while ((t < mxrec3d) .and. (.not. found)) + call nextime (ldate, ltime, tstep3d) + if (ldate == stdate) then + found = .true. + end if + t = t + 1 + end do + end if + + cio_emis_nvars(n) = nvars3d + if (nlays3d .eq. 1) then + n_e2d = n_e2d + cio_emis_nvars(n) + else + n_e3d = n_e3d + cio_emis_nvars(n) + end if + +#endif + end do + +#ifdef mpas +! deallocate (bottom, top) +! +! n_dust_vars = 0 +#else + +! Wind blown dust data + n_dust_vars = 0 +#endif + + n_e2d = n_e2d + n_dust_vars + + allocate (emis_name(n_e2d+n_e3d, 3), stat=stat) + if (stat .ne. 0) then + xmsg = 'Failure allocating emis_name ' + call m3exit (pname, 0, 0, xmsg, xstat1 ) + end if + +#ifndef mpas +! setup initial condition file +! n_i3d = 0 +! IF ( .NOT. OPEN3( ICFILE, FSREAD3, PNAME ) ) THEN +! XMSG = 'Open failure for ' // ICFILE +! Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) +! END IF +! n_opened_file = n_opened_file + 1 +! f_icon = n_opened_file +! IF ( .NOT. DESC3( ICFILE ) ) THEN +! XMSG = 'Could not get description of file '// ICFILE +! CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) +! END IF +! call subhfile ( ICFILE, gxoff, gyoff, +! & STRTCOLIC, ENDCOLIC, STRTROWIC, ENDROWIC ) +! +!! remove duplicate name from MET_CRO_3D file +! adj = nvars3d +! do v = nvars3d, 1, -1 +! n = index1 (vname3d(v), n_c3d, c3d_name) +! if (n .gt. 0) then +! do idx = v+1, adj +! vname3d(idx-1) = vname3d(idx) +! end do +! adj = adj - 1 +! end if +! end do +! n_i3d = adj +! +! allocate (i3d_name(n_i3d, 3), stat=stat) +! if (stat .ne. 0) then +! xmsg = 'Failure allocating i3d_name ' +! call m3exit (pname, 0, 0, xmsg, xstat1 ) +! end if +! i3d_name(:,1) = vname3d(1:n_i3d) +! i3d_name(:,2) = 'ic' ! denote initial condition variable +! i3d_name(:,3) = ' ' ! denote non met variable +! +!! setup initial condition file for ISAM +! n_is3d = 0 +! +! if (ISAM_NEW_START == 'N') then +! IF ( .NOT. OPEN3( ISAM_PREVDAY, FSREAD3, PNAME ) ) THEN +! XMSG = 'Open failure for ' // ISAM_PREVDAY +! Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) +! END IF +! n_opened_file = n_opened_file + 1 +! f_is_icon = n_opened_file +! IF ( .NOT. DESC3( ISAM_PREVDAY ) ) THEN +! XMSG = 'Could not get description of file '// ISAM_PREVDAY +! CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) +! END IF +! call subhfile ( ISAM_PREVDAY, gxoff, gyoff, +! & STRTCOLISIC, ENDCOLISIC, STRTROWISIC, ENDROWISIC ) +! +! n_is3d = nvars3d +! allocate (is3d_name(n_is3d, 3), stat=stat) +! if (stat .ne. 0) then +! xmsg = 'Failure allocating i3d_name ' +! call m3exit (pname, 0, 0, xmsg, xstat1 ) +! end if +! is3d_name(:,1) = vname3d(1:n_is3d) +! is3d_name(:,2) = 'is' ! denote ISAM initial condition variable +! is3d_name(:,3) = ' ' ! denote non met variable +! +! file_sdate(f_is_icon) = sdate3d +! file_stime(f_is_icon) = stime3d +! file_tstep(f_is_icon) = tstep3d +! file_xcell(f_is_icon) = xcell3d +! file_ycell(f_is_icon) = ycell3d +! +! end if ! ISAM_NEW_START +#endif + +! setup gridded emission file + end = 0 + allocate (cio_emis_file_layer(N_FILE_GR), stat=stat) + do n = 1, N_FILE_GR + WRITE (fname, '(a8, i3.3)') "GR_EMIS_", n +#ifdef mpas +! floc = cio_emis_file_loc(n) +! nl = mio_file_data(floc)%nlays +#else + IF ( .NOT. DESC3( fname ) ) THEN + XMSG = 'Could not get description of file '// fname + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + nl = nlays3d +#endif + + begin = end + 1 + + write (tname, '(a1, i3.3)') '_', n +#ifdef mpas +! do v = 1, mio_file_data(floc)%nvars +! end = end + 1 +! emis_name(end,1) = trim(mio_file_data(floc)%var_name(v)) // tname +! end do + +#else + do v = 1, nvars3d + end = end + 1 + emis_name(end,1) = trim(vname3d(v)) // tname + end do +#endif + + if (nl .eq. 1) then + emis_name(begin:end, 2) = 'e2d' ! e denote emission 2d variable + else + emis_name(begin:end, 2) = 'e3d' ! E denote emission 3d variable + end if + emis_name(begin:end, 3) = ' ' ! denote non met variable + cio_emis_file_layer(n) = nl + end do + + cio_emis_nlays = maxval(cio_emis_file_layer) + ! If there are 3D (inline point or Lightning) sources, + ! revise the top to be the model top. + IF ( NPTGRPS .GT. 0 .OR. LTNG_NO ) cio_emis_nlays = NLAYS + + ! Make sure the top is not greater than the model top + cio_emis_nlays = MAX( MIN( cio_emis_nlays, NLAYS ), 1 ) + + WRITE( LOGDEV,1009 ) cio_emis_nlays, NLAYS + 1009 FORMAT( 5X, 'Number of Emissions Layers: ', I3 + & / 5X, 'out of total Number of Model Layers:', I3 ) + +! lightning file + n_l2d = 0 +#ifndef mpas +! if (NLDNSTRIKE) then +! IF ( .NOT. OPEN3( NLDN_STRIKES, FSREAD3, PNAME ) ) THEN +! XMSG = 'Open failure for ' // NLDN_STRIKES +! Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) +! END IF +! n_opened_file = n_opened_file + 1 +! f_ltng = n_opened_file +! IF ( .NOT. DESC3( NLDN_STRIKES ) ) THEN +! XMSG = 'Could not get description of file '// NLDN_STRIKES +! CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) +! END IF +! call subhfile ( NLDN_STRIKES, gxoff, gyoff, +! & STRTCOLLNT, ENDCOLLNT, STRTROWLNT, ENDROWLNT) +! +! file_sdate(f_ltng) = sdate3d +! file_stime(f_ltng) = stime3d +! file_tstep(f_ltng) = tstep3d +! file_xcell(f_ltng) = xcell3d +! file_ycell(f_ltng) = ycell3d +! +! n_l2d = nvars3d +! cio_LTLYRS = nlays3d +! allocate (l2d_name(n_l2d, 3), stat=stat) +! if (stat .ne. 0) then +! xmsg = 'Failure allocating l2d_name ' +! call m3exit (pname, 0, 0, xmsg, xstat1 ) +! end if +! l2d_name(:,1) = vname3d(1:n_l2d) +! l2d_name(:,2) = 'lnt' ! denote lightning variable +! l2d_name(:,3) = ' ' ! denote non met variable +! ! Check to see what the lightning variable name is called +! ! backwards (NLDNstrk) & forwards compatible (LNT) +! if ( index1('NLDNstrk', n_l2d ,l2d_name(:,1)) .gt. 0 ) then +! lt_name = 'NLDNstrk' +! else +! lt_name = 'LNT' +! end if +! +! end if +#endif + +! combining all files + n_cio_grid_vars = n_c2d + n_c3d + n_d3d + n_e2d + n_e3d + n_l2d + n_i3d + n_is3d + +#ifdef mpas +! cro_ncols = ncols +! cro_nrows = 1 +! size_c2dx = 1 + +!! for standard domain +! s_cro_ncols = ncols +! s_cro_nrows = 1 +#else + cro_ncols = ENDCOLMC2 - STRTCOLMC2 + 1 + cro_nrows = ENDROWMC2 - STRTROWMC2 + 1 + +! for standard domain + STRTCOLSTD = COLSX_PE( 1, MYPE+1 ) + ENDCOLSTD = COLSX_PE( 2, MYPE+1 ) + STRTROWSTD = ROWSX_PE( 1, MYPE+1 ) + ENDROWSTD = ROWSX_PE( 2, MYPE+1 ) + + s_cro_ncols = ENDCOLSTD - STRTCOLSTD + 1 + s_cro_nrows = ENDROWSTD - STRTROWSTD + 1 +#endif + size_c2d = cro_ncols * cro_nrows + + size_s2d = s_cro_ncols * s_cro_nrows + + if ((cro_ncols .ne. ncols) .or. (cro_nrows .ne. nrows)) then + call m3exit( 'Centralized I/O',0,0,' ==d== NO ncols nrows ',1 ) + end if + + x_cro_ncols = ENDCOLMC2x - STRTCOLMC2x + 1 + x_cro_nrows = ENDROWMC2x - STRTROWMC2x + 1 + size_c2dx = x_cro_ncols * x_cro_nrows + + size_d2d = dot_ncols * dot_nrows + + if (window) then + + size_c3d = w_cro_ncols * w_cro_nrows * nlays + else + size_c3d = size_c2dx * nlays + end if + + size_e3d = size_s2d * cio_emis_nlays + size_s3d = size_s2d * nlays + + size_lt = size_s2d * cio_LTLYRS + + allocate (cio_grid_var_name(n_cio_grid_vars, 3), + & cio_grid_data_inx(2, 0:2, n_cio_grid_vars), + & head_grid(n_cio_grid_vars), + & tail_grid(n_cio_grid_vars), + & cio_grid_data_tstamp(2, 0:2, n_cio_grid_vars), + & cio_grid_data( size_c2dx * 3 * n_c2d ! 2d met data + & + size_c2d * 3 * n_e2d ! 2d emis data + & + size_c3d * 3 * n_c3d ! 3D met data + & + size_e3d * 3 * n_e3d ! 3d emis data + & + size_s3d * 3 * n_i3d ! 3d initial condition data + & + size_s3d * 3 * n_is3d ! 3d ISAM initial condition data + & + size_d3dx * 3 * n_d3d ! 3d dot data + & + size_lt * 3 * n_l2d), ! lightning data + & stat = stat) + if (stat .ne. 0) then + xmsg = 'Failure allocating cio_grid_var_name and associated arrays ' + call m3exit (pname, 0, 0, xmsg, xstat1 ) + end if + cio_grid_data = 0.0 + +#ifdef mpas +! end = 0 +! allocate (cio_mpas_grid_data_tstamp(0:2, n_cio_grid_vars), +! & stat = stat) + +#else + begin = 1 + end = n_c2d + cio_grid_var_name(begin:end, :) = c2d_name + + begin = end + 1 + end = end + n_c3d + cio_grid_var_name(begin:end, :) = c3d_name + + begin = end + 1 + end = end + n_d3d + cio_grid_var_name(begin:end, :) = d3d_name +#endif + + begin = end + 1 + end = end + n_e2d + n_e3d + cio_grid_var_name(begin:end, :) = emis_name + +#ifndef mpas +! begin = end + 1 +! end = end + n_i3d +! cio_grid_var_name(begin:end, :) = i3d_name +! +! if (ISAM_NEW_START == 'N') then +! begin = end + 1 +! end = end + n_is3d +! cio_grid_var_name(begin:end, :) = is3d_name +! end if +! +! if (NLDNSTRIKE) then +! begin = end + 1 +! end = end + n_l2d +! cio_grid_var_name(begin:end, :) = l2d_name +! deallocate (l2d_name) +! end if +! +! deallocate (c2d_name, c3d_name, i3d_name) +! if (ISAM_NEW_START == 'N') then +! deallocate (is3d_name) +! end if +! if (.not. window) then +! deallocate (d3d_name) +! end if +#endif + deallocate (emis_name) + + call quicksort(cio_grid_var_name, 1, n_cio_grid_vars) + + begin = 1 + do v = 1, n_cio_grid_vars + +! locate certain species + if (cio_grid_var_name(v,1) .eq. 'TEMPG') then + tempg_loc = v + else if (cio_grid_var_name(v,1) .eq. 'TSEASFC') then + tseasfc_loc = v + end if + + if (cio_grid_var_name(v,2) .eq. 'mc2') then + d_size = size_c2dx + else if (cio_grid_var_name(v,2) .eq. 'e2d') then + d_size = size_s2d + else if (cio_grid_var_name(v,2) .eq. 'mc3') then + d_size = size_c3d + else if (cio_grid_var_name(v,2) .eq. 'e3d') then + d_size = size_e3d + else if ((cio_grid_var_name(v,2) .eq. 'ic') .or. + & (cio_grid_var_name(v,2) .eq. 'is')) then + d_size = size_s3d + else if (cio_grid_var_name(v,2) .eq. 'md3') then + d_size = size_d3dx + else if ((cio_grid_var_name(v,2) .eq. 'lnt') .or. + & (cio_grid_var_name(v,2) .eq. 'wb')) then + d_size = size_s2d + else + call m3exit( 'Centralized I/O',0,0,' ==d== UNKOWN',1 ) + end if + + do n = 0, 2 + cio_grid_data_inx(1, n, v) = begin + end = begin + d_size - 1 + cio_grid_data_inx(2, n, v) = end + begin = end + 1 + end do +! this is for checking purposes +! write (logdev, '(a12, i5, 1x, a16, 2a4, 10i10)') ' ==d== file ', v, +! & cio_grid_var_name(v,:), cio_grid_data_inx(:,:,v) + end do + + end subroutine gridded_files_setup + +! ------------------------------------------------------------------------- + subroutine retrieve_time_dep_gridded_data (jdate, jtime, vname) + + USE UTILIO_DEFN + USE HGRD_DEFN + USE VGRD_DEFN, ONLY : NLAYS + USE CGRID_SPCS + use get_env_module +#ifdef mpas !(Wei Li) +! use mio_module +! use util_module, only : nextime +! use mio_util_func_module, only : mpas_nextime +! use coupler_module, only : cell_area +! use centralized_io_util_module, only : julian_to_mpas_date_time, binary_search +#else + use centralized_io_util_module, only : binary_search +#endif + + INCLUDE SUBST_FILES_ID ! file name parameters + + integer, intent(in) :: jdate, jtime + character (*), intent(in), optional :: vname + + Character( 40 ), parameter :: pname = 'retrieve_time_dep_gridded_data' + + LOGICAL, SAVE :: firstime = .true. + INTEGER :: STAT, i, j, k, begin, end, buf_loc, iterations, iter, + & loc_jdate_met, loc_emis_jdate, + & loc_jtime_met, data_jdate, data_jtime, t_time, + & bs_tjdate, wb_tjdate, v, beg_v, end_v, fnum, str_len, + & bs_tjtime, wb_tjtime, wb_pre_begin, wb_pre_end, + & t_beg, t_end, floc + integer, allocatable :: tdata(:), loc_jdate(:), loc_jtime(:) + character (16) :: loc_vname + character (20) :: fname + logical :: advanced + character (20), allocatable, save :: mpas_loc_time_stamp(:) + + CHARACTER( 120 ) :: XMSG = ' ' + +#ifdef mpas +! real, save, allocatable :: mpas_tdata(:,:), temp_data_1d(:), temp_data_2d(:,:) +! character (20) :: loc_mpas_time_stamp ! this is for mpas only +! character (20), save :: mpas_time_stamp ! this is for mpas only +! integer, save :: pre_jdate, pre_jtime ! this is fore mpas only +! character( 40 ), save :: exception1, exception2 +#endif + + allocate (loc_jdate(n_opened_file), loc_jtime(n_opened_file), STAT=STAT) + + if (firstime) then + +#ifdef mpas +! allocate (mpas_loc_time_stamp(n_opened_file), STAT=STAT) +! +! do k = 1, N_FILE_GR +! write (fname, '(a8, i3.3)') "GR_EMIS_", k +! i = search_fname (fname) +! mpas_loc_time_stamp(f_emis(k)) = mio_file_data(i)%timestamp(1) +! end do +! +! pre_jdate = -1 +! pre_jtime = -1 +! +! call get_env (exception1, 'exception1', ' ') +! call get_env (exception2, 'exception2', ' ') + +#else + allocate (SOILCAT_A(ncols, nrows), STAT=STAT) + + IF ( STAT .NE. 0 ) THEN + XMSG = 'Failure allocating SLTYP array' + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT3 ) + END IF +#ifdef twoway + If ( .Not. INTERPX( MET_CRO_2D, 'SLTYP', PNAME, + & STRTCOLMC2, ENDCOLMC2,STRTROWMC2, ENDROWMC2, 1, 1, + & jdate, jtime, SOILCAT_A ) ) THEN + XMSG = ' Error interpolating variable SLTYP from ' // MET_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF +#else + If ( .Not. XTRACT3( MET_CRO_2D, 'SLTYP', + & 1, 1, STRTROWMC2, ENDROWMC2, STRTCOLMC2, ENDCOLMC2, + & jdate, jtime, SOILCAT_A ) ) THEN + XMSG = ' Error interpolating variable SLTYP from ' // MET_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF +#endif + +#endif + head_grid = -1 + tail_grid = -1 + + iterations = 2 + else + iterations = 1 + end if ! firstime + + if (present(vname)) then + beg_v = binary_search (vname, cio_grid_var_name(:,1), n_cio_grid_vars) + end_v = beg_v + else + beg_v = 1 + end_v = n_cio_grid_vars + end if + + loc_jdate = jdate + loc_jtime = jtime + + advanced = .false. + do iter = 1, iterations + do v = beg_v, end_v + buf_loc = mod((tail_grid(v) + iter), 2) + + begin = cio_grid_data_inx(1,buf_loc,v) + end = cio_grid_data_inx(2,buf_loc,v) + + if (cio_grid_var_name(v,2) == 'mc2') then + +#ifndef mpas +! data_jdate = loc_jdate(f_met) +! data_jtime = loc_jtime(f_met) +! +! if ((cio_grid_var_name(v,1) .ne. 'TSEASFC') .or. TSEASFC_AVAIL) then +#ifdef twoway + IF ( .NOT. INTERPX( MET_CRO_2D, cio_grid_var_name(v,1), PNAME, + & STRTCOLMC2x, ENDCOLMC2x, STRTROWMC2x, ENDROWMC2x, 1, 1, + & data_jdate, data_jtime, cio_grid_data(begin:end) ) ) THEN + XMSG = 'Could not extract ' // MET_CRO_2D // ' file' + CALL M3EXIT ( PNAME, data_jdate, data_jtime, XMSG, XSTAT1 ) + END IF +#else + IF ( .NOT. XTRACT3( MET_CRO_2D, cio_grid_var_name(v,1), + & 1, 1, STRTROWMC2x, ENDROWMC2x, STRTCOLMC2x, ENDCOLMC2x, + & data_jdate, data_jtime, cio_grid_data(begin:end) ) ) THEN + XMSG = 'Could not extract ' // MET_CRO_2D // ' file' + CALL M3EXIT ( PNAME, data_jdate, data_jtime, XMSG, XSTAT1 ) + END IF +#endif + END IF + +! deal with convective scheme + if ((cio_grid_var_name(v,1) .eq. 'RC') .or. + & (cio_grid_var_name(v,1) .eq. 'RCA')) then + if (maxval(cio_grid_data(begin:end)) .lt. 0.0) then + convective_scheme = .false. + cio_grid_data(begin:end) = 0.0 + XMSG = 'MCIP files indicate no convective parameterization was ' + & // 'used in the WRF simulation' + CALL M3WARN ( PNAME, JDATE, JTIME, XMSG ) + XMSG = 'Processing will continue without subgrid clouds' + CALL M3MESG ( XMSG ) + else + where (cio_grid_data(begin:end) .lt. 0.0) cio_grid_data(begin:end) = 0.0 + end if + end if + + else if (cio_grid_var_name(v,2) == 'mc3') then + + data_jdate = loc_jdate(f_met) + data_jtime = loc_jtime(f_met) +#ifdef twoway + IF ( .NOT. INTERPX( MET_CRO_3D, cio_grid_var_name(v,1), PNAME, + & STRTCOLMC3, ENDCOLMC3, STRTROWMC3, ENDROWMC3, 1, nlays, + & data_jdate, data_jtime, cio_grid_data(begin:end) ) ) THEN + XMSG = 'Could not extract ' // MET_CRO_3D // ' file' + CALL M3EXIT ( PNAME, data_jdate, data_jtime, XMSG, XSTAT1 ) + END IF +#else + IF ( .NOT. XTRACT3( MET_CRO_3D, cio_grid_var_name(v,1), + & 1, nlays, STRTROWMC3, ENDROWMC3, STRTCOLMC3, ENDCOLMC3, + & data_jdate, data_jtime, cio_grid_data(begin:end) ) ) THEN + XMSG = 'Could not extract ' // MET_CRO_3D // ' file' + CALL M3EXIT ( PNAME, data_jdate, data_jtime, XMSG, XSTAT1 ) + END IF +#endif + else if (cio_grid_var_name(v,2) == 'md3') then + + data_jdate = loc_jdate(f_met) + data_jtime = loc_jtime(f_met) +#ifdef twoway + IF ( .NOT. INTERPX( MET_DOT_3D, cio_grid_var_name(v,1), PNAME, + & STRTCOLMD3x, ENDCOLMD3x, STRTROWMD3x, ENDROWMD3x, 1, nlays, + & data_jdate, data_jtime, cio_grid_data(begin:end) ) ) THEN + XMSG = 'Could not extract ' // MET_DOT_3D // ' file' + CALL M3EXIT ( PNAME, data_jdate, data_jtime, XMSG, XSTAT1 ) + END IF +#else + IF ( .NOT. XTRACT3( MET_DOT_3D, cio_grid_var_name(v,1), + & 1, nlays, STRTROWMD3x, ENDROWMD3x, STRTCOLMD3x, ENDCOLMD3x, + & data_jdate, data_jtime, cio_grid_data(begin:end) ) ) THEN + XMSG = 'Could not extract ' // MET_DOT_3D // ' file' + CALL M3EXIT ( PNAME, data_jdate, data_jtime, XMSG, XSTAT1 ) + END IF +#endif +#endif + else if (cio_grid_var_name(v,2) == 'e2d') then + + str_len = len_trim(cio_grid_var_name(v,1)) + read (cio_grid_var_name(v,1)(str_len-2:str_len), *) fnum + loc_vname = cio_grid_var_name(v,1)(1:str_len-4) + +#ifdef mpas +! floc = cio_emis_file_loc(fnum) +! +! if (.not. allocated(mpas_tdata)) then +! allocate (mpas_tdata(ncols, nlays), +! & temp_data_1d(ncols), +! & stat=stat) +! end if +! +! loc_mpas_time_stamp = mpas_loc_time_stamp(f_emis(fnum)) +! +! call mio_fread (cio_emis_file_name(fnum), +! & loc_vname, +! & mpas_tdata, +! & loc_mpas_time_stamp) +! +!! de-normalized the data +! mpas_tdata = 0.0 +! if ((cio_emis_file_name(fnum) .eq. exception1) .or. +! & (cio_emis_file_name(fnum) .eq. exception2)) then +! do i = 1, ncols +! do k = 1, num_dist_layers(i,fnum) +! mpas_tdata(i,k) = temp_data_1d(i) * dist_frac(k,i,fnum) +! end do +! end do +! else +! do i = 1, ncols +! do k = 1, num_dist_layers(i,fnum) +! mpas_tdata(i,k) = temp_data_1d(i) * dist_frac(k,i,fnum) !* cell_area(i,1) +! end do +! end do +! end if +! +!! do i = 1, ncols +!! mpas_tdata(i,:) = mpas_tdata(i,:) * cell_area(i,1) +!! end do +! +! cio_grid_data(begin:end) = reshape(mpas_tdata, (/ end-begin+1 /)) + +#else + + ! Check if its a representative day on start-up (every other time it will + ! be managed by the emissions processing) + if (firstime) then + if (file_sym_date(f_emis(fnum))) loc_jdate(f_emis(fnum)) = file_sdate(f_emis(fnum)) + end if + data_jdate = loc_jdate(f_emis(fnum)) + data_jtime = loc_jtime(f_emis(fnum)) + + IF ( .NOT. XTRACT3( cio_emis_file_name(fnum), loc_vname, 1, 1, + & cio_emis_file_startrow(fnum), cio_emis_file_endrow(fnum), + & cio_emis_file_startcol(fnum), cio_emis_file_endcol(fnum), + & data_jdate, data_jtime, cio_grid_data(begin:end) ) ) THEN + XMSG = 'Could not extract ' // cio_emis_file_name(fnum) // ' file' + CALL M3EXIT ( PNAME, data_jdate, data_jtime, XMSG, XSTAT1 ) + END IF +#endif + + else if (cio_grid_var_name(v,2) == 'e3d') then + + str_len = len_trim(cio_grid_var_name(v,1)) + read (cio_grid_var_name(v,1)(str_len-2:str_len), *) fnum + loc_vname = cio_grid_var_name(v,1)(1:str_len-4) + +#ifdef mpas +! floc = cio_emis_file_loc(fnum) +! +! if (.not. allocated(mpas_tdata)) then +! allocate (mpas_tdata(ncols, nlays), +! & temp_data_1d(ncols), +! & stat=stat) +! end if +! +! file_tstep(f_emis(fnum)) = mio_file_data(floc)%tstep +! +! ! Check if its a representative day on start-up (every other +! ! time it will be managed by the emissions processing) +! if (firstime) then +! if (file_sym_date(f_emis(fnum))) loc_jdate(f_emis(fnum)) = file_sdate(f_emis(fnum)) +! end if +! data_jdate = loc_jdate(f_emis(fnum)) +! data_jtime = loc_jtime(f_emis(fnum)) +! +! call julian_to_mpas_date_time (data_jdate, data_jtime, loc_mpas_time_stamp) +! +! call mio_fread (cio_emis_file_name(fnum), +! & loc_vname, +! & temp_data_1d, +! & loc_mpas_time_stamp) +! +! cio_mpas_grid_data_tstamp(buf_loc, v) = loc_mpas_time_stamp +! +! call mpas_date_time_to_julian (loc_mpas_time_stamp, data_jdate, data_jtime) +! +!! de-normalized the data +! mpas_tdata = 0.0 +! do i = 1, ncols +! do k = 1, num_dist_layers(i,fnum) +! mpas_tdata(i,k) = temp_data_1d(i) * dist_frac(k,i,fnum) +! end do +! end do +! +! t_beg = begin +! t_end = begin + ncols - 1 +! do k = 1, nlays +! cio_grid_data(t_beg:t_end) = mpas_tdata(:,k) +! t_beg = t_end + 1 +! t_end = t_end + ncols +! end do + +#else + ! Check if its a representative day on start-up (every other time it will + ! be managed by the emissions processing) + if (firstime) then + if (file_sym_date(f_emis(fnum))) loc_jdate(f_emis(fnum)) = file_sdate(f_emis(fnum)) + end if + data_jdate = loc_jdate(f_emis(fnum)) + data_jtime = loc_jtime(f_emis(fnum)) + + IF ( .NOT. XTRACT3( cio_emis_file_name(fnum), loc_vname, + & 1, cio_emis_file_layer(fnum), + & cio_emis_file_startrow(fnum), cio_emis_file_endrow(fnum), + & cio_emis_file_startcol(fnum), cio_emis_file_endcol(fnum), + & data_jdate, data_jtime, cio_grid_data(begin:end) ) ) THEN + XMSG = 'Could not extract ' // cio_emis_file_name(fnum) // ' file' + CALL M3EXIT ( PNAME, data_jdate, data_jtime, XMSG, XSTAT1 ) + END IF + +#endif + + else if (cio_grid_var_name(v,2) == 'ic') then + +#ifndef mpas +! data_jdate = loc_jdate(f_icon) +! data_jtime = loc_jtime(f_icon) +! +! if (iter == 1) then +! +! IF ( .NOT. XTRACT3( ICFILE, cio_grid_var_name(v,1), +! & 1, nlays, STRTROWIC, ENDROWIC, STRTCOLIC, ENDCOLIC, +! & data_jdate, data_jtime, cio_grid_data(begin:end) ) ) THEN +! XMSG = 'Could not extract ' // ICFILE // ' file' +! CALL M3EXIT ( PNAME, data_jdate, data_jtime, XMSG, XSTAT1 ) +! END IF +! end if +#endif + + else if (cio_grid_var_name(v,2) == 'is') then + +#ifndef mpas +! data_jdate = loc_jdate(f_is_icon) +! data_jtime = loc_jtime(f_is_icon) +! +! if ((iter == 1) .and. (ISAM_NEW_START == 'N')) then +! +! IF ( .NOT. XTRACT3( ISAM_PREVDAY, cio_grid_var_name(v,1), +! & 1, nlays, STRTROWISIC, ENDROWISIC, STRTCOLISIC, ENDCOLISIC, +! & data_jdate, data_jtime, cio_grid_data(begin:end) ) ) THEN +! XMSG = 'Could not extract ' // ISAM_PREVDAY // ' file' +! CALL M3EXIT ( PNAME, data_jdate, data_jtime, XMSG, XSTAT1 ) +! END IF +! end if +#endif + + else if (cio_grid_var_name(v,2) == 'lnt') then + +#ifndef mpas +! data_jdate = loc_jdate(f_ltng) +! data_jtime = loc_jtime(f_ltng) +! +! IF ( .NOT. XTRACT3( NLDN_STRIKES, cio_grid_var_name(v,1), +! & 1, cio_LTLYRS, STRTROWLNT, ENDROWLNT, STRTCOLLNT, ENDCOLLNT, +! & data_jdate, data_jtime, cio_grid_data(begin:end) ) ) THEN +! XMSG = 'Could not extract ' // NLDN_STRIKES // ' file' +! CALL M3EXIT ( PNAME, data_jdate, data_jtime, XMSG, XSTAT1 ) +! END IF +#endif + end if + + cio_grid_data_tstamp(1, buf_loc, v) = data_jdate + cio_grid_data_tstamp(2, buf_loc, v) = data_jtime + + end do + +#ifndef mpas +!! assign TEMPG to TSEASFC when TSEASFC is not available in the input file +! if (.not. TSEASFC_AVAIL) then +! begin = cio_grid_data_inx(1,buf_loc,tempg_loc) +! end = cio_grid_data_inx(2,buf_loc,tempg_loc) +! i = cio_grid_data_inx(1,buf_loc,tseasfc_loc) +! j = cio_grid_data_inx(2,buf_loc,tseasfc_loc) +! cio_grid_data(i:j) = cio_grid_data(begin:end) +! end if +! +! CALL NEXTIME ( loc_jdate(f_met), loc_jtime(f_met), file_tstep(f_met) ) +! if (NLDNSTRIKE) then +! CALL NEXTIME ( loc_jdate(f_ltng), loc_jtime(f_ltng), file_tstep(f_ltng) ) +! end if +! CALL NEXTIME ( loc_jdate(f_bcon), loc_jtime(f_bcon), file_tstep(f_bcon) ) +#endif + + do i = 1, N_FILE_GR + CALL NEXTIME ( loc_jdate(f_emis(i)), loc_jtime(f_emis(i)), file_tstep(f_emis(i)) ) + end do + + end do ! end iter + + if (firstime) then + firstime = .false. + head_grid = 0 + tail_grid = 1 + else + do v = beg_v, end_v + head_grid(v) = mod(head_grid(v)+1, 2) + tail_grid(v) = mod(tail_grid(v)+1, 2) + end do + end if + +#ifdef mpas +! pre_jdate = jdate +! pre_jtime = jtime +#endif + deallocate (loc_jdate, loc_jtime) + + end subroutine retrieve_time_dep_gridded_data + +! ------------------------------------------------------------------------- + subroutine retrieve_lufrac_cro_data + + USE UTILIO_DEFN + USE HGRD_DEFN + USE LSM_Mod, ONLY: n_lufrac, init_lsm + + INCLUDE SUBST_FILES_ID ! file name parameters + + Character( 40 ), parameter :: pname = 'retrieve_lufrac_cro_data' + integer :: startcol, endcol, startrow, endrow, gxoff, gyoff + + CHARACTER( 120 ) :: XMSG = ' ' + INTEGER :: STAT, n, c + + CALL INIT_LSM( 0, 0 ) + + allocate (LUFRAC(ncols, nrows, n_lufrac), STAT=STAT) + IF ( STAT .NE. 0 ) THEN + XMSG = 'Failure allocating LUFRAC array' + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT3 ) + END IF + +#ifdef mpas +! do n = 1, n_lufrac +! do c = 1, ncols +! lufrac(c,1,n) = lufrac_data(n,c) +! end do +! end do +#else + CALL SUBHFILE ( LUFRAC_CRO, GXOFF, GYOFF, + & startcol, endcol, startrow, endrow ) + + IF ( .Not. XTRACT3( LUFRAC_CRO, 'LUFRAC', + & 1, n_lufrac, startrow, endrow, startcol, endcol, + & 0, 0, LUFRAC ) ) THEN + XMSG = 'Error interpolating variable LUFRAC from ' // LUFRAC_CRO + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF +#endif + + end subroutine retrieve_lufrac_cro_data + +#ifdef mpas +! ------------------------------------------------------------------------- +! subroutine stack_files_setup_mpas +! +!! USE UTILIO_DEFN +! use stk_prms +! use stack_group_data_module +! use get_env_module +! use hgrd_defn, only : ncols, mype +! use vgrd_defn, only : nlays +! !use coupler_module, only : pres_ind, g3ddata !(Wei Li) +! use centralized_io_util_module, only : quicksort +! !use util_module, only : index1 !(Wei Li) +! use RUNTIME_VARS, only : emis_sym_date +! +! !use mydata_module !(Wei Li) +! +! include SUBST_FILES_ID ! file name parameters +! +! character( 40 ), parameter :: pname = 'stack_files_setup_mpas' +! +! character( 120 ) :: xmsg = ' ' +! character( 500 ) :: map_fname, fname +! integer :: n, v, pt, max_nsrc_pts, max_nvars, begin, end, stat, delta, +! & num_mesh_points, my_num_mesh_points, t_nvars, floc +! integer, allocatable :: d_size(:), pt_size(:), +! & stk_gp_sdate(:), stk_gp_stime(:), +! & stk_gp_nlays(:), mpas_map(:), my_mpas_map_index(:), +! & tdata_1di(:) +! real, allocatable :: tdata_1dr(:) +! +! call get_env (map_fname, 'mpas_dmap_file', ' ') +! call get_env (num_mesh_points, 'num_mesh_points', 1) +! +! allocate (cio_stack_file_name(nptgrps), +! & cio_stack_file_loc(nptgrps), +! & n_cio_stack_emis_vars(nptgrps), +! & n_cio_stack_emis_lays(nptgrps), +! & n_cio_stack_emis_pts(nptgrps), +! & cio_mpas_stack_emis_timestamp(nptgrps), +! & stkgname(nptgrps), +! & d_size(nptgrps), +! & pt_size(nptgrps), +! & stk_gp_sdate(nptgrps), +! & stk_gp_stime(nptgrps), +! & stk_gp_nlays(nptgrps), +! & fire_on(nptgrps), +! & nsrc(nptgrps), +! & mpas_map(num_mesh_points), +! & my_mpas_map_index(num_mesh_points), ! my mesh point +! & my_nsrc_index(num_mesh_points, nptgrps), ! my source number +! & my_nsrc_mesh_index(num_mesh_points, nptgrps), ! my source w.r.t. to my mesh point +! & my_nsrc_pressure(nlays, num_mesh_points, nptgrps), ! my source pressure +! & stat=stat) +! if (stat .ne. 0) then +! xmsg = 'Failure allocating cio_stack_file_name and other arrays' +! call prog_interrupt (pname, 0, 0, xmsg, 1) +! end if +! +! my_data = .false. +! my_cell_num = -1 +! open (unit = 97, file = map_fname, status = 'old') +! my_num_mesh_points = 0 +! do n = 1, num_mesh_points +! read (97, *) mpas_map(n) +! if (mpas_map(n) == mype) then +! my_num_mesh_points = my_num_mesh_points + 1 +! my_mpas_map_index(my_num_mesh_points) = n +! if (n == 108535) then +! my_cell_num(1) = my_num_mesh_points +! my_data = .true. +! else if (n == 12287) then +! my_cell_num(2) = my_num_mesh_points +! my_data = .true. +! end if +! end if +! end do +! close (97) +! +! fire_on = .false. ! array assignment +!! go through all stack group one time to figure out max number of source points +! stkgname = ' ' ! array +! do n = 1, nptgrps +! write( stkgname( n ),'( "STK_GRPS_",I3.3 )' ) n +! end do +! +! if ( .not. stk_prms_init( stkgname ) ) then +! write (cio_logdev, *) 'Could not initialize stack parameters' +! stop +! end if +! +! do n = 1, nptgrps +! +! floc = search_fname(stkgname(n)) +! +!! stk_gp_sdate(n) = mio_file_data(floc)%var_name(ivar) +!! stk_gp_stime(n) = mio_file_data(floc)%var_name(ivar) +! stk_gp_nlays(n) = mio_file_data(floc)%dim_len(3) +! +! nsrc( n ) = mio_file_data(floc)%dim_len(5) +! +! do v = 1, mio_file_data(floc)%nvars +! if ( mio_file_data(floc)%var_name(v) .eq. 'ACRESBURNED' ) fire_on( n ) = .true. +! end do +! end do +! max_nsrc_pts = maxval(nsrc) +! +! allocate (stkid(max_nsrc_pts, nptgrps), +! & stat = stat) +! if (stat .ne. 0) then +! xmsg = 'Failure allocating other stack group variable arrays' +! call prog_interrupt (pname, cio_model_sdate, cio_model_stime, xmsg, 1) +! end if +! +!! read in stack group data +! +! do n = 1, nptgrps +! +! allocate (tdata_1di(nsrc(n)), stat = stat) +! +! call mio_fread (stkgname(n), 'ROW', tdata_1di) +! +! my_nsrc(n) = 0 +! do v = 1, nsrc(n) +! pt = index1 (tdata_1di(v), my_num_mesh_points, my_mpas_map_index) +! +! if (pt .gt. 0) then +! my_nsrc(n) = my_nsrc(n) + 1 +! my_nsrc_index(my_nsrc(n), n) = v +! my_nsrc_mesh_index(my_nsrc(n), n) = pt +! end if +! end do +! +! deallocate (tdata_1di) +! +! end do +! +! my_strt_src = 0 +! do n = 1, nptgrps +! +! if ( my_nsrc( n ) .gt. 0 ) then +! +! my_strt_src(n) = 1 +! my_end_src(n) = my_nsrc(n) +! +! stkdiam(n)%len = my_nsrc(n) +! stkht(n)%len = my_nsrc(n) +! stktk(n)%len = my_nsrc(n) +! stkvel(n)%len = my_nsrc(n) +! +! allocate (stkdiam(n)%arry(my_nsrc(n)), +! & stkht(n)%arry(my_nsrc(n)), +! & stktk(n)%arry(my_nsrc(n)), +! & stkvel(n)%arry(my_nsrc(n)), +! & tdata_1dr(nsrc(n)), +! & stat=stat ) +! +! if ( fire_on(n) ) then +! acres_burned(n)%len = my_nsrc(n) +! allocate (acres_burned(n)%arry(my_nsrc(n)), +! & stat=stat ) +! end if +! +! call mio_fread (stkgname(n), 'STKDM', tdata_1dr) +! +! do v = 1, my_nsrc(n) +! stkdiam( n )%arry(v) = tdata_1dr(my_nsrc_index(v, n)) +! my_nsrc_pressure(:,v,n) = g3ddata(my_nsrc_mesh_index(v, n),1,:,pres_ind) +! end do +! +! call mio_fread (stkgname(n), 'STKHT', tdata_1dr) +! +! do v = 1, my_nsrc(n) +! stkht( n )%arry(v) = tdata_1dr(my_nsrc_index(v, n)) +! end do +! +! call mio_fread (stkgname(n), 'STKTK', tdata_1dr) +! +! do v = 1, my_nsrc(n) +! stktk( n )%arry(v) = tdata_1dr(my_nsrc_index(v, n)) +! end do +! +! call mio_fread (stkgname(n), 'STKVE', tdata_1dr) +! +! do v = 1, my_nsrc(n) +! stkvel( n )%arry(v) = tdata_1dr(my_nsrc_index(v, n)) +! end do +! +! if ( fire_on( n ) ) then +! call mio_fread (stkgname(n), 'ACRESBURNED', tdata_1dr) +! +! do v = 1, my_nsrc(n) +! acres_burned( n )%arry(v) = tdata_1dr(my_nsrc_index(v, n)) +! end do +! +! end if +! +! deallocate (tdata_1dr) +! end if +! +! end do +! +!! process stack emission files +! max_nvars = 0 +! d_size = 0 +! do pt = 1, nptgrps +! +! write( cio_stack_file_name(pt), '( "STK_EMIS_",I3.3 )' ) pt +! +! floc = search_fname(cio_stack_file_name(pt)) +! cio_stack_file_loc(pt) = floc +! +! n_cio_stack_emis_vars(pt) = mio_file_data(floc)%nvars +! n_cio_stack_emis_lays(pt) = mio_file_data(floc)%nlays +! n_cio_stack_emis_pts(pt) = nsrc( pt ) +! +! cio_mpas_stack_emis_timestamp(pt) = mio_file_data(floc)%timestamp(1) +! +! if (max_nvars .lt. mio_file_data(floc)%nvars) then +! max_nvars = mio_file_data(floc)%nvars +! end if +! +! if (my_strt_src(pt) .gt. 0) then +! pt_size(pt) = (my_end_src(pt) - my_strt_src(pt) + 1) * n_cio_stack_emis_lays(pt) +! d_size(pt) = mio_file_data(floc)%nvars * pt_size(pt) * 3 +! else +! pt_size(pt) = 0 +! d_size(pt) = 0 +! end if +! +! end do +! +! allocate (cio_stack_var_name(max_nvars, nptgrps), +! & head_stack_emis(max_nvars, nptgrps), +! & tail_stack_emis(max_nvars, nptgrps), +! & cio_stack_emis_data_inx(2, 0:2, max_nvars, nptgrps), +! & cio_stack_emis_data_tstamp(2, 0:2, max_nvars, nptgrps), +! & cio_stack_data(sum(d_size)), +! & f_stk_emis(NPTGRPS), +! & stat = stat) +! if (stat .ne. 0) then +! xmsg = 'Failure allocating other stack arrays' +! call prog_interrupt (pname, 0, 0, xmsg, 1) +! end if +! +! begin = 1 +! cio_stack_emis_data_inx = -1 +! do pt = 1, nptgrps +! +! floc = cio_stack_file_loc(pt) +! +! n_opened_file = n_opened_file + 1 +! f_stk_emis(pt) = n_opened_file +! +!! Check whether file is a representative day type +! write (fname, '(a16, i3.3)') "STK_EM_SYM_DATE_", pt +! file_sym_date(f_stk_emis(pt)) = emis_sym_date ! Master switch to change default +! call get_env(file_sym_date(f_stk_emis(pt)), fname, +! & file_sym_date(f_stk_emis(pt)), logdev) +! +! file_sdate(f_stk_emis(pt)) = mio_file_data(floc)%tflag(1,1) +! file_stime(f_stk_emis(pt)) = mio_file_data(floc)%tflag(2,1) +! file_tstep(f_stk_emis(pt)) = mio_file_data(floc)%tstep +! +! t_nvars = mio_file_data(floc)%nvars +! +! cio_stack_var_name(1:t_nvars, pt) = mio_file_data(floc)%var_name(1:t_nvars) +! +! call quicksort(cio_stack_var_name(1:t_nvars,pt), 1, t_nvars) +! +! if (my_nsrc(pt) .gt. 0) then +! do v = 1, mio_file_data(floc)%nvars +! do n = 0, 2 +! cio_stack_emis_data_inx(1,n,v,pt) = begin +! end = begin + pt_size(pt) - 1 +! cio_stack_emis_data_inx(2,n,v,pt) = end +! begin = end + 1 +! end do +! end do +! end if +! end do +! +! deallocate (d_size) +! +! end subroutine stack_files_setup_mpas +! +!! ------------------------------------------------------------------------- +! subroutine retrieve_stack_data_mpas (jdate, jtime, fname, vname) +! +!! USE UTILIO_DEFN +! use stk_prms, only : my_strt_src, my_end_src, my_nsrc, my_nsrc_index +! use stack_group_data_module, only : nsrc +! use util_module, only : NEXTIME +! use centralized_io_util_module, only : julian_to_mpas_date_time, binary_search +! +! include SUBST_FILES_ID ! file name parameters +! +! integer, intent(in) :: jdate, jtime +! character (*), intent(in), optional :: fname, vname +! +! character( 40 ), parameter :: pname = 'retrieve_stack_data_mpas' +! +! logical, save :: firstime = .true. +! integer :: stat, i, j, begin, end, buf_loc, iterations, +! & iter, loc_jdate, loc_jtime, v, beg_v, end_v, +! & beg_gp, end_gp, gp, fnum +! real, allocatable :: tdata_1dr(:) +! character (20) :: mpas_time_stamp +! character (20), allocatable, save :: mpas_stack_loc_time_stamp(:) +! +! character( 120 ) :: xmsg = ' ' +! +! if (firstime) then +! +! allocate (mpas_stack_loc_time_stamp(nptgrps), stat=stat) +! +! do i = 1, nptgrps +! j = search_fname (cio_stack_file_name(i)) +! mpas_stack_loc_time_stamp(i) = mio_file_data(j)%timestamp(1) +! end do +! +! head_stack_emis = -1 +! tail_stack_emis = -1 +! +! iterations = 2 +! else +! iterations = 1 +! end if +! +! if (present(vname)) then +! beg_gp = binary_search (fname, cio_stack_file_name, nptgrps) +! end_gp = beg_gp +! beg_v = binary_search (vname, cio_stack_var_name(:,beg_gp), n_cio_stack_emis_vars(beg_gp)) +! end_v = beg_v +! else +! beg_gp = 1 +! end_gp = nptgrps +! end if +! +! do gp = beg_gp, end_gp +! +! allocate (tdata_1dr(nsrc(gp)), stat = stat) +! +! if (firstime) then +! loc_jdate = jdate +! if (file_sym_date(f_stk_emis(gp))) loc_jdate = file_sdate(f_stk_emis(gp)) ! Representative day check +! loc_jtime = jtime +! else +! loc_jdate = jdate +! loc_jtime = jtime +! end if +! +! if (.not. present(vname)) then +! beg_v = 1 +! end_v = n_cio_stack_emis_vars(gp) +! end if +! +!! cio_stack_emis_data_inx +! +! do iter = 1, iterations +! +! call julian_to_mpas_date_time (loc_jdate, loc_jtime, mpas_time_stamp) +! +! do v = beg_v, end_v +! buf_loc = mod((tail_stack_emis(v, gp) + iter), 2) +! +! cio_stack_emis_data_tstamp(1, buf_loc, v, gp) = loc_jdate +! cio_stack_emis_data_tstamp(2, buf_loc, v, gp) = loc_jtime +! +! begin = cio_stack_emis_data_inx(1, buf_loc, v, gp) +! end = cio_stack_emis_data_inx(2, buf_loc, v, gp) +! +! if ((begin .gt. 0) .and. (my_nsrc(gp) .gt. 0)) then +! +! call mio_fread (cio_stack_file_name(gp), +! & cio_stack_var_name(v, gp), +! & tdata_1dr, +! & mpas_time_stamp) +! +! do i = 1, my_nsrc(gp) +! cio_stack_data(begin+i-1) = tdata_1dr(my_nsrc_index(i, gp)) +! end do +! end if +! end do +! +! call nextime ( loc_jdate, loc_jtime, file_tstep(f_stk_emis(gp)) ) +! +! end do ! end iter +! +! deallocate (tdata_1dr) +! +! end do +! +! if (firstime) then +! firstime = .false. +! head_stack_emis = 0 +! tail_stack_emis = 1 +! else +! do gp = beg_gp, end_gp +! do v = beg_v, end_v +! head_stack_emis(v, gp) = mod(head_stack_emis(v, gp)+1, 2) +! tail_stack_emis(v, gp) = mod(tail_stack_emis(v, gp)+1, 2) +! end do +! end do +! end if +! +! end subroutine retrieve_stack_data_mpas +! +!! ------------------------------------------------------------------------- +! subroutine retrieve_ocean_data_mpas +! +! USE HGRD_DEFN +! USE mio_module, only : search_fname +! +! character (20) :: ocean_file = 'OCEAN_1' +! character (120) :: xmsg = ' ' +! character (1000) :: fname +! integer :: floc +! logical :: exist +! +! call get_env (fname, ocean_file, ' ') +! inquire (file=fname, exist=exist) +! +! if (exist) then +! floc = search_fname (ocean_file) +! end if +! +! if (ocean_chem) then +! +!! if OCEAN file does not exist, g2ddata with open_ind and surf_ind have +!! been setup in subroutne mpas_cmaq_coupler, mpas_atmchem_interface.F +! if (exist) then +! call mio_fread (ocean_file, +! & 'OPEN', +! & g2ddata(:, 1, open_ind), +! & mio_file_data(floc)%timestamp(1)) +! +! call mio_fread (ocean_file, +! & 'SURF', +! & g2ddata(:, 1, surf_ind), +! & mio_file_data(floc)%timestamp(1)) +! +! call mio_fread (ocean_file, +! & 'CHLO', +! & g2ddata(:, 1, chlo_ind), +! & mio_file_data(floc)%timestamp(1)) +! call mio_fread (ocean_file, +! & 'DMS', +! & g2ddata(:, 1, dms_ind), +! & mio_file_data(floc)%timestamp(1)) +! else +! XMSG = 'Ocean file doese not exist' +! call prog_interrupt ('reading ocean file', 0, 0, xmsg, 1) +! end if +! end if +! end if +! +! end subroutine retrieve_ocean_data_mpas +! +#else + +! ------------------------------------------------------------------------- + subroutine boundary_files_setup + + USE UTILIO_DEFN + use HGRD_DEFN, only : ncols, nrows + USE VGRD_DEFN, only : VGTYP_GD, nlays + use centralized_io_util_module, only : quicksort + + INCLUDE SUBST_FILES_ID ! file name parameters + + Character( 40 ), parameter :: pname = 'boundary_files_setup' + + CHARACTER( 120 ) :: XMSG = ' ' + INTEGER :: GXOFF, GYOFF, stat, n, v, d_size, begin, end + + character( 16 ), allocatable :: b3d_name(:,:) + character( 16 ) :: mb3d_name(2, 2) + +! MET_BDY_3D file, need to be opened when window is F + if (.not. window) then +#ifndef twoway + IF ( .NOT. OPEN3( MET_BDY_3D, FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open '// MET_BDY_3D // ' file' + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + IF ( .NOT. DESC3( MET_BDY_3D ) ) THEN + XMSG = 'Could not get file description from '// MET_BDY_3D + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF +#endif + n_mb3d = 2 + mb3d_name = 'mb' ! denote met 3D boundary variable + mb3d_name(1,1) = 'DENSA_J' + mb3d_name(2,1) = 'JACOBM' + else + n_mb3d = 0 + end if + +! BCON file + IF ( .NOT. OPEN3( BCFILE, FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open '// BCFILE // ' file' + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + n_opened_file = n_opened_file + 1 + f_bcon = n_opened_file + IF ( .NOT. DESC3( BCFILE ) ) THEN + XMSG = 'Could not get description of file '// BCFILE + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + file_sdate(f_bcon) = sdate3d + file_stime(f_bcon) = stime3d + file_tstep(f_bcon) = tstep3d + file_xcell(f_bcon) = xcell3d + file_ycell(f_bcon) = ycell3d + + n_b3d = nvars3d + size_b2d = (ncols3d + nrows3d + 2 * nthik3d) * 2 * nthik3d + size_b3d = size_b2d * nlays + + allocate (b3d_name(n_b3d, 2), + & cio_bc_file_var_name(nvars3d), + & stat=stat) + if (stat .ne. 0) then + xmsg = 'Failure allocating mb3d_name ' + call m3exit (pname, 0, 0, xmsg, xstat1 ) + end if + + if (tstep3d == 0) then + b3d_name = 'bc' ! denote time independent 3D boundary variable + else + b3d_name = 'bct' ! denote time dependent 3D boundary variable + end if + + b3d_name(:,1) = vname3d(1:nvars3d) + cio_bc_file_var_name = vname3d(1:nvars3d) + n_cio_bc_file_vars = nvars3d + +! combining all files + n_cio_bndy_vars = n_mb3d + n_b3d + + allocate (cio_bndy_var_name(n_cio_bndy_vars, 2), + & cio_bndy_data_inx(2, 0:2, n_cio_bndy_vars), + & head_bndy(n_cio_bndy_vars), + & tail_bndy(n_cio_bndy_vars), + & cio_bndy_data_tstamp(2, 0:2, n_cio_bndy_vars), + & cio_bndy_data(size_b3d * 3 * (n_mb3d + n_b3d)), ! boundary data + & stat = stat) + if (stat .ne. 0) then + xmsg = 'Failure allocating cio_bndy_var_name and associated arrays ' + call m3exit (pname, 0, 0, xmsg, xstat1 ) + end if + + begin = 1 + end = n_b3d + cio_bndy_var_name(begin:end, :) = b3d_name + if (.not. window) then + begin = end + 1 + end = end + 2 + cio_bndy_var_name(begin:end, :) = mb3d_name + end if + + deallocate (b3d_name) + + call quicksort(cio_bndy_var_name, 1, n_cio_bndy_vars) + + begin = 1 + do v = 1, n_cio_bndy_vars + + do n = 0, 2 + cio_bndy_data_inx(1, n, v) = begin + end = begin + size_b3d - 1 + cio_bndy_data_inx(2, n, v) = end + begin = end + 1 + end do +! this is for checking purposes +! write (logdev, '(a13, i5, 1x, a16, a4, 10i10)') ' ==d== bfile ', v, +! & cio_bndy_var_name(v,:), cio_bndy_data_inx(:,:,v) + end do + + end subroutine boundary_files_setup + +! ------------------------------------------------------------------------- + subroutine stack_files_setup + + USE UTILIO_DEFN + USE STK_PRMS + USE stack_group_data_module + USE HGRD_DEFN, only : XORIG_GD, YORIG_GD, XCELL_GD, YCELL_GD + + INCLUDE SUBST_FILES_ID ! file name parameters + + Character( 40 ), parameter :: pname = 'stack_files_setup' + + Character( 32 ) :: fname + CHARACTER( 120 ) :: XMSG = ' ' + integer :: n, v, pt, max_nsrc_pts, max_nvars, begin, end, stat, delta + integer, allocatable :: d_size(:), pt_size(:), + & stk_gp_sdate(:), stk_gp_stime(:), + & stk_gp_nlays(:) + + integer :: ldate, ltime, t + logical :: found, done + + allocate (cio_stack_file_name(NPTGRPS), + & n_cio_stack_emis_vars(NPTGRPS), + & n_cio_stack_emis_lays(NPTGRPS), + & n_cio_stack_emis_pts(NPTGRPS), + & STKGNAME(NPTGRPS), + & d_size(NPTGRPS), + & pt_size(NPTGRPS), + & stk_gp_sdate(NPTGRPS), + & stk_gp_stime(NPTGRPS), + & stk_gp_nlays(NPTGRPS), + & FIRE_ON(NPTGRPS), + & NSRC(NPTGRPS), + & stat=stat) + if (stat .ne. 0) then + xmsg = 'Failure allocating cio_stack_file_name and other arrays' + call m3exit (pname, 0, 0, xmsg, xstat1 ) + end if + + FIRE_ON = .FALSE. ! array assignment +! go through all stack group one time to figure out max number of source points + STKGNAME = ' ' ! array + DO N = 1, NPTGRPS + WRITE( STKGNAME( N ),'( "STK_GRPS_",I3.3 )' ) N + END DO + + do N = 1, NPTGRPS + IF ( .NOT. OPEN3( STKGNAME( N ), FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open '// TRIM( STKGNAME( N ) ) // ' file' + call m3exit (pname, cio_model_sdate, cio_model_stime, xmsg, xstat1 ) + END IF + n_opened_file = n_opened_file + 1 + + IF ( .NOT. DESC3( STKGNAME( N ) ) ) THEN + XMSG = 'Could not get ' // TRIM( STKGNAME( N ) ) // ' file description' + call m3exit (pname, cio_model_sdate, cio_model_stime, xmsg, xstat1 ) + END IF + + stk_gp_sdate(n) = sdate3d + stk_gp_stime(n) = stime3d + stk_gp_nlays(n) = nlays3d + + NSRC( N ) = NROWS3D + + DO V = 1, NVARS3D + IF ( VNAME3D( V ) .EQ. 'ACRESBURNED' ) FIRE_ON( N ) = .TRUE. + END DO + end do + max_nsrc_pts = maxval(NSRC) + + allocate (xloca(max_nsrc_pts, NPTGRPS), + & yloca(max_nsrc_pts, NPTGRPS), + & stkid(max_nsrc_pts, NPTGRPS), + & f_stk_emis(NPTGRPS), + & stat = stat) + if (stat .ne. 0) then + xmsg = 'Failure allocating other stack group variable arrays' + call m3exit (pname, cio_model_sdate, cio_model_stime, xmsg, xstat1 ) + end if + +! read in stack group data + + do N = 1, NPTGRPS + IF ( .NOT. READ3( STKGNAME( N ), 'XLOCA', ALLAYS3, + & stk_gp_sdate(n), stk_gp_stime(n), XLOCA(:,N) ) ) THEN + XMSG = 'Could not read XLOCA from ' // TRIM( STKGNAME( N)) + call m3exit (pname, stk_gp_sdate(n), stk_gp_stime(n), xmsg, xstat1 ) + END IF + + IF ( .NOT. READ3( STKGNAME( N ), 'YLOCA', ALLAYS3, + & stk_gp_sdate(n), stk_gp_stime(n), YLOCA(:,N) ) ) THEN + XMSG = 'Could not read YLOCA from ' // TRIM( STKGNAME( N)) + call m3exit (pname, stk_gp_sdate(n), stk_gp_stime(n), xmsg, xstat1 ) + END IF + + IF ( .NOT. READ3( STKGNAME( N ), 'ISTACK', ALLAYS3, + & stk_gp_sdate(n), stk_gp_stime(n), STKID(:,N) ) ) THEN + XMSG = 'Could not read ISTACK from ' // TRIM( STKGNAME( N) ) + call m3exit (pname, stk_gp_sdate(n), stk_gp_stime(n), xmsg, xstat1 ) + END IF + end do + + IF ( .NOT. STK_PRMS_INIT( STKGNAME ) ) THEN + xmsg = 'Could not initialize stack parameters' + call m3exit( 'Stack Files Setup', 0, 0, xmsg, 2 ) + END IF + + do N = 1, NPTGRPS + + IF ( MY_NSRC( N ) .GT. 0 ) THEN + + IF ( .NOT. XTRACT3( STKGNAME( N ), 'STKDM', 1, stk_gp_nlays(n), + & MY_STRT_SRC( N ), MY_END_SRC( N ), + & 1, 1, stk_gp_sdate(n), stk_gp_stime(n), STKDIAM( N )%ARRY) ) THEN + XMSG = 'Could not read STKDM from ' // TRIM( STKGNAME( N ) ) + call m3exit (pname, stk_gp_sdate(n), stk_gp_stime(n), xmsg, xstat1 ) + END IF + + IF ( .NOT. XTRACT3( STKGNAME( N ), 'STKHT', 1, stk_gp_nlays(n), + & MY_STRT_SRC( N ), MY_END_SRC( N ), + & 1, 1, stk_gp_sdate(n), stk_gp_stime(n), STKHT( N )%ARRY) ) THEN + XMSG = 'Could not read STKHT from ' // TRIM( STKGNAME( N ) ) + call m3exit (pname, stk_gp_sdate(n), stk_gp_stime(n), xmsg, xstat1 ) + END IF + + IF ( .NOT. XTRACT3( STKGNAME( N ), 'STKTK', 1, stk_gp_nlays(n), + & MY_STRT_SRC( N ), MY_END_SRC( N ), + & 1, 1, stk_gp_sdate(n), stk_gp_stime(n), STKTK( N )%ARRY) ) THEN + XMSG = 'Could not read STKTK from ' // TRIM( STKGNAME( N ) ) + call m3exit (pname, stk_gp_sdate(n), stk_gp_stime(n), xmsg, xstat1 ) + END IF + + IF ( .NOT. XTRACT3( STKGNAME( N ), 'STKVE', 1, stk_gp_nlays(n), + & MY_STRT_SRC( N ), MY_END_SRC( N ), + & 1, 1, stk_gp_sdate(n), stk_gp_stime(n), STKVEL( N )%ARRY) ) THEN + XMSG = 'Could not read STKVE from ' // TRIM( STKGNAME( N ) ) + call m3exit (pname, stk_gp_sdate(n), stk_gp_stime(n), xmsg, xstat1 ) + END IF + + IF ( FIRE_ON( N ) ) THEN + IF ( .NOT. XTRACT3( STKGNAME( N ), 'ACRESBURNED', 1, stk_gp_nlays(n), + & MY_STRT_SRC( N ), MY_END_SRC( N ), + & 1, 1, stk_gp_sdate(n), stk_gp_stime(n), ACRES_BURNED( N )%ARRY) ) THEN + XMSG = 'Could not read ACRESBURNED from ' // TRIM( STKGNAME( N ) ) + call m3exit (pname, stk_gp_sdate(n), stk_gp_stime(n), xmsg, xstat1 ) + END IF + END IF + + END IF + + end do + +! process stack emission files + max_nvars = 0 + d_size = 0 + do pt = 1, NPTGRPS + WRITE( cio_stack_file_name(pt), '( "STK_EMIS_",I3.3 )' ) pt + + IF ( .NOT. OPEN3( cio_stack_file_name( pt ), FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open '// TRIM( cio_stack_file_name( pt ) ) // ' file' + CALL M3MESG( XMSG ) + END IF + n_opened_file = n_opened_file + 1 + f_stk_emis(pt) = n_opened_file + + IF ( .NOT. DESC3( cio_stack_file_name( pt ) ) ) THEN + XMSG = 'Could not get ' // TRIM( cio_stack_file_name( pt ) ) // ' file description' + CALL M3MESG( XMSG ) + END IF + + n_cio_stack_emis_vars(pt) = nvars3d + n_cio_stack_emis_lays(pt) = nlays3d + n_cio_stack_emis_pts(pt) = nrows3d + + file_sdate(f_stk_emis(pt)) = sdate3d + file_stime(f_stk_emis(pt)) = stime3d + file_tstep(f_stk_emis(pt)) = tstep3d + file_xcell(f_stk_emis(pt)) = xcell3d + file_ycell(f_stk_emis(pt)) = ycell3d + +! Check whether file is a representative day type + write (fname, '(a16, i3.3)') "STK_EM_SYM_DATE_", pt + file_sym_date(f_stk_emis(pt)) = emis_sym_date ! Master switch to change default + call get_env(file_sym_date(f_stk_emis(pt)), fname, + & file_sym_date(f_stk_emis(pt)), logdev) + + found = .false. + ldate = sdate3d + ltime = stime3d + if ((ldate == stdate) .and. (mxrec3d > 1)) then + found = .true. + else + t = 1 + do while ((t < mxrec3d) .and. (.not. found)) + call nextime (ldate, ltime, tstep3d) + if (ldate == stdate) then + found = .true. + end if + t = t + 1 + end do + end if + + if (max_nvars .lt. nvars3d) then + max_nvars = nvars3d + end if + if (MY_STRT_SRC(pt) .gt. 0) then + pt_size(pt) = (MY_END_SRC(pt) - MY_STRT_SRC(pt) + 1) * n_cio_stack_emis_lays(pt) + d_size(pt) = nvars3d * pt_size(pt) * 3 + else + pt_size(pt) = 0 + d_size(pt) = 0 + end if + + end do + + allocate (cio_stack_var_name(max_nvars, NPTGRPS), + & head_stack_emis(max_nvars, NPTGRPS), + & tail_stack_emis(max_nvars, NPTGRPS), + & cio_stack_emis_data_inx(2, 0:2, max_nvars, NPTGRPS), + & cio_stack_emis_data_tstamp(2, 0:2, max_nvars, NPTGRPS), + & cio_stack_data(sum(d_size)), + & stat = stat) + if (stat .ne. 0) then + xmsg = 'Failure allocating other stack arrays' + call m3exit (pname, 0, 0, xmsg, xstat1 ) + end if + + begin = 1 + cio_stack_emis_data_inx = -1 + do pt = 1, NPTGRPS + IF ( .NOT. DESC3( cio_stack_file_name( pt ) ) ) THEN + XMSG = 'Could not get ' // TRIM( cio_stack_file_name( pt ) ) // ' file description' + CALL M3MESG( XMSG ) + END IF + + cio_stack_var_name(1:nvars3d, pt) = vname3d(1:nvars3d) + call quicksort(cio_stack_var_name(:,pt), 1, nvars3d) + + if (MY_NSRC(pt) .gt. 0) then + do v = 1, nvars3d + do n = 0, 2 + cio_stack_emis_data_inx(1,n,v,pt) = begin + end = begin + pt_size(pt) - 1 + cio_stack_emis_data_inx(2,n,v,pt) = end + begin = end + 1 + end do + end do + end if + end do + + deallocate (d_size) + + end subroutine stack_files_setup + +! ------------------------------------------------------------------------- + subroutine biogemis_setup + + USE UTILIO_DEFN + use HGRD_DEFN, only : ncols, nrows + USE biog_emis_param_module + + INCLUDE SUBST_FILES_ID ! file name parameters + + Character( 40 ), parameter :: pname = 'biogemis_setup' + + CHARACTER( 120 ) :: XMSG = ' ' + CHARACTER( 256 ) :: MESG + CHARACTER( 16 ) :: VAR + INTEGER :: STAT, i, j, k + integer :: startcol, endcol, startrow, endrow, gxoff, gyoff + + ALLOCATE( AVGEMIS( NCOLS,NROWS,NSEF-1,NSEASONS ), + & STAT=STAT ) + + IF ( .NOT. OPEN3( biogemis_fname, FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open ' // trim(biogemis_fname) // ' file' + CALL M3MESG( XMSG ) + END IF + n_opened_file = n_opened_file + 1 + + IF ( .NOT. DESC3( biogemis_fname ) ) THEN + XMSG = 'Could not get ' // trim(biogemis_fname) // ' file description' + CALL M3MESG( XMSG ) + END IF + + call subhfile ( biogemis_fname, gxoff, gyoff, + & startcol, endcol, startrow, endrow ) + + +C Read the various categories of normalized emissions + DO I = 1, NSEASONS + + DO J = 1, NSEF-1 + VAR = 'AVG_' // TRIM( BIOTYPES( J ) ) // SEASON( I ) + + IF ( .NOT. XTRACT3( biogemis_fname, VAR, + & 1,1, startrow, endrow, startcol, endcol, + & 0, 0, AVGEMIS( :,:,J,I ) ) ) THEN + MESG = 'Could not read "' // TRIM( VAR ) // + & '" from file "' // TRIM( biogemis_fname ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + END DO + + END DO ! end loop over seasons + + end subroutine biogemis_setup + +! ------------------------------------------------------------------------- + subroutine beis_norm_emis_setup + + USE UTILIO_DEFN + use HGRD_DEFN, only : ncols, nrows + + Character( 40 ), parameter :: pname = 'beis_norm_emis_setup' + Character( 40 ), parameter :: fname = 'BEIS_NORM_EMIS' + + CHARACTER( 256 ) :: MESG + CHARACTER( 16 ) :: VAR + INTEGER :: STAT + integer :: startcol, endcol, startrow, endrow, gxoff, gyoff + + ALLOCATE( GROWAGNO( NCOLS,NROWS ), + & NGROWAGNO( NCOLS,NROWS ), + & NONAGNO( NCOLS,NROWS ), + & STAT=STAT ) + + IF ( .NOT. OPEN3( fname, FSREAD3, PNAME ) ) THEN + MESG = 'Could not open ' // trim(fname) // ' file ' + CALL M3MESG( MESG ) + END IF + n_opened_file = n_opened_file + 1 + + call subhfile ( fname, gxoff, gyoff, + & startcol, endcol, startrow, endrow ) + + VAR = 'AVG_NOAG_GROW' + IF ( .NOT. XTRACT3( fname, VAR, + & 1,1, startrow, endrow, startcol, endcol, + & 0, 0, GROWAGNO ) ) THEN + MESG = 'Could not read "' // TRIM( VAR ) // + & '" from file "' // TRIM( fname ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + + VAR = 'AVG_NOAG_NONGROWNB3' + IF ( .NOT. XTRACT3( fname, VAR, + & 1,1, startrow, endrow, startcol, endcol, + & 0, 0, NGROWAGNO ) ) THEN + MESG = 'Could not read "' // TRIM( VAR ) // + & '" from file "' // TRIM( fname ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + + VAR = 'AVG_NONONAG' + IF ( .NOT. XTRACT3( fname, VAR, + & 1,1, startrow, endrow, startcol, endcol, + & 0, 0, NONAGNO ) ) THEN + MESG = 'Could not read "' // TRIM( VAR ) // + & '" from file "' // TRIM( fname ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + + end subroutine beis_norm_emis_setup + +! ------------------------------------------------------------------------- + subroutine depv_data_setup + + USE UTILIO_DEFN + use HGRD_DEFN, only : ncols, nrows + use depv_data_module +! use util_module, only : index1 + + INCLUDE SUBST_FILES_ID ! file name parameters + + Character( 40 ), parameter :: pname = 'depv_data_setup' + + CHARACTER( 256 ) :: MESG + CHARACTER( 16 ) :: vname + INTEGER :: STAT, i, j, k, jdate_yest + integer :: startcol, endcol, startrow, endrow, gxoff, gyoff + + Allocate ( Beld_ag ( ncols, nrows, e2c_cats ), + & pHs1 ( ncols, nrows, e2c_cats ), ! for E2C_SOIL file + & pHs2 ( ncols, nrows, e2c_cats ), ! for E2C_SOIL file + & NH4ps1 ( ncols, nrows, e2c_cats ), ! for E2C_CHEM file + & NH4ps2 ( ncols, nrows, e2c_cats ), ! for E2C_CHEM file + & STAT=STAT ) + + IF ( .NOT. OPEN3( E2C_LU, FSREAD3, PNAME ) ) THEN + mesg = 'Could not open ' // trim(E2C_LU) // ' file' + CALL M3MESG( mesg ) + END IF + n_opened_file = n_opened_file + 1 + + call subhfile ( E2C_LU, gxoff, gyoff, + & startcol, endcol, startrow, endrow ) + + Do k = 1, e2c_cats + vname = BELD_Names(k) + IF ( .NOT. XTRACT3( E2C_LU, vname, + & 1, 1, startrow, endrow, startcol, endcol, + & 0, 0, Beld_ag( :,:,k ) ) ) Then + MESG = 'Could not read "' // TRIM( vname ) // + & '" from file "' // TRIM( E2C_LU ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + End Do + +! for E2C_SOIL file + If ( .Not. Open3( E2C_SOIL, fsread3, pname ) ) Then + mesg = 'Could not open '// E2C_SOIL // ' file' + Call M3exit ( pname, 0, 0, mesg, xstat1 ) + End If + n_opened_file = n_opened_file + 1 + + call subhfile ( E2C_SOIL, gxoff, gyoff, + & startcol, endcol, startrow, endrow ) + + vname = 'L1_PH' + If ( .Not. Xtract3 ( E2C_SOIL, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, 0, 0, pHs1 ) ) Then + MESG = 'Could not read "' // TRIM( vname ) // + & '" from file "' // TRIM( E2C_SOIL ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L2_PH' + If ( .Not. Xtract3 ( E2C_SOIL, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, 0, 0, pHs2 ) ) Then + MESG = 'Could not read "' // TRIM( vname ) // + & '" from file "' // TRIM( E2C_SOIL ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + +#ifdef m3dry_opt + Allocate ( por1 ( ncols, nrows, e2c_cats ), + & por2 ( ncols, nrows, e2c_cats ), + & wp1 ( ncols, nrows, e2c_cats ), + & wp2 ( ncols, nrows, e2c_cats ), + & cec1 ( ncols, nrows, e2c_cats ), + & cec2 ( ncols, nrows, e2c_cats ), + & STAT=STAT ) + + vname = 'L1_Porosity' + If ( .Not. Xtract3 ( E2C_SOIL, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, 0, 0, por1 ) ) Then + MESG = 'Could not read "' // TRIM( vname ) // + & '" from file "' // TRIM( E2C_SOIL ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L2_Porosity' + If ( .Not. Xtract3 ( E2C_SOIL, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, 0, 0, por2 ) ) Then + MESG = 'Could not read "' // TRIM( vname ) // + & '" from file "' // TRIM( E2C_SOIL ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L1_Wilt_P' + If ( .Not. Xtract3 ( E2C_SOIL, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, 0, 0, wp1 ) ) Then + MESG = 'Could not read "' // TRIM( vname ) // + & '" from file "' // TRIM( E2C_SOIL ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L2_Wilt_P' + If ( .Not. Xtract3 ( E2C_SOIL, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, 0, 0, wp2 ) ) Then + MESG = 'Could not read "' // TRIM( vname ) // + & '" from file "' // TRIM( E2C_SOIL ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L1_Cation' + If ( .Not. Xtract3 ( E2C_SOIL, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, 0, 0, cec1 ) ) Then + MESG = 'Could not read "' // TRIM( vname ) // + & '" from file "' // TRIM( E2C_SOIL ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L2_Cation' + If ( .Not. Xtract3 ( E2C_SOIL, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, 0, 0, cec2 ) ) Then + MESG = 'Could not read "' // TRIM( vname ) // + & '" from file "' // TRIM( E2C_SOIL ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If +#endif + +! for E2C_CHEM file + If ( .Not. Open3( E2C_CHEM, fsread3, pname ) ) Then + mesg = 'Could not open '// E2C_CHEM // ' file' + Call M3exit ( pname, 0, 0, mesg, xstat1 ) + End If + n_opened_file = n_opened_file + 1 + + IF ( .NOT. DESC3( E2C_CHEM ) ) THEN + MESG = 'Could not get description of file "' // + & TRIM( E2C_CHEM ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + + call subhfile ( E2C_CHEM, gxoff, gyoff, + & startcol, endcol, startrow, endrow ) + + GMN_AVAIL = .false. + if (index1 ('GMN', nvars3d, vname3d) .gt. 0) then + GMN_AVAIL = .true. + end if + + vname = 'L1_NH3' + If ( .Not. Xtract3 (E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, NH4ps1) ) Then + MESG = 'Could not read "' // TRIM( vname ) // + & '" from file "' // TRIM( E2C_CHEM ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L2_NH3' + If ( .Not. Xtract3 (E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, NH4ps2) ) Then + MESG = 'Could not read "' // TRIM( vname ) // + & '" from file "' // TRIM( E2C_CHEM ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + +#ifdef m3dry_opt + + Allocate ( wep1 ( ncols, nrows, e2c_cats ), + & wep2 ( ncols, nrows, e2c_cats ), + & dep2 ( ncols, nrows, e2c_cats ), + & STAT=STAT ) + + vname = 'L1_SW' + If ( .Not. Xtract3 (E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, wep1)) Then + MESG = 'Could not read "' // TRIM( vname ) // + & '" from file "' // TRIM( E2C_CHEM ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L2_SW' + If ( .Not. Xtract3 (E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, wep2)) Then + MESG = 'Could not read "' // TRIM( vname ) // + & '" from file "' // TRIM( E2C_CHEM ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L2_DEP' + If ( .Not. Xtract3 (E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, dep2)) Then + MESG = 'Could not read "' // TRIM( vname ) // + & '" from file "' // TRIM( E2C_CHEM ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If +#else +#ifdef stage_opt + Allocate( Nit1 ( ncols,nrows,e2c_cats ), + & Nit2 ( ncols,nrows,e2c_cats ), + & L1_ON ( ncols,nrows,e2c_cats ), + & L2_ON ( ncols,nrows,e2c_cats ), + & BDc1 ( ncols,nrows,e2c_cats ), + & BDc2 ( ncols,nrows,e2c_cats ), + & STAT=STAT ) + + vname = 'L1_NITR' + If ( .Not. Xtract3 (E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, Nit1 ) ) Then + Write( mesg,9001 ) vname, E2C_CHEM + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L2_NITR' + If ( .Not. Xtract3 (E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, Nit2 ) ) Then + Write( mesg,9001 ) vname, E2C_CHEM + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L1_ON' + If ( .Not. Xtract3 (E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, L1_ON ) ) Then + Write( mesg,9001 ) vname, E2C_CHEM + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L2_ON' + If ( .Not. Xtract3 (E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, L2_ON ) ) Then + Write( mesg,9001 ) vname, E2C_CHEM + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L1_BD' + If ( .Not. Xtract3 (E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, BDc1 ) ) Then + Write( mesg,9001 ) vname, E2C_CHEM + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L2_BD' + If ( .Not. Xtract3 (E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, BDc2 ) ) Then + Write( mesg,9001 ) vname, E2C_CHEM + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + If ( GMN_AVAIL ) Then ! Using Fest-C 1.4 output + Allocate( GMN ( ncols,nrows,e2c_cats ), STAT = STAT ) + If ( STAT .Ne. 0 ) Then + mesg = 'Failure allocating GMN' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'GMN' + If ( .Not. Xtract3 (E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, GMN ) ) Then + Write( mesg,9001 ) vname, E2C_CHEM + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + End If + + Allocate( gamma1 ( ncols,nrows ), + & gamma2 ( ncols,nrows ), + & F1_NH4 ( ncols,nrows,e2c_cats ), + & F2_NH4 ( ncols,nrows,e2c_cats ), + & STAT=STAT ) + + if ( MEDC_AVAIL ) then + call subhfile ( INIT_MEDC_1, gxoff, gyoff, + & startcol, endcol, startrow, endrow ) + + vname = 'Gamma1' + If ( .Not. Xtract3 ( INIT_MEDC_1, vname, 1, 1, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, gamma1 ) ) Then + Write( mesg,9001 ) vname, INIT_MEDC_1 + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'Gamma2' + If ( .Not. Xtract3 ( INIT_MEDC_1, vname, 1, 1, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, gamma2 ) ) Then + Write( mesg,9001 ) vname, INIT_MEDC_1 + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L1_ANH3' + If ( .Not. Xtract3 ( E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, F1_NH4 ) ) Then + Write( mesg,9001 ) vname, E2C_CHEM + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L2_ANH3' + If ( .Not. Xtract3 ( E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, F2_NH4 ) ) Then + Write( mesg,9001 ) vname, E2C_CHEM + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + If( .not. GMN_AVAIL ) Then + + Allocate( L1_ON_Yest ( ncols,nrows,e2c_cats ), + & L2_ON_Yest ( ncols,nrows,e2c_cats ), + & F1_ON ( ncols,nrows,e2c_cats ), + & F2_ON ( ncols,nrows,e2c_cats ), + & STAT = STAT ) + If ( STAT .Ne. 0 ) Then + mesg = 'Failure allocating organic N vars' + Call M3EXIT( PNAME, 0, 0, mesg, XSTAT1 ) + End If + + If( MOD(cio_model_sdate,1000) .Eq. 1 ) Then + If( MOD(cio_model_sdate,4000) .Eq. 0 .And. + & MOD(cio_model_sdate,100000) .Ne. 0 ) Then + jdate_yest = (INT(cio_model_sdate/1000)-1)*1000+366 + Else If( MOD(cio_model_sdate,400000) .Eq. 0) Then + jdate_yest = (INT(cio_model_sdate/1000)-1)*1000+366 + Else ! not a leap year + jdate_yest = (INT(cio_model_sdate/1000)-1)*1000+365 + End If + Else + jdate_yest = cio_model_sdate-1 + End If + + If ( .Not. Open3( E2C_CHEM_YEST, fsread3, pname ) ) Then + mesg = 'Could not open '// E2C_CHEM_YEST // ' file' + Call M3exit ( pname, 0, 0, mesg, xstat1 ) + End If + n_opened_file = n_opened_file + 1 + + IF ( .NOT. DESC3( E2C_CHEM_YEST ) ) THEN + MESG = 'Could not get description of file "' // + & TRIM( E2C_CHEM_YEST ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + + call subhfile ( E2C_CHEM, gxoff, gyoff, + & startcol, endcol, startrow, endrow ) + + vname = 'L1_AON' + If ( .Not. Xtract3 (E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, F1_ON ) ) Then + Write( mesg,9001 ) vname, E2C_CHEM + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L2_AON' + If ( .Not. Xtract3 (E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, F2_ON ) ) Then + Write( mesg,9001 ) vname, E2C_CHEM + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + call subhfile ( E2C_CHEM_YEST, gxoff, gyoff, + & startcol, endcol, startrow, endrow ) + + vname = 'L1_ON' + If ( .Not. Xtract3 (E2C_CHEM_YEST, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, jdate_yest, 0, L1_ON_Yest ) ) Then + Write( mesg,9001 ) vname, E2C_CHEM + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L2_ON' + If ( .Not. Xtract3 (E2C_CHEM_YEST, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, jdate_yest, 0, L2_ON_Yest ) ) Then + Write( mesg,9001 ) vname, E2C_CHEM + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + end if ! .not. GMN_AVAIL + end if ! MEDC_AVAIL + +9001 Format( 'Failure reading ', a, 1x, 'from ', a ) + +#endif ! end if stage option +#endif ! end if m3dry option + + end subroutine depv_data_setup + +! ------------------------------------------------------------------------- + subroutine medc_file_setup + + USE UTILIO_DEFN + use bidi_mod + + INCLUDE SUBST_FILES_ID ! file name parameters + + Character( 40 ), parameter :: pname = 'medc_file_setup' + + CHARACTER( 256 ) :: xmsg + integer :: v + integer :: startcol, endcol, startrow, endrow, gxoff, gyoff + + CALL INIT_BIDI( ) + + IF ( .NOT. OPEN3( INIT_MEDC_1, FSREAD3, PNAME ) ) THEN + XMSG = 'Open failure for ' // INIT_MEDC_1 + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + n_opened_file = n_opened_file + 1 + + call subhfile ( INIT_MEDC_1, gxoff, gyoff, + & startcol, endcol, startrow, endrow ) + + DO v = 1, Hg_TOT + IF ( .NOT. Xtract3( INIT_MEDC_1, MEDIA_NAMES( V ), 1, 1, + & startrow, endrow, startcol, endcol, + & cio_model_sdate, 0, CMEDIA(:,:,v) ) )THEN + xmsg = 'Could not read ' // trim( MEDIA_NAMES( V ) ) + & // ' from ' // trim( INIT_MEDC_1 ) + call m3exit( pname, cio_model_sdate, 0, xmsg, xstat1 ) + END IF + END DO + + end subroutine medc_file_setup + +! ------------------------------------------------------------------------- + subroutine soilinp_setup + + USE UTILIO_DEFN + use HGRD_DEFN, only : ncols, nrows + use RUNTIME_VARS, only : NEW_START,BIOGEMIS_MEGAN,BIOGEMIS_BEIS, + & BDSNP_MEGAN,IGNORE_SOILINP + + + INCLUDE SUBST_FILES_ID ! file name parameters + + integer, parameter :: mxhrs = 24 + Character( 40 ), parameter :: pname = 'soilinp_setup' + Character( 40 ), parameter :: msoilinp = 'MEGAN_SOILINP' + Character( 40 ), parameter :: bsoilinp = 'BEIS_SOILINP' + Character( 40 ), parameter :: bdsnpinp = 'BDSNPINP' + + CHARACTER( 16 ) :: var + CHARACTER( 256 ) :: mesg + integer :: stat, i, j, k + real t24sum(ncols,nrows),sw24sum(ncols,nrows) + + ALLOCATE( PTYPE( NCOLS,NROWS ), + & PULSEDATE( NCOLS,NROWS ), + & PULSETIME( NCOLS,NROWS ), + & RAINFALL( NCOLS,NROWS, mxhrs ), + & DDTTM( mxhrs ), + & STAT=STAT ) + + DDTTM = ' ' ! array + + if (BIOGEMIS_MEGAN) then + ALLOCATE (t24y ( ncols,nrows ), + & sw24y ( ncols,nrows ), + & lai_y ( ncols,nrows ), + & HRNO_SW ( NCOLS,NROWS, mxhrs ), + & HRNO_T2M ( NCOLS,NROWS, mxhrs ), + & stat=stat) + if (BDSNP_MEGAN) then + ALLOCATE (PFACTOR ( ncols,nrows ), + & DRYPERIOD ( ncols,nrows ), + & NDEPRES ( ncols,nrows ), + & NDEPRATE ( ncols,nrows ), + & SOILMPREV ( ncols,nrows ), + & stat=stat) + pfactor = 0.0 + dryperiod = 0.0 + soilmprev = 0.0 + ndepres =0.0 + ndeprate =0.0 + end if + + IF ( STAT .NE. 0 ) THEN + MESG = 'Failure BIOGEMIS_MEGAN arrays' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT3 ) + END IF + end if + + + if (BIOGEMIS_BEIS .and. .not. NEW_START .and. .not. IGNORE_SOILINP) then + IF ( .NOT. OPEN3( BSOILINP, FSREAD3, PNAME ) ) THEN + mesg = 'Open failure for ' // BSOILINP + Call M3EXIT( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + n_opened_file = n_opened_file + 1 + +! Get description of NO rain data file + IF ( .NOT. DESC3( BSOILINP ) ) THEN + MESG = 'Could not get description of file "' // + & TRIM( BSOILINP ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + +! Check that the file start date and time are consistent + IF ( SDATE3D .NE. cio_model_sdate ) THEN + WRITE( MESG, 94011 ) 'Cannot use BEIS_SOILINP file; ' // + & 'found date ', SDATE3D, ' expecting ', cio_model_sdate + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + + IF ( STIME3D .NE. cio_model_stime ) THEN + WRITE( MESG, 94011 ) 'Cannot use BEIS_SOILINP file; ' // + & 'found time ', STIME3D, ' expecting ', cio_model_stime + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + +94011 FORMAT( A, F10.2, 1X, A, I3, ',', I3 ) + + VAR = 'PTYPE' + IF ( .NOT. XTRACT3( BSOILINP, 'PTYPE', 1, 1, + & STRTROWSTD, ENDROWSTD, STRTCOLSTD, ENDCOLSTD, + & 0, 0, PTYPE ) ) THEN + MESG = 'Could not read "' // TRIM( VAR ) // + & '" from file "' // TRIM( BSOILINP ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + + VAR = 'PULSEDATE' + IF ( .NOT. XTRACT3( BSOILINP, VAR, 1, 1, + & STRTROWSTD, ENDROWSTD, STRTCOLSTD, ENDCOLSTD, + & 0, 0, PULSEDATE ) ) THEN + MESG = 'Could not read "' // TRIM( VAR ) // + & '" from file "' // TRIM( BSOILINP ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + + VAR = 'PULSETIME' + IF ( .NOT. XTRACT3( BSOILINP, VAR, 1, 1, + & STRTROWSTD, ENDROWSTD, STRTCOLSTD, ENDCOLSTD, + & 0, 0, PULSETIME ) ) THEN + MESG = 'Could not read "' // TRIM( VAR ) // + & '" from file "' // TRIM( BSOILINP ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + + + RAINFALL = 0.0 + + DDTTM = ' ' ! array + DO I = 1, mxhrs + WRITE( VAR, '(A8,I2.2)' ) 'RAINFALL', I + IF ( .NOT. XTRACT3( BSOILINP, VAR, 1, 1, + & STRTROWSTD, ENDROWSTD, STRTCOLSTD, ENDCOLSTD, + & 0, 0, RAINFALL( :,:,I ) ) ) THEN + MESG = 'Could not read "' // TRIM( VAR ) // + & '" from file "' // TRIM( BSOILINP ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + J = INDEX( VDESC3D( I+3 ), 'for' ) + 3 + K = LEN_TRIM( VDESC3D( I+3 ) ) + DDTTM( I ) = VDESC3D( I+3 )( J:K ) + END DO + + end if ! end beis section + + + if (BIOGEMIS_MEGAN .and. .not. NEW_START .and. .not. IGNORE_SOILINP) then + + IF ( .NOT. OPEN3( MSOILINP, FSREAD3, PNAME ) ) THEN + mesg = 'Open failure for ' // MSOILINP + Call M3EXIT( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + n_opened_file = n_opened_file + 1 + +! Get description of NO rain data file + IF ( .NOT. DESC3( MSOILINP ) ) THEN + MESG = 'Could not get description of file "' // + & TRIM( MSOILINP ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + +! Check that the file start date and time are consistent + IF ( SDATE3D .NE. cio_model_sdate ) THEN + WRITE( MESG, 94010 ) 'Cannot use MEGAN_SOILINP file; ' // + & 'found date ', SDATE3D, ' expecting ', cio_model_sdate + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + + IF ( STIME3D .NE. cio_model_stime ) THEN + WRITE( MESG, 94010 ) 'Cannot use MEGAN_SOILINP file; ' // + & 'found time ', STIME3D, ' expecting ', cio_model_stime + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + +94010 FORMAT( A, F10.2, 1X, A, I3, ',', I3 ) + + VAR = 'PTYPE' + IF ( .NOT. XTRACT3( MSOILINP, 'PTYPE', 1, 1, + & STRTROWSTD, ENDROWSTD, STRTCOLSTD, ENDCOLSTD, + & 0, 0, PTYPE ) ) THEN + MESG = 'Could not read "' // TRIM( VAR ) // + & '" from file "' // TRIM( MSOILINP ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + + VAR = 'PULSEDATE' + IF ( .NOT. XTRACT3( MSOILINP, VAR, 1, 1, + & STRTROWSTD, ENDROWSTD, STRTCOLSTD, ENDCOLSTD, + & 0, 0, PULSEDATE ) ) THEN + MESG = 'Could not read "' // TRIM( VAR ) // + & '" from file "' // TRIM( MSOILINP ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + + VAR = 'PULSETIME' + IF ( .NOT. XTRACT3( MSOILINP, VAR, 1, 1, + & STRTROWSTD, ENDROWSTD, STRTCOLSTD, ENDCOLSTD, + & 0, 0, PULSETIME ) ) THEN + MESG = 'Could not read "' // TRIM( VAR ) // + & '" from file "' // TRIM( MSOILINP ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + + sw24sum = 0.0 + t24sum = 0.0 + lai_y = 0.0 + RAINFALL = 0.0 + + DDTTM = ' ' ! array + DO I = 1, mxhrs + WRITE( VAR, '(A8,I2.2)' ) 'RAINFALL', I + IF ( .NOT. XTRACT3( MSOILINP, VAR, 1, 1, + & STRTROWSTD, ENDROWSTD, STRTCOLSTD, ENDCOLSTD, + & 0, 0, RAINFALL( :,:,I ) ) ) THEN + MESG = 'Could not read "' // TRIM( VAR ) // + & '" from file "' // TRIM( MSOILINP ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + J = INDEX( VDESC3D( I+3 ), 'for' ) + 3 + K = LEN_TRIM( VDESC3D( I+3 ) ) + DDTTM( I ) = VDESC3D( I+3 )( J:K ) + + WRITE( VAR, '(A2,I2.2)' ) 'SW', I + IF ( .NOT. XTRACT3( MSOILINP, VAR, 1, 1, + & STRTROWSTD, ENDROWSTD, STRTCOLSTD,ENDCOLSTD, + & 0, 0, sw24y( :,: ) ) ) THEN + MESG = 'Could not read "' // TRIM( VAR ) // + & '" from file "' // TRIM( MSOILINP ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + sw24sum = sw24y + sw24sum + + WRITE( VAR, '(A3,I2.2)' ) 'T2M', I + IF ( .NOT. XTRACT3( MSOILINP, VAR, 1, 1, + & STRTROWSTD, ENDROWSTD, STRTCOLSTD,ENDCOLSTD, + & 0, 0, t24y( :,: ) ) ) THEN + MESG = 'Could not read "' // TRIM( VAR ) // + & '" from file "' // TRIM( MSOILINP ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + t24sum = t24y + t24sum + + END DO ! looping over 24 hrs + + sw24y = sw24sum/mxhrs + t24y = t24sum/mxhrs + + IF ( .NOT. XTRACT3( MSOILINP, 'LAI', 1, 1, + & STRTROWSTD, ENDROWSTD, STRTCOLSTD,ENDCOLSTD, + & 0, 0, lai_y( :,: ) ) ) THEN + MESG = 'Could not read "' // 'LAI' // + & '" from file "' // TRIM( MSOILINP ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + + if (BDSNP_MEGAN) then + ! BDSNP daily inputs + + IF ( .NOT. OPEN3( BDSNPINP, FSREAD3, PNAME ) ) THEN + mesg = 'Open failure for ' // BDSNPINP + Call M3EXIT( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + + IF ( .NOT. DESC3( BDSNPINP ) ) THEN + MESG = 'Could not get description of file "' // + & TRIM( BDSNPINP ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT1 ) + END IF + IF ( .NOT. XTRACT3( BDSNPINP, 'DRYPERIOD', + & 1, 1, STRTROWSTD, ENDROWSTD, STRTCOLSTD,ENDCOLSTD, + & 0, 0, dryperiod(:,:) ) ) THEN + mesg = 'Could not extract ' // BDSNPINP // ' file' + CALL M3EXIT ( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + IF ( .NOT. XTRACT3( BDSNPINP, 'NDEPRES', + & 1, 1, STRTROWSTD, ENDROWSTD, STRTCOLSTD,ENDCOLSTD, + & 0, 0, ndepres(:,:) ) ) THEN + mesg = 'Could not extract ' // BDSNPINP // ' file' + CALL M3EXIT ( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + IF ( .NOT. XTRACT3( BDSNPINP, 'NDEPRATE_DIAG', + & 1, 1, STRTROWSTD, ENDROWSTD, STRTCOLSTD,ENDCOLSTD, + & 0, 0, ndeprate(:,:) ) ) THEN + mesg = 'Could not extract ' // BDSNPINP // ' file' + CALL M3EXIT ( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + IF ( .NOT. XTRACT3( BDSNPINP, 'PFACTOR', + & 1, 1, STRTROWSTD, ENDROWSTD, STRTCOLSTD,ENDCOLSTD, + & 0, 0, pfactor(:,:) ) ) THEN + mesg = 'Could not extract ' // BDSNPINP // ' file' + CALL M3EXIT ( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + IF ( .NOT. XTRACT3( BDSNPINP, 'SOILMPREV', + & 1, 1, STRTROWSTD, ENDROWSTD,STRTCOLSTD,ENDCOLSTD, + & 0, 0, soilmprev(:,:) ) ) THEN + mesg = 'Could not extract ' // BDSNPINP // ' file' + CALL M3EXIT ( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + + + end if ! bdsnp check + end if ! megan check + + + end subroutine soilinp_setup + +! ------------------------------------------------------------------------- + subroutine retrieve_grid_cro_2d_data + + USE UTILIO_DEFN + USE HGRD_DEFN + USE LSM_Mod, ONLY: n_lufrac, init_lsm + + INCLUDE SUBST_FILES_ID ! file name parameters + + Character( 40 ), parameter :: pname = 'retrieve_grid_cro_2d_data' + integer :: gxoff, gyoff, + & STRTCOLGC2, ENDCOLGC2, STRTROWGC2, ENDROWGC2 + + CHARACTER( 120 ) :: XMSG = ' ' + Character( 16 ) :: vname + INTEGER :: STAT, L + + allocate (MSFX2(ncols, nrows), + & LWMASK(ncols, nrows), + & HT(ncols, nrows), + & LAT(ncols, nrows), + & LON(ncols, nrows), + & PURB(ncols, nrows), + & STAT=STAT) + IF ( STAT .NE. 0 ) THEN + XMSG = 'Failure allocating MSFX2 or other arrays' + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT3 ) + END IF + + CALL SUBHFILE ( GRID_CRO_2D, GXOFF, GYOFF, + & STRTCOLGC2, ENDCOLGC2, STRTROWGC2, ENDROWGC2 ) + +#ifdef twoway + IF ( .NOT. INTERPX( GRID_CRO_2D, 'MSFX2', PNAME, + & STRTCOLGC2, ENDCOLGC2, STRTROWGC2, ENDROWGC2, 1, 1, + & 0, 0, MSFX2 ) ) THEN + XMSG = ' Error interpolating variable MSFX2 from ' // GRID_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + IF ( .NOT. INTERPX( GRID_CRO_2D, 'LWMASK', PNAME, + & STRTCOLGC2, ENDCOLGC2, STRTROWGC2, ENDROWGC2, 1, 1, + & 0, 0, LWMASK ) ) THEN + XMSG = ' Error interpolating variable LWMASK from ' // GRID_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + IF ( .NOT. INTERPX( GRID_CRO_2D, 'HT', PNAME, + & STRTCOLGC2, ENDCOLGC2, STRTROWGC2, ENDROWGC2, 1, 1 , + & 0, 0, HT ) ) THEN + XMSG = ' Error interpolating variable HT from ' // GRID_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + IF ( .NOT. INTERPX( GRID_CRO_2D, 'LAT', PNAME, + & STRTCOLGC2, ENDCOLGC2, STRTROWGC2, ENDROWGC2, 1, 1 , + & 0, 0, LAT ) ) THEN + XMSG = ' Error interpolating variable LAT from ' // GRID_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + IF ( .NOT. INTERPX( GRID_CRO_2D, 'LON', PNAME, + & STRTCOLGC2, ENDCOLGC2, STRTROWGC2, ENDROWGC2, 1, 1 , + & 0, 0, LON ) ) THEN + XMSG = ' Error interpolating variable LON from ' // GRID_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + if (minkz) then + IF ( .NOT. INTERPX( GRID_CRO_2D, 'PURB', PNAME, + & STRTCOLGC2, ENDCOLGC2, STRTROWGC2, ENDROWGC2, 1, 1 , + & 0, 0, PURB ) ) THEN + XMSG = ' Error interpolating variable PURB from ' // GRID_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + else + purb = 0.0 + end if + + IF ( .NOT. LUCRO_AVAIL ) THEN + + CALL INIT_LSM( 0, 0 ) + + allocate (LUFRAC(ncols, nrows, n_lufrac), STAT=STAT) + IF ( STAT .NE. 0 ) THEN + XMSG = 'Failure allocating LUFRAC array' + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT3 ) + END IF + + DO l = 1, n_lufrac + Write( vname,'( "LUFRAC_",I2.2 )' ) l + IF ( .Not. INTERPX( GRID_CRO_2D, VNAME, PNAME, + & STRTCOLGC2, ENDCOLGC2, STRTROWGC2, ENDROWGC2, 1, 1, + & 0, 0, LUFRAC( :,:,l ) ) ) THEN + XMSG = 'Error interpolating variable' // TRIM( VNAME ) // ' from ' // GRID_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + END DO + + END IF + +#else + IF ( .NOT. XTRACT3( GRID_CRO_2D, 'MSFX2', + & 1, 1, STRTROWGC2, ENDROWGC2, STRTCOLGC2, ENDCOLGC2, + & 0, 0, MSFX2 ) ) THEN + XMSG = ' Error interpolating variable MSFX2 from ' // GRID_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + IF ( .NOT. XTRACT3( GRID_CRO_2D, 'LWMASK', + & 1, 1, STRTROWGC2, ENDROWGC2, STRTCOLGC2, ENDCOLGC2, + & 0, 0, LWMASK ) ) THEN + XMSG = ' Error interpolating variable LWMASK from ' // GRID_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + IF ( .NOT. XTRACT3( GRID_CRO_2D, 'HT', + & 1, 1, STRTROWGC2, ENDROWGC2, STRTCOLGC2, ENDCOLGC2, + & 0, 0, HT ) ) THEN + XMSG = ' Error interpolating variable HT from ' // GRID_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + IF ( .NOT. XTRACT3( GRID_CRO_2D, 'LAT', + & 1, 1, STRTROWGC2, ENDROWGC2, STRTCOLGC2, ENDCOLGC2, + & 0, 0, LAT ) ) THEN + XMSG = ' Error interpolating variable LAT from ' // GRID_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + IF ( .NOT. XTRACT3( GRID_CRO_2D, 'LON', + & 1, 1, STRTROWGC2, ENDROWGC2, STRTCOLGC2, ENDCOLGC2, + & 0, 0, LON ) ) THEN + XMSG = ' Error interpolating variable LON from ' // GRID_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + if (minkz) then + IF ( .NOT. XTRACT3( GRID_CRO_2D, 'PURB', + & 1, 1, STRTROWGC2, ENDROWGC2, STRTCOLGC2, ENDCOLGC2, + & 0, 0, PURB ) ) THEN + XMSG = ' Error interpolating variable PURB from ' // GRID_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + else + purb = 0.0 + end if + + IF ( .NOT. LUCRO_AVAIL ) THEN + + CALL INIT_LSM( 0, 0 ) + + allocate (LUFRAC(ncols, nrows, n_lufrac), STAT=STAT) + IF ( STAT .NE. 0 ) THEN + XMSG = 'Failure allocating LUFRAC array' + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT3 ) + END IF + + DO l = 1, n_lufrac + Write( vname,'( "LUFRAC_",I2.2 )' ) l + IF ( .Not. XTRACT3( GRID_CRO_2D, VNAME, + & 1, 1, STRTROWGC2, ENDROWGC2, STRTCOLGC2, ENDCOLGC2, + & 0, 0, LUFRAC( :,:,l ) ) ) THEN + XMSG = 'Error interpolating variable' // TRIM( VNAME ) // ' from ' // GRID_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + END DO + + END IF +#endif + end subroutine retrieve_grid_cro_2d_data + +! ------------------------------------------------------------------------- + subroutine retrieve_grid_dot_2d_data + + USE UTILIO_DEFN + USE HGRD_DEFN + + INCLUDE SUBST_FILES_ID ! file name parameters + + Character( 40 ), parameter :: pname = 'retrieve_grid_dot_2d_data' + + INTEGER :: STAT + CHARACTER( 120 ) :: XMSG = ' ' + INTEGER :: gxoff, gyoff, + & STRTCOLGD2, ENDCOLGD2, STRTROWGD2, ENDROWGD2 + + ALLOCATE ( MSFD2( NCOLS+1, NROWS+1 ), STAT = STAT ) + IF ( STAT .NE. 0 ) THEN + XMSG = 'Failure allocating MSFD2 array' + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT3 ) + END IF + + CALL SUBHFILE ( GRID_DOT_2D, GXOFF, GYOFF, + & STRTCOLGD2, ENDCOLGD2, STRTROWGD2, ENDROWGD2 ) + +#ifdef twoway + IF ( .NOT. INTERPX( GRID_DOT_2D, 'MSFD2', PNAME, + & STRTCOLGD2, ENDCOLGD2, STRTROWGD2, ENDROWGD2, 1, 1, + & 0, 0, MSFD2 ) ) THEN + XMSG = 'Could not interpolate MSFD2 from ' // GRID_DOT_2D + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF +#else + IF ( .NOT. XTRACT3( GRID_DOT_2D, 'MSFD2', + & 1, 1, STRTROWGD2, ENDROWGD2, STRTCOLGD2, ENDCOLGD2, + & 0, 0, MSFD2 ) ) THEN + XMSG = 'Could not interpolate MSFD2 from ' // GRID_DOT_2D + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF +#endif + end subroutine retrieve_grid_dot_2d_data + +! ------------------------------------------------------------------------- + subroutine retrieve_ocean_data + + USE RXNS_DATA, ONLY : MECHNAME + USE UTILIO_DEFN + USE HGRD_DEFN + + INCLUDE SUBST_FILES_ID ! file name parameters + + Character( 40 ), parameter :: pname = 'retrieve_ocean_data' + integer :: startcol, endcol, startrow, endrow, gxoff, gyoff + + INTEGER :: STAT + CHARACTER( 120 ) :: XMSG = ' ' + + allocate (ocean(ncols, nrows), + & szone(ncols, nrows), + & chlr(ncols, nrows), + & dmsl(ncols, nrows), + & STAT=STAT) + IF ( STAT .NE. 0 ) THEN + XMSG = 'Failure allocating OPEN, SURF, CHLO, DMS array' + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT3 ) + END IF + + IF ( .NOT. OCEAN_CHEM ) THEN + + WRITE( LOGDEV, '(/,5x,A,/,5x,A,/5x,A)' ), + & 'CTM_OCEAN_CHEM set to FALSE. Open ocean and surf zone', + & 'fractions will be set to 0. There will be no oceanic', + & 'halogen-mediated loss of ozone, dms chemistry, or sea spray aerosol emissions.' + ocean = 0.0 + szone = 0.0 + dmsl = 0.0 + chlr = 0.0 + + If ( INDEX( MECHNAME, 'CB6R5M_AE7_AQ' ) .GT. 0 ) then + XMSG = 'CTM_OCEAN_CHEM must be set to TRUE when using CB6R5M_AE7_AQ mechanism' + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + endif + + ELSEIF ( OCEAN_CHEM .AND. .NOT. USE_MARINE_GAS_EMISSION ) THEN + + IF ( .NOT. OPEN3( OCEAN_1, FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open ' // OCEAN_1 + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + ELSE + n_opened_file = n_opened_file + 1 + + call subhfile ( OCEAN_1, gxoff, gyoff, + & startcol, endcol, startrow, endrow ) + + IF ( .NOT. XTRACT3( OCEAN_1, 'OPEN', + & 1, 1, startrow, endrow, startcol, endcol, + & 0, 0, ocean ) ) Then + XMSG = 'Could not read OPEN from ' // OCEAN_1 + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + IF ( .NOT. XTRACT3( OCEAN_1, 'SURF', + & 1, 1, startrow, endrow, startcol, endcol, + & 0, 0, szone ) ) Then + XMSG = 'Could not interpolate SURF from ' // OCEAN_1 + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + WHERE ( ocean .LT. 0.001 ) ocean = 0.0 ! ensure values are nonnegative and greater than 0.001 + WHERE ( szone .LT. 0.001 ) szone = 0.0 ! ensure values are nonnegative and greater than 0.001 + + dmsl = 0.0 + chlr = 0.0 + + ENDIF + + ELSEIF ( OCEAN_CHEM .AND. USE_MARINE_GAS_EMISSION ) THEN + + IF ( .NOT. OPEN3( OCEAN_1, FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open ' // OCEAN_1 + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + ELSE + n_opened_file = n_opened_file + 1 + + call subhfile ( OCEAN_1, gxoff, gyoff, + & startcol, endcol, startrow, endrow ) + + IF ( .NOT. XTRACT3( OCEAN_1, 'OPEN', + & 1, 1, startrow, endrow, startcol, endcol, + & 0, 0, ocean ) ) Then + XMSG = 'Could not read OPEN from ' // OCEAN_1 + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + IF ( .NOT. XTRACT3( OCEAN_1, 'SURF', + & 1, 1, startrow, endrow, startcol, endcol, + & 0, 0, szone ) ) Then + XMSG = 'Could not interpolate SURF from ' // OCEAN_1 + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + WHERE ( ocean .LT. 0.001 ) ocean = 0.0 ! ensure values are nonnegative and greater than 0.001 + WHERE ( szone .LT. 0.001 ) szone = 0.0 ! ensure values are nonnegative and greater than 0.001 + + If ( INDEX( MECHNAME, 'CB6R5M_AE7_AQ' ) .GT. 0 ) then + + If ( .Not. XTRACT3( OCEAN_1, 'CHLO', + & 1, 1, startrow, endrow, startcol, endcol, + & 0, 0, chlr ) ) Then + XMSG = 'Could not read CHLO from ' // OCEAN_1 + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + End If + + If ( .Not. XTRACT3( OCEAN_1, 'DMS', + & 1, 1, startrow, endrow, startcol, endcol, + & 0, 0, dmsl ) ) Then + XMSG = 'Could not read DMS from ' // OCEAN_1 + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + End If + + ELSEIF ( INDEX( MECHNAME, 'CB6R5_AE7_AQ' ) .GT. 0 ) then + + chlr = 0.0 + + If ( .Not. XTRACT3( OCEAN_1, 'DMS', + & 1, 1, startrow, endrow, startcol, endcol, + & 0, 0, dmsl ) ) Then + XMSG = 'Could not read DMS from ' // OCEAN_1 + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + End If + + END IF + + END IF + END IF + + end subroutine retrieve_ocean_data + +! ------------------------------------------------------------------------- + subroutine retrieve_ltng_param_data + + USE UTILIO_DEFN + USE HGRD_DEFN + + INCLUDE SUBST_FILES_ID ! file name parameters + + Character( 40 ), parameter :: pname = 'retrieve_ltng_param_data' + Character( 40 ), parameter :: LTNGPARMS_FILE = 'LTNGPARMS_FILE' + + INTEGER :: STAT + CHARACTER( 120 ) :: XMSG = ' ' + integer :: startcol, endcol, startrow, endrow, gxoff, gyoff + + allocate (OCEAN_MASK(ncols, nrows), + & SLOPE(ncols, nrows), + & INTERCEPT(ncols, nrows), + & SLOPE_lg(ncols, nrows), + & INTERCEPT_lg(ncols, nrows), + & ICCG_SUM(ncols, nrows), + & ICCG_WIN(ncols, nrows), + & STAT=STAT) + IF ( STAT .NE. 0 ) THEN + XMSG = 'Failure allocating ltng parameter arrays' + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT3 ) + END IF + + IF ( .NOT. OPEN3( LTNGPARMS_FILE, FSREAD3, PNAME ) ) THEN + XMSG = 'Open failure for ' // LTNGPARMS_FILE + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + n_opened_file = n_opened_file + 1 + + call subhfile ( LTNGPARMS_FILE, gxoff, gyoff, + & startcol, endcol, startrow, endrow ) + + IF ( .NOT. XTRACT3( LTNGPARMS_FILE, "OCNMASK", 1, 1, + & startrow, endrow, startcol, endcol, + & 0, 0, OCEAN_MASK ) ) Then + XMSG = 'Could not interpolate OPEN from ' // LTNGPARMS_FILE + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + End If + + IF ( .NOT. XTRACT3( LTNGPARMS_FILE, "SLOPE", 1, 1, + & startrow, endrow, startcol, endcol, + & 0, 0, SLOPE ) ) Then + XMSG = 'Could not interpolate OPEN from ' // LTNGPARMS_FILE + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + End If + + IF ( .NOT. XTRACT3( LTNGPARMS_FILE, "INTERCEPT", 1, 1, + & startrow, endrow, startcol, endcol, + & 0, 0, INTERCEPT ) ) Then + XMSG = 'Could not interpolate OPEN from ' // LTNGPARMS_FILE + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + End If + + IF ( .NOT. XTRACT3( LTNGPARMS_FILE, "SLOPE_lg", 1, 1, + & startrow, endrow, startcol, endcol, + & 0, 0, SLOPE_lg ) ) Then + XMSG = 'Could not interpolate OPEN from ' // LTNGPARMS_FILE + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + End If + + IF ( .NOT. XTRACT3( LTNGPARMS_FILE, "INTERCEPT_lg", 1, 1, + & startrow, endrow, startcol, endcol, + & 0, 0, INTERCEPT_lg ) ) Then + XMSG = 'Could not interpolate OPEN from ' // LTNGPARMS_FILE + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + End If + + IF ( .NOT. XTRACT3( LTNGPARMS_FILE, "ICCG_SUM", 1, 1, + & startrow, endrow, startcol, endcol, + & 0, 0, ICCG_SUM ) ) Then + XMSG = 'Could not interpolate OPEN from ' // LTNGPARMS_FILE + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + End If + + IF ( .NOT. XTRACT3( LTNGPARMS_FILE, "ICCG_WIN", 1, 1, + & startrow, endrow, startcol, endcol, + & 0, 0, ICCG_WIN ) ) Then + XMSG = 'Could not interpolate OPEN from ' // LTNGPARMS_FILE + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + End If + + end subroutine retrieve_ltng_param_data + +! ------------------------------------------------------------------------- + subroutine retrieve_boundary_data (jdate, jtime, vname) + + USE UTILIO_DEFN + USE HGRD_DEFN + USE VGRD_DEFN, ONLY : NLAYS + USE CGRID_SPCS + + INCLUDE SUBST_FILES_ID ! file name parameters + + integer, intent(in) :: jdate, jtime + character (*), intent(in), optional :: vname + + Character( 40 ), parameter :: pname = 'retrieve_boundary_data' + + LOGICAL, SAVE :: firstime = .true. + INTEGER :: STAT, i, j, begin, end, buf_loc, iterations, + & iter, loc_jdate_met, loc_jdate, loc_jtime_met, + & loc_jtime, v, beg_v, end_v + + CHARACTER( 120 ) :: XMSG = ' ' + + if (firstime) then + + head_bndy = -1 + tail_bndy = -1 + + end if ! firstime + + if (firstime) then + iterations = 2 + else + iterations = 1 + end if + + if (present(vname)) then + beg_v = binary_search (vname, cio_bndy_var_name(:,1), n_cio_bndy_vars) + end_v = beg_v + else + beg_v = 1 + end_v = n_cio_bndy_vars + end if + + loc_jdate = jdate + loc_jdate_met = jdate + loc_jtime = jtime + loc_jtime_met = jtime + + do iter = 1, iterations + do v = beg_v, end_v + buf_loc = mod((tail_bndy(v) + iter), 2) + + cio_bndy_data_tstamp(1, buf_loc, v) = loc_jdate + if (cio_bndy_var_name(v,2) == 'mb') then + cio_bndy_data_tstamp(2, buf_loc, v) = loc_jtime_met + else + cio_bndy_data_tstamp(2, buf_loc, v) = loc_jtime + end if + + begin = cio_bndy_data_inx(1,buf_loc,v) + end = cio_bndy_data_inx(2,buf_loc,v) + + if (cio_bndy_var_name(v,2) == 'mb') then +#ifdef twoway + cio_bndy_data(begin:end) = 0.0 +#else + if (.not. read3 (MET_BDY_3D, cio_bndy_var_name(v,1), -1, + & loc_jdate_met, loc_jtime_met, cio_bndy_data(begin:end) ) ) THEN + XMSG = 'Could not read ' // MET_BDY_3D // ' file' + CALL M3EXIT ( PNAME, loc_jdate_met, loc_jtime_met, XMSG, XSTAT1 ) + END IF +#endif + else if (cio_bndy_var_name(v,2) == 'bct') then + + if (.not. read3 (BCFILE, cio_bndy_var_name(v,1), -1, + & loc_jdate, loc_jtime, cio_bndy_data(begin:end) ) ) THEN + XMSG = 'Could not read ' // BCFILE // ' file' + CALL M3EXIT ( PNAME, loc_jdate, loc_jtime, XMSG, XSTAT1 ) + END IF + + else if (cio_bndy_var_name(v,2) == 'bc') then + + if (iter == 1) then + if (.not. read3 (BCFILE, cio_bndy_var_name(v,1), -1, + & loc_jdate, loc_jtime, cio_bndy_data(begin:end) ) ) THEN + XMSG = 'Could not read ' // BCFILE // ' file' + CALL M3EXIT ( PNAME, loc_jdate, loc_jtime, XMSG, XSTAT1 ) + END IF + else + cio_bndy_data_tstamp(1, buf_loc, v) = jdate + 999 ! this will ensure future never falls out of the circular buffer + end if + + else + call m3exit( 'Centralized I/O',0,0,' ==d== UNKOWNi Type of File',1 ) + end if + + end do + + CALL NEXTIME ( loc_jdate_met, loc_jtime_met, file_tstep(f_met)) + CALL NEXTIME ( loc_jdate, loc_jtime, file_tstep(f_bcon)) + + end do ! end iter + + if (firstime) then + firstime = .false. + head_bndy = 0 + tail_bndy = 1 + else + do v = beg_v, end_v + head_bndy(v) = mod(head_bndy(v)+1, 2) + tail_bndy(v) = mod(tail_bndy(v)+1, 2) + end do + end if + + end subroutine retrieve_boundary_data + +! ------------------------------------------------------------------------- + subroutine retrieve_stack_data (jdate, jtime, fname, vname) + + USE UTILIO_DEFN + USE STK_PRMS, only : MY_STRT_SRC, MY_END_SRC + + INCLUDE SUBST_FILES_ID ! file name parameters + + integer, intent(in) :: jdate, jtime + character (*), intent(in), optional :: fname, vname + + Character( 40 ), parameter :: pname = 'retrieve_stack_data' + + LOGICAL, SAVE :: firstime = .true. + INTEGER :: STAT, i, j, begin, end, buf_loc, iterations, + & iter, loc_jdate, loc_jtime, v, beg_v, end_v, + & beg_pt, end_pt, pt, fnum + + CHARACTER( 120 ) :: XMSG = ' ' + + if (firstime) then + + head_stack_emis = -1 + tail_stack_emis = -1 + + iterations = 2 + else + iterations = 1 + end if + + if (present(vname)) then + beg_pt = binary_search (fname, cio_stack_file_name, NPTGRPS) + end_pt = beg_pt + beg_v = binary_search (vname, cio_stack_var_name(:,beg_pt), n_cio_stack_emis_vars(beg_pt)) + end_v = beg_v + else + beg_pt = 1 + end_pt = NPTGRPS + end if + + do pt = beg_pt, end_pt + + if (firstime) then + loc_jdate = jdate + if (file_sym_date(f_stk_emis(pt))) loc_jdate = file_sdate(f_stk_emis(pt)) ! Representative day check + loc_jtime = jtime + else + loc_jdate = jdate + loc_jtime = jtime + end if + + if (.not. present(vname)) then + beg_v = 1 + end_v = n_cio_stack_emis_vars(pt) + end if + +! cio_stack_emis_data_inx + + do iter = 1, iterations + + do v = beg_v, end_v + buf_loc = mod((tail_stack_emis(v, pt) + iter), 2) + + cio_stack_emis_data_tstamp(1, buf_loc, v, pt) = loc_jdate + cio_stack_emis_data_tstamp(2, buf_loc, v, pt) = loc_jtime + + begin = cio_stack_emis_data_inx(1, buf_loc, v, pt) + end = cio_stack_emis_data_inx(2, buf_loc, v, pt) + + if (begin .gt. 0) then + IF ( .NOT. XTRACT3( cio_stack_file_name(pt), cio_stack_var_name(v, pt), + & 1,1, MY_STRT_SRC( pt ),MY_END_SRC( pt), 1,1, + & loc_jdate, loc_jtime, cio_stack_data(begin:end) ) ) THEN + XMSG = 'Could not extract ' // cio_stack_file_name(pt) // ' file' + CALL M3EXIT ( PNAME, loc_jdate, loc_jtime, XMSG, XSTAT1 ) + END IF + end if + end do + + CALL NEXTIME ( loc_jdate, loc_jtime, file_tstep(f_stk_emis(pt)) ) + end do ! end iter + end do + + if (firstime) then + firstime = .false. + head_stack_emis = 0 + tail_stack_emis = 1 + else + do pt = beg_pt, end_pt + do v = beg_v, end_v + head_stack_emis(v, pt) = mod(head_stack_emis(v, pt)+1, 2) + tail_stack_emis(v, pt) = mod(tail_stack_emis(v, pt)+1, 2) + end do + end do + end if + + end subroutine retrieve_stack_data + +#endif + +! ------------------------------------------------------------------------- + subroutine lus_setup + +! Function: + +! Set-up land-use categories for dust. Allocate and fill in: +! -- lut array --> landuse category fraction +! -- ladut array --> % of desertland + + + use RUNTIME_VARS +! use UTILIO_DEFN + use lus_data_module ! Data module that contains info. on different land schemes + use HGRD_DEFN, only : ncols, nrows +#ifdef twoway + use twoway_data_module +#endif + + INCLUDE SUBST_FILES_ID ! file name parameters + + character (24), parameter :: strg = 'incorrect num_land_cat, ' + character (40), parameter :: pname = 'lus_setup' + + character (256) :: xmsg + integer :: i, err, strtcol1,endcol1, strtrow1, endrow1, + & strtcol2, endcol2, strtrow2, endrow2, gxoff1, + & gyoff1, gxoff2, gyoff2 + + lufile( 1 ) = grid_cro_2d + +#ifndef mpas +! if ( .not. lucro_avail ) then ! TRUE if LUFRAC file isn't there +! +! if ( .not. open3( lufile( 1 ), fsread3, pname ) ) then +! xmsg = 'could not open ' // trim( lufile( 1 ) ) +! call m3exit ( pname, 0, 0, xmsg, xstat1 ) +! end if +! n_opened_file = n_opened_file + 1 +! +! ! Retrieve domain decomposition offsets for first lufile +! call subhfile( lufile( 1 ), gxoff1, gyoff1, strtcol1, +! & endcol1, strtrow1, endrow1 ) +! +! +! end if + +#endif + + ! determine land_scheme from GRID_CRO_2D + +#ifdef twoway + +C mminlu and num_land_cat are WRF global variables + + select case( mminlu ) + + case( 'USGS24' ) + if ( num_land_cat .ne. 24 ) then + write( xmsg, '(a, i3, a )' ) strg, num_land_cat, + & ' for ' // trim( mminlu ) + call m3exit ( pname, stdate, sttime, xmsg, xstat1 ) + end if + dust_land_scheme = 'USGS24' + case( 'NLCD40' ) + if ( num_land_cat .ne. 40 ) then + write( xmsg, '(a, i3, a )' ) strg, num_land_cat, + & ' for ' // trim( mminlu ) + call m3exit ( pname, stdate, sttime, xmsg, xstat1 ) + end if + dust_land_scheme = 'NLCD40' + case( 'NLCD-MODIS' ) + if ( num_land_cat .ne. 50 ) then + write( xmsg, '(a, i3, a )' ) strg, num_land_cat, + & ' for ' // trim( mminlu ) + call m3exit ( pname, stdate, sttime, xmsg, xstat1 ) + end if + dust_land_scheme = 'NLCD-MODIS' + case( 'MODIFIED_IGBP_MODIS_NOAH' ) + if ( num_land_cat .ne. 20 ) then + write( xmsg, '(a, i3, a )' ) strg, num_land_cat, + & ' for ' // trim( mminlu ) + call m3exit ( pname, stdate, sttime, xmsg, xstat1 ) + end if + dust_land_scheme = 'MODIS_NOAH' + case( 'MODIS' ) + if ( num_land_cat .ne. 20 ) then + write( xmsg, '(a, i3, a )' ) strg, num_land_cat, + & ' for ' // trim( mminlu ) + call m3exit ( pname, stdate, sttime, xmsg, xstat1 ) + end if + dust_land_scheme = 'MODIS' + case default + xmsg = 'Land use scheme not supported' + call m3exit ( pname, stdate, sttime, xmsg, xstat1 ) + + end select + +#else +#ifdef mpas +! dust_land_scheme = mminlu_mpas +#else + dust_land_scheme = cio_dust_land_scheme ! land scheme found from grid_cro_2D 'DLUSE' var-desc +#endif +#endif + + select case( dust_land_scheme ) ! After land scheme is determined allocate number of land use categories & number of dustland categories from lus_data_module + + case( 'USGS24' ) ! If USGS34 + n_lucat = n_lucat_usgs24 + n_dlcat = n_dlcat_usgs24 + allocate( vnmlu( n_lucat ), + & vnmld( n_dlcat ), + & dmsk( n_dlcat ), + & dmap( n_dlcat+1 ), stat = err ) + if ( err .ne. 0 ) then + xmsg = '*** Error allocating vnmlu, vnmld, dmsk or dmap' + call m3exit ( pname, stdate, sttime, xmsg, xstat1 ) + end if + vnmlu = vnmlu_usgs24 ! array assignment + vnmld = vnmld_usgs24 ! array assignment + dmsk = dmsk_usgs24 ! array assignment + dmap = dmap_usgs24 ! array assignment + + case( 'MODIS' ) ! If MODIS + n_lucat = n_lucat_modis + n_dlcat = n_dlcat_modis + allocate( vnmlu( n_lucat ), + & vnmld( n_dlcat ), + & dmsk( n_dlcat ), + & dmap( n_dlcat+1 ), stat = err ) + if ( err .ne. 0 ) then + xmsg = '*** Error allocating vnmlu, vnmld, dmsk or dmap' + call m3exit ( pname, stdate, sttime, xmsg, xstat1 ) + end if + vnmlu = vnmlu_modis ! array assignment + vnmld = vnmld_modis ! array assignment + dmsk = dmsk_modis ! array assignment + dmap = dmap_modis ! array assignment + + case( 'NLCD40' ) ! If NLCD40 + n_lucat = n_lucat_nlcd40 + n_dlcat = n_dlcat_nlcd40 + allocate( vnmlu( n_lucat ), + & vnmld( n_dlcat ), + & dmsk( n_dlcat ), + & dmap( n_dlcat+1 ), stat = err ) + if ( err .ne. 0 ) then + xmsg = '*** Error allocating vnmlu, vnmld, dmsk or dmap' + call m3exit ( pname, stdate, sttime, xmsg, xstat1 ) + end if + vnmlu = vnmlu_nlcd40 ! array assignment + vnmld = vnmld_nlcd40 ! array assignment + dmsk = dmsk_nlcd40 ! array assignment + dmap = dmap_nlcd40 ! array assignment + + case( 'NLCD-MODIS', 'NLCD50' ) ! If NCLD-MODIS or NCLD50 + n_lucat = n_lucat_nlcd_modis + n_dlcat = n_dlcat_nlcd_modis + allocate( vnmlu( n_lucat ), + & vnmld( n_dlcat ), + & dmsk( n_dlcat ), + & dmap( n_dlcat+1 ), stat = err ) + if ( err .ne. 0 ) then + xmsg = '*** Error allocating vnmlu, vnmld, dmsk or dmap' + call m3exit ( pname, stdate, sttime, xmsg, xstat1 ) + end if + vnmlu = vnmlu_nlcd_modis ! array assignment + vnmld = vnmld_nlcd_modis ! array assignment + dmsk = dmsk_nlcd_modis ! array assignment + dmap = dmap_nlcd_modis ! array assignment + + case( 'MODIS_NOAH' ) ! If MODIS-NOAH + n_lucat = n_lucat_modis_noah + n_dlcat = n_dlcat_modis_noah + allocate( vnmlu( n_lucat ), + & vnmld( n_dlcat ), + & dmsk( n_dlcat ), + & dmap( n_dlcat+1 ), stat = err ) + if ( err .ne. 0 ) then + xmsg = '*** Error allocating vnmlu, vnmld, dmsk or dmap' + call m3exit ( pname, stdate, sttime, xmsg, xstat1 ) + end if + vnmlu = vnmlu_modis_noah ! array assignment + vnmld = vnmld_modis_noah ! array assignment + dmsk = dmsk_modis_noah ! array assignment + dmap = dmap_modis_noah ! array assignment + + case default ! Other land-schemes not supported + xmsg = 'Land use scheme not supported' + call m3exit ( pname, stdate, sttime, xmsg, xstat1 ) + + end select + +! Writing Landuse categories to logfiles + write( logdev,* ) ' ' + write( logdev,* ) ' Land use scheme is ', trim( dust_land_scheme ) + write( logdev,* ) ' n_lucat,n_dlcat: ', n_lucat, n_dlcat + write( logdev,* ) ' desert land categories ------------------------' + do i = 1, n_dlcat + write( logdev,* ) ' ', trim( vnmld( i )%name ), ' ', trim( vnmld( i )%desc ) + end do + write( logdev,* ) ' land use categories ---------------------------' + do i = 1, n_lucat + write( logdev,* ) ' ', trim( vnmlu( i )%name ), ' ', trim( vnmlu( i )%desc ) + end do + write( logdev,* ) ' ' + + allocate( ladut( ncols,nrows,n_dlcat ), + & lut( ncols,nrows,n_lucat ), + & uland( ncols,nrows,4 ), stat = err ) + if ( err .ne. 0 ) then + xmsg = '*** Error allocating ladut, lut or uland' + call m3exit ( pname, stdate, sttime, xmsg, xstat1 ) + end if + + if ( .not. lucro_avail ) then ! TRUE if LUFRAC file isn't there or the land scheme is beld + +#ifdef mpas +! do i = 1, n_dlcat ! Loop through the number of desertland categories and fill in ladut array +! ladut( :,:,i) = lufrac( :,:,vnmld( i )%lu_idx ) ! Use mapped index in LUFRAC from lus_data_module to fill in ladut +! end do +! +! lut = lufrac ! landuse category fraction is lufrac that is already been extracted + +#else +! Get desert land (fraction) data (assume if BELD, all desert types are in file 1) + do i = 1, n_dlcat +#ifdef twoway + if ( .not. interpx( lufile( 1 ), vnmld( i )%name, pname, + & strtcol1, endcol1, strtrow1, endrow1, + & 1, 1, 0, 0, ladut( :,:,i ) ) ) then + xmsg = 'Could not read ' // trim( vnmld( i )%name ) + & // ' from ' // trim( lufile( 1 ) ) + call m3exit( pname, cio_model_sdate, cio_model_stime, xmsg, xstat1 ) + end if +#else + if ( .not. xtract3( lufile( 1 ), vnmld( i )%name, 1,1, + & strtrow1, endrow1,strtcol1, endcol1, + & 0, 0, ladut( :,:,i ) ) ) then + xmsg = 'Could not read ' // trim( vnmld( i )%name ) + & // ' from ' // trim( lufile( 1 ) ) + call m3exit( pname, cio_model_sdate, cio_model_stime, xmsg, xstat1 ) + end if +#endif + end do + +! Get land use (fraction) data + do i = 1, n_lucat-1 +#ifdef twoway + if ( .not. interpx( lufile( 1 ), vnmlu( i )%name, pname, + & strtcol1, endcol1, strtrow1, endrow1, + & 1, 1, 0, 0, lut( :,:,i ) ) ) then + xmsg = 'Could not read ' // trim( vnmlu( i )%name ) + & // ' from ' // trim( lufile( 1 ) ) + call m3exit( pname, cio_model_sdate, cio_model_stime, xmsg, xstat1 ) + end if +#else + if ( .not. xtract3( lufile( 1 ), vnmlu( i )%name, 1,1, + & strtrow1, endrow1,strtcol1, endcol1, + & 0, 0, lut( :,:,i ) ) ) then + xmsg = 'Could not read ' // trim( vnmlu( i )%name ) + & // ' from ' // trim( lufile( 1 ) ) + call m3exit( pname, cio_model_sdate, cio_model_stime, xmsg, xstat1 ) + end if +#endif + end do + + i = n_lucat +#ifdef twoway + if ( .not. interpx( lufile( 1 ), vnmlu( i )%name, pname, + & strtcol1, endcol1, strtrow1, endrow1, + & 1, 1, 0, 0, lut( :,:,i ) ) ) then + xmsg = 'Could not read ' // trim( vnmlu( i )%name ) + & // ' from ' // trim( lufile( 1 ) ) + call m3exit( pname, cio_model_sdate, cio_model_stime, xmsg, xstat1 ) + end if +#else + if ( .not. xtract3( lufile( 1 ), vnmlu( i )%name, 1,1, + & strtrow1, endrow1,strtcol1, endcol1, + & 0, 0, lut( :,:,i ) ) ) then + xmsg = 'Could not read ' // trim( vnmlu( i )%name ) + & // ' from ' // trim( lufile( 1 ) ) + call m3exit( pname, cio_model_sdate, cio_model_stime, xmsg, xstat1 ) + end if +#endif +#endif + + else ! IF LUFRAC is there + + do i = 1, n_dlcat ! Loop through the number of desertland categories and fill in ladut array + + ladut( :,:,i) = lufrac( :,:,vnmld( i )%lu_idx ) ! Use mapped index in LUFRAC from lus_data_module to fill in ladut + + end do + + lut = lufrac ! landuse category fraction is lufrac that is already been extracted + + end if + + end subroutine lus_setup + +! ------------------------------------------------------------------------- + + subroutine megan_setup ! reads in variables from MEGAN_PARAMS (see file_inputs.txt and run script) + use hgrd_defn, only : ncols,nrows + USE UTILIO_DEFN + use RUNTIME_VARS, only : logdev, USE_MEGAN_LAI, BDSNP_MEGAN, + & MGN_ONLN_DEP + + integer :: stat, i, megan_hr, megan_day, strtcol, + & endcol, strtrow, endrow, gxoff, gyoff + + character( 20 ) :: loc_time_stamp + real :: t24sum(ncols),sw24sum(ncols) + character( 40 ), parameter :: pname = 'megan_setup' + + character( 40 ), parameter :: MEGAN_LDF = 'MEGAN_LDF' + character( 40 ), parameter :: MEGAN_LAI = 'MEGAN_LAI' + character( 40 ), parameter :: MEGAN_EFS = 'MEGAN_EFS' + character( 40 ), parameter :: MEGAN_CTS = 'MEGAN_CTS' + character( 40 ), parameter :: BDSNP_NFILE = 'BDSNP_NFILE' + character( 40 ), parameter :: BDSNP_AFILE = 'BDSNP_AFILE' + character( 40 ), parameter :: BDSNP_NAFILE = 'BDSNP_NAFILE' + character( 40 ), parameter :: BDSNP_FFILE = 'BDSNP_FFILE' + character( 40 ), parameter :: BDSNP_LFILE = 'BDSNP_LFILE' + character( 256 ) :: mesg + character( 40 ) :: var + + if (BDSNP_MEGAN) then + allocate (bdsnp_fert( ncols,nrows), + & bdsnp_arid( ncols,nrows), + & bdsnp_nonarid( ncols,nrows), + & bdsnp_landtype( ncols,nrows), + & bdsnp_ndep( ncols,nrows,12), + & stat=stat) + IF ( STAT .NE. 0 ) THEN + MESG = 'Failure BIOGEMIS_MEGAN arrays in megan_setup' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT3 ) + END IF + bdsnp_fert = 0. + bdsnp_arid = 0. + bdsnp_nonarid = 0. + bdsnp_landtype = 0. + bdsnp_ndep = 0. + end if + +#ifdef mpas + + +! MPAS MIO not included + +#else +! NOT MPAS +! Open the CTS, LDF, LAI, and EFS files + IF ( .NOT. OPEN3( MEGAN_CTS, FSREAD3, PNAME ) ) THEN + mesg = 'Open failure for ' // MEGAN_CTS + Call M3EXIT( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + n_opened_file = n_opened_file + 1 + f_mbiog = n_opened_file + + IF ( .NOT. DESC3( MEGAN_CTS ) ) THEN + MESG = 'Could not get description of file "' // + & TRIM( MEGAN_CTS ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT1 ) + END IF + + file_sdate(f_mbiog) = sdate3d + file_stime(f_mbiog) = stime3d + file_tstep(f_mbiog) = tstep3d + file_xcell(f_mbiog) = xcell3d + file_ycell(f_mbiog) = ycell3d + + allocate (ctf(mxrec3d,ncols,nrows), stat = stat) + + if (stat .ne. 0) then + mesg = 'Failure allocating MEGAN input arrays' + call m3exit (pname, 0, 0, mesg, xstat1 ) + end if + + call subhfile( megan_cts , gxoff, gyoff, strtcol, + & endcol, strtrow, endrow ) + + megan_day = sdate3d + megan_hr = stime3d + + megan_hr = 0 + do I=1,mxrec3d + + IF ( .NOT. XTRACT3( MEGAN_CTS, 'CTS', + & 1, 1, strtrow, endrow, strtcol, endcol, + & 0, megan_hr, ctf(I,:,:) ) ) THEN + mesg = 'Could not extract ' // MEGAN_CTS // ' file' + CALL M3EXIT ( PNAME, megan_day, megan_hr, mesg, XSTAT1 ) + END IF + megan_hr = megan_hr + 10000 + !call nextime (megan_day, megan_hr, tstep3d) + + end do + + WHERE ( ctf .ne. ctf ) ctf = 0.0 ! ensure no NaNs + + IF ( .NOT. OPEN3( MEGAN_EFS, FSREAD3, PNAME ) ) THEN + mesg = 'Open failure for ' // MEGAN_EFS + Call M3EXIT( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + + IF ( .NOT. DESC3( MEGAN_EFS ) ) THEN + MESG = 'Could not get description of file "' // + & TRIM( MEGAN_EFS ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT1 ) + END IF + + allocate (efmaps(ncols,nrows,nvars3d), stat = stat) + + if (stat .ne. 0) then + mesg = 'Failure allocating MEGAN input arrays' + call m3exit (pname, 0, 0, mesg, xstat1 ) + end if + + call subhfile( megan_efs, gxoff, gyoff, strtcol, + & endcol, strtrow, endrow ) + + megan_day = sdate3d + megan_hr = stime3d + + IF ( .NOT. XTRACT3( MEGAN_EFS, 'ALL', + & 1, 1, strtrow, endrow, strtcol, endcol, + & megan_day, megan_hr, efmaps(:,:,:) ) ) THEN + mesg = 'Could not extract ' // MEGAN_EFS // ' file' + CALL M3EXIT ( PNAME, 0, megan_hr, mesg, XSTAT1 ) + END IF + + IF ( USE_MEGAN_LAI) THEN + IF ( .NOT. OPEN3( MEGAN_LAI, FSREAD3, PNAME ) ) THEN + mesg = 'Open failure for ' // MEGAN_LAI + Call M3EXIT( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + + IF ( .NOT. DESC3( MEGAN_LAI ) ) THEN + MESG = 'Could not get description of file "' // + & TRIM( MEGAN_LAI ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT1 ) + END IF + + + allocate (lai_m(ncols,nrows,nvars3d-2), stat = stat) + + if (stat .ne. 0) then + mesg = 'Failure allocating MEGAN input arrays' + call m3exit (pname, 0, 0, mesg, xstat1 ) + end if + + lai_m = 0.0 + + call subhfile( megan_lai, gxoff, gyoff, strtcol, + & endcol, strtrow, endrow ) + + megan_day = sdate3d + megan_hr = stime3d + + do I=1,nvars3d-2 ! lat/lon excluded + WRITE( VAR, '(A3,I2.2)' ) 'LAI', I + IF ( .NOT. XTRACT3( MEGAN_LAI, VAR, + & 1, 1, strtrow, endrow, strtcol, endcol, + & megan_day, megan_hr, lai_m(:,:,I) ) ) THEN + mesg = 'Could not extract ' // MEGAN_LAI // ' file' + CALL M3EXIT ( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + end do + END IF + + IF ( .NOT. OPEN3( MEGAN_LDF, FSREAD3, PNAME ) ) THEN + mesg = 'Open failure for ' // MEGAN_LDF + Call M3EXIT( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + + IF ( .NOT. DESC3( MEGAN_LDF ) ) THEN + MESG = 'Could not get description of file "' // + & TRIM( MEGAN_LDF ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT1 ) + END IF + + allocate (ldf(ncols,nrows,nvars3d), stat = stat) + + if (stat .ne. 0) then + mesg = 'Failure allocating MEGAN input arrays' + call m3exit (pname, 0, 0, mesg, xstat1 ) + end if + + call subhfile( megan_ldf, gxoff, gyoff, strtcol, + & endcol, strtrow, endrow ) + + megan_day = sdate3d + megan_hr = stime3d + + IF ( .NOT. XTRACT3( MEGAN_LDF, 'ALL', + & 1, 1, strtrow, endrow, strtcol, endcol, + & megan_day, megan_hr, LDF(:,:,:) ) ) THEN + mesg = 'Could not extract ' // MEGAN_LDF // ' file' + CALL M3EXIT ( PNAME, 0, megan_hr, mesg, XSTAT1 ) + END IF + if (BDSNP_MEGAN) then + + ! Optional BDSNP nitrogen input + if (.not. MGN_ONLN_DEP) then + IF ( .NOT. OPEN3( BDSNP_NFILE, FSREAD3, PNAME ) ) THEN + mesg = 'Open failure for ' // BDSNP_NFILE + Call M3EXIT( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + + IF ( .NOT. DESC3( BDSNP_NFILE ) ) THEN + MESG = 'Could not get description of file "' // + & TRIM( BDSNP_NFILE ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT1 ) + END IF + + + call subhfile( BDSNP_NFILE, gxoff, gyoff, strtcol, + & endcol, strtrow, endrow ) + + megan_day = sdate3d + megan_hr = stime3d + do i = 1,12 + write( var, '(A8,I2.2)' ) 'NITROGEN', i + IF ( .NOT. XTRACT3( BDSNP_NFILE, var, + & 1, 1, strtrow, endrow, strtcol, endcol, + & megan_day, megan_hr, bdsnp_ndep(:,:,i) ) ) THEN + mesg = 'Could not extract ' // BDSNP_NFILE // ' file' + CALL M3EXIT ( PNAME, 0, megan_hr, mesg, XSTAT1 ) + END IF + end do + end if + + ! BDSNP fertilizer input + + IF ( .NOT. OPEN3( BDSNP_FFILE, FSREAD3, PNAME ) ) THEN + mesg = 'Open failure for ' // BDSNP_FFILE + Call M3EXIT( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + + IF ( .NOT. DESC3( BDSNP_FFILE ) ) THEN + MESG = 'Could not get description of file "' // + & TRIM( BDSNP_FFILE ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT1 ) + END IF + + call subhfile( BDSNP_FFILE, gxoff, gyoff, strtcol, + & endcol, strtrow, endrow ) + + i = FLOAT( MOD( STDATE, 1000 ) ) + write( var, '(A4,I3.3)' ) 'FERT', i + IF ( .NOT. XTRACT3( BDSNP_FFILE, var, + & 1, 1, strtrow, endrow, strtcol, endcol, + & megan_day, megan_hr, bdsnp_fert(:,:) ) ) THEN + mesg = 'Could not extract ' // BDSNP_FFILE // ' file' + CALL M3EXIT ( PNAME, 0, megan_hr, mesg, XSTAT1 ) + END IF + + ! BDSNP arid input + + IF ( .NOT. OPEN3( BDSNP_AFILE, FSREAD3, PNAME ) ) THEN + mesg = 'Open failure for ' // BDSNP_AFILE + Call M3EXIT( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + + IF ( .NOT. DESC3( BDSNP_AFILE ) ) THEN + MESG = 'Could not get description of file "' // + & TRIM( BDSNP_AFILE ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT1 ) + END IF + + call subhfile( BDSNP_AFILE, gxoff, gyoff, strtcol, + & endcol, strtrow, endrow ) + + + IF ( .NOT. XTRACT3( BDSNP_AFILE, 'ARID', + & 1, 1, strtrow, endrow, strtcol, endcol, + & megan_day, megan_hr, bdsnp_arid(:,:) ) ) THEN + mesg = 'Could not extract ' // BDSNP_AFILE // ' file' + CALL M3EXIT ( PNAME, 0, megan_hr, mesg, XSTAT1 ) + END IF + + ! BDSNP nonarid input + + IF ( .NOT. OPEN3( BDSNP_NAFILE, FSREAD3, PNAME ) ) THEN + mesg = 'Open failure for ' // BDSNP_NAFILE + Call M3EXIT( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + + IF ( .NOT. DESC3( BDSNP_NAFILE ) ) THEN + MESG = 'Could not get description of file "' // + & TRIM( BDSNP_NAFILE ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT1 ) + END IF + + call subhfile( BDSNP_NAFILE, gxoff, gyoff, strtcol, + & endcol, strtrow, endrow ) + + + IF ( .NOT. XTRACT3( BDSNP_NAFILE, 'NONARID', + & 1, 1, strtrow, endrow, strtcol, endcol, + & megan_day, megan_hr, bdsnp_nonarid(:,:) ) ) THEN + mesg = 'Could not extract ' // BDSNP_NAFILE // ' file' + CALL M3EXIT ( PNAME, 0, megan_hr, mesg, XSTAT1 ) + END IF + + ! BDSNP landtype input + + IF ( .NOT. OPEN3( BDSNP_LFILE, FSREAD3, PNAME ) ) THEN + mesg = 'Open failure for ' // BDSNP_LFILE + Call M3EXIT( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + + IF ( .NOT. DESC3( BDSNP_LFILE ) ) THEN + MESG = 'Could not get description of file "' // + & TRIM( BDSNP_LFILE ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT1 ) + END IF + + call subhfile( BDSNP_LFILE, gxoff, gyoff, strtcol, + & endcol, strtrow, endrow ) + + IF ( .NOT. XTRACT3( BDSNP_LFILE, 'LANDTYPE', + & 1, 1, strtrow, endrow, strtcol, endcol, + & megan_day, megan_hr, bdsnp_landtype(:,:) ) ) THEN + mesg = 'Could not extract ' // BDSNP_LFILE // ' file' + CALL M3EXIT ( PNAME, 0, megan_hr, mesg, XSTAT1 ) + END IF + + end if + +#endif + end subroutine megan_setup + +! ------------------------------------------------------------------------- + + subroutine centralized_io_init (in_ncols) + + use lsm_mod, only: n_lufrac, init_lsm + USE UTILIO_DEFN ! (Wei Li) , only : m3exit + USE RUNTIME_VARS, only: log_heading, logdev + +#ifdef mpas +! use hgrd_defn, only : ncols +! use RUNTIME_VARS, only : WB_DUST, ocean_chem +! use lus_defn, only : lus_init +#else + USE HGRD_DEFN + use cgrid_spcs, only : GC_DDEP, N_GC_DDEP +! use util_module, only : index1 + + INCLUDE SUBST_FILES_ID ! file name parameters +#endif + + integer, intent(in), optional :: in_ncols + + Character( 40 ), parameter :: pname = 'centralized_io_init' + + logical, save :: first_time = .true. + INTEGER :: STAT + CHARACTER( 120 ) :: XMSG = ' ' + Character( 16 ) :: vname + + if (first_time) then + first_time = .false. + call log_heading( logdev, 'Opening CMAQ Input Files' ) + +#ifdef mpas +! call gridded_files_setup +! +! call retrieve_lufrac_cro_data +! +! if (wb_dust) then +! call lus_setup +! end if +! +!! cio_logdev = 6 +! +! if ( WB_DUST ) then +! if (.not. lus_init (mminlu_mpas, lufrac_data) ) then +! print *, ' Error: Cannot initialize Land Use category' +! stop +! end if +! end if +! +! allocate (lwmask(in_ncols, 1), +! & lat(in_ncols, 1), +! & lon(in_ncols, 1), +! & ht(in_ncols, 1), +! & ocean(in_ncols, 1), +! & szone(in_ncols, 1), +! & stat=stat) +! +! lon = g2ddata(:,:,lon_ind) +! lat = g2ddata(:,:,lat_ind) +! ht = g2ddata(:,:,ht_ind) +! lwmask = g2ddata(:,:,lwmask_ind) +! +! call retrieve_ocean_data_mpas +! +! if (ocean_chem) then +! ocean = g2ddata(:,:,open_ind) +! szone = g2ddata(:,:,surf_ind) +! dmsl = g2ddata(:,:,dms_ind) +! chlr = g2ddata(:,:,chlo_ind) +! end if +! +! cio_model_sdate = stdate +! cio_model_stime = sttime +! +! call stack_files_setup_mpas +! +#else + cio_logdev = init3() + + cio_model_sdate = STDATE + cio_model_stime = STTIME + + east_pe = (mod(mype, npcol) .eq. npcol - 1) + west_pe = (mod(mype, npcol) .eq. 0) + north_pe = (mype .ge. npcol * (nprow - 1)) + south_pe = (mype .lt. npcol) + + cio_LTNG_NO = LTNG_NO + + MEDC_AVAIL = .true. + If ( .Not. Open3( INIT_MEDC_1, fsread3, pname ) ) Then + MEDC_AVAIL = .false. + if (abflux) then + E2C_CHEM_AVAIL = .true. + If ( .Not. Open3( E2C_CHEM, fsread3, pname ) ) Then + XMSG = 'Open failure for ' // E2C_CHEM + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + E2C_CHEM_AVAIL = .false. + END IF + n_opened_file = n_opened_file + 1 + else + E2C_CHEM_AVAIL = .false. + end if + END IF + + if (MEDC_AVAIL) then + n_opened_file = n_opened_file + 1 + end if + + call gridded_files_setup + + call boundary_files_setup + + call stack_files_setup + + if (BIOGEMIS_BEIS) then + call biogemis_setup + call beis_norm_emis_setup + end if + if (BIOGEMIS_MEGAN) then + call megan_setup + end if + + + if (ABFLUX) then + call depv_data_setup + end if + + if (LUCRO_AVAIL) then + call retrieve_lufrac_cro_data + end if + + if (WB_DUST) then + if (.not. PX_LSM) then + XMSG = 'WB_DUST requires PX LSM (PX_VERSION Y)' + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + end if + call lus_setup + + end if + + if (HGBIDI .and. (.not. NEW_START)) then ! two level check, 1. environment variable and then GC_DDEP species list + if ( index1 ( 'HG', N_GC_DDEP, GC_DDEP) .gt. 0 ) then + call medc_file_setup + end if + end if + + if (BIOGEMIS_BEIS .or. BIOGEMIS_MEGAN) then + call soilinp_setup + end if + + + call retrieve_grid_cro_2d_data + + call retrieve_grid_dot_2d_data + + call retrieve_ocean_data + + if (cio_LTNG_NO) then + call retrieve_ltng_param_data + end if +#endif + + end if + + call retrieve_time_dep_gridded_data (cio_model_sdate, cio_model_stime) + +#ifdef mpas +! call retrieve_stack_data_mpas (cio_model_sdate, cio_model_stime) +#else + call retrieve_boundary_data (cio_model_sdate, cio_model_stime) + + call retrieve_stack_data (cio_model_sdate, cio_model_stime) +#endif + + end subroutine centralized_io_init + +!----------------------------------------------------------------------- + SUBROUTINE DESID_INIT_REGIONS( ) +! +! This subroutine defines several hardcoded rules for emissions +! scaling that will apply by default. These include subtracting NH3 +! from fertilizer emissions if BiDi is turned on, moving all +! sulfuric acid vapor to the particle phase upon emission and +! splitting up the coarse mode anthropogenic emissions mass into +! speciated compounds. +!----------------------------------------------------------------------- + USE GRID_CONF + USE UTILIO_DEFN + USE desid_param_module + USE UTIL_FAMILY_MODULE +#ifdef mpas +! USE util_module, only : index1, upcase + +#endif + +#ifdef parallel + USE SE_MODULES ! stenex (using SE_UTIL_MODULE,SE_DATA_COPY_MODULE) +#else + USE NOOP_MODULES ! stenex (using NOOP_UTIL_MODULE,NOOP_DATA_COPY_MODULE) +#endif + +#ifdef sens + USE DDM3D_DEFN, ONLY: NP, NPMAX, S_NRGN, S_RGNLBL, IREGION +#endif + + IMPLICIT NONE + + TYPE( DESID_REG_TYPE) :: DESID_REG_READ( DESID_MAX_REG ) + INTEGER, PARAMETER :: NFILE0 = 200 + CHARACTER( 32 ) :: FILENAMES( NFILE0 ) = '' + CHARACTER( 32 ) :: VNAME + + INTEGER :: IRGN, NFILE, IDX, IFILE, IREAD, IVAR, IFAM, JRGN + INTEGER :: GXOFF, GYOFF, ENDCOL, ENDROW, STARTCOL, STARTROW + INTEGER :: N_REG_RULE + CHARACTER( 16 ) :: PNAME = "DESID_INIT_REGIONS" + CHARACTER( 250) :: XMSG + REAL, ALLOCATABLE :: REG_FACI(:,:), REG_FACJ(:,:) + integer :: ldate, ltime, floc + CHARACTER( 16 ) :: lvname + + ! Find the total number of regions to be processed + N_REG_RULE = 0 ! The first region is the entire domain + DO IRGN = 1,DESID_MAX_REG + IF ( DESID_REG_NML( IRGN )%LABEL .EQ. '' ) EXIT + N_REG_RULE = N_REG_RULE + 1 + END DO + + ! Allocate Vectors and Arrays for Each Region + ALLOCATE( DESID_REG( DESID_MAX_REG ) ) + DESID_REG( 1 )%LABEL = 'EVERYWHERE' + DESID_REG( 1 )%FILE = 'N/A' + DESID_REG( 1 )%VAR = 'N/A' + DESID_REG( 1 )%FILENUM = 1 + DESID_N_REG = 1 + + ALLOCATE( DESID_REG_FAC( NCOLS,NROWS,DESID_MAX_REG ) ) + DESID_REG_FAC = 0.0 + DESID_REG_FAC( :,:,1 ) = 1.0 + + ! Populate global Region properties structure. Also assign each + ! region a number according to the file it comes from. 1 = + ! domain-wide. + NFILE = 1 + FILENAMES( 1 ) = 'N/A' + + IF ( N_REG_RULE .GT. 0 ) THEN + DO IREAD = 1,N_REG_RULE + CALL UPCASE( DESID_REG_NML( IREAD )%LABEL ) + CALL UPCASE( DESID_REG_NML( IREAD )%FILE ) + CALL UPCASE( DESID_REG_NML( IREAD )%VAR ) + + DESID_REG_READ( IREAD )%LABEL = DESID_REG_NML( IREAD )%LABEL ! Region Name + DESID_REG_READ( IREAD )%FILE = DESID_REG_NML( IREAD )%FILE ! Logical filename + DESID_REG_READ( IREAD )%VAR = DESID_REG_NML( IREAD )%VAR ! Variable from file + ! used to inform mask + + IDX = INDEX1( DESID_REG_READ( IREAD )%FILE, NFILE, FILENAMES(1:NFILE) ) + IF ( IDX .NE. 0 ) THEN + DESID_REG_READ( IREAD )%FILENUM = IDX + ELSE + NFILE = NFILE + 1 + DESID_REG_READ( IREAD )%FILENUM = NFILE + FILENAMES( NFILE ) = DESID_REG_READ( IREAD )%FILE + END IF + END DO + + ! Process each region by looping through the pertinent files, + ! look up maps and save the data in a global array + DO IFILE = 1,NFILE + IF ( FILENAMES( IFILE ) .EQ. 'N/A' ) CYCLE + +#ifdef mpas +! floc = search_fname (filenames( ifile )) + +! ldate = 0 +! ltime = 0 +#else + ! Get domain decomp info from the emissions file + CALL SUBHFILE ( FILENAMES( IFILE ), GXOFF, GYOFF, + & STARTCOL, ENDCOL, STARTROW, ENDROW ) + + ! Open input file + IF ( .NOT. OPEN3( FILENAMES( IFILE ), FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open '// FILENAMES( IFILE ) // ' file' + CALL M3EXIT( PNAME, STDATE, STTIME, XMSG, XSTAT1 ) + END IF + n_opened_file = n_opened_file + 1 + + ! Retrieve File Header Information + IF ( .NOT. DESC3( FILENAMES( IFILE ) ) ) THEN + XMSG = 'Could not get ' // FILENAMES( IFILE ) // ' file description' + CALL M3EXIT( PNAME, STDATE, STTIME, XMSG, XSTAT1 ) + END IF + +#endif + + ! Read data from regions file into region array + DO IREAD = 1,N_REG_RULE + IF ( DESID_REG_READ( IREAD )%FILENUM .EQ. IFILE ) THEN + IF ( DESID_REG_READ( IREAD )%VAR .EQ. 'ALL' ) THEN + ! Populate the region array with all of the + ! variables on this file + IF ( DESID_REG_READ( IREAD )%LABEL .NE. 'ALL' ) THEN + XMSG = 'Error reading Region input in Emissions Control file.'// + & 'If the variable name is set to "ALL", then the label must'// + & 'also be set to "ALL".' + CALL M3EXIT( PNAME, STDATE, STTIME, XMSG, XSTAT1 ) + ELSE +!#ifdef mpas +! DO IVAR = 1, cio_emis_nvars(ifile) +! lvname = mio_file_data(floc)%var_name(ivar) +!#else + DO IVAR = 1,NVARS3D + lvname = vname3d( ivar ) +!#endif + DESID_N_REG = DESID_N_REG + 1 + IF ( DESID_N_REG .GT. DESID_MAX_REG ) THEN + XMSG = 'The number of DESID regions has exceeded '// + & 'the maximum. Set Desid_Max_Reg in the '// + & 'CMAQ_Control_DESID.nml file to a higher value.' + CALL M3EXIT( PNAME, SDATE3D, STIME3D, XMSG, XSTAT1 ) + END IF + DESID_REG( DESID_N_REG )%LABEL = lvname + DESID_REG( DESID_N_REG )%VAR = lvname + DESID_REG( DESID_N_REG )%FILE = DESID_REG_READ( IREAD )%FILE + DESID_REG( DESID_N_REG )%FILENUM = DESID_REG_READ( IREAD )%FILENUM + +#ifdef mpas +! call mio_fread (FILENAMES(IFILE), lvname, DESID_REG_FAC(:,1,DESID_N_REG)) +#else + IF ( .NOT. XTRACT3( FILENAMES( IFILE ), VNAME3D(IVAR), 1, 1, + & STARTROW, ENDROW, STARTCOL, ENDCOL, + & 0, 0, DESID_REG_FAC( 1,1,DESID_N_REG ) ) ) Then + XMSG = 'Could not read ' // VNAME3D(IVAR) // + & 'from file ' // FILENAMES( IFILE ) + CALL M3WARN ( PNAME, 0, 0, XMSG ) + End If +#endif + + END DO + END IF + ELSE + ! Populate the region array with only this variable + DESID_N_REG = DESID_N_REG + 1 + IF ( DESID_N_REG .GT. DESID_MAX_REG ) THEN + XMSG = 'The number of DESID regions has exceeded '// + & 'the maximum. Set Desid_Max_Reg in the '// + & 'CMAQ_Control_DESID.nml file to a higher value.' + CALL M3EXIT( PNAME, SDATE3D, STIME3D, XMSG, XSTAT1 ) + END IF + + DESID_REG( DESID_N_REG ) = DESID_REG_READ( IREAD ) + VNAME = DESID_REG_READ( IREAD )%VAR + +#ifdef mpas +! call mio_fread (FILENAMES(IFILE), VNAME, DESID_REG_FAC(:,1,DESID_N_REG)) +#else + IF ( .NOT. XTRACT3( FILENAMES( IFILE ), VNAME, 1, 1, + & STARTROW, ENDROW, STARTCOL, ENDCOL, + & 0, 0, DESID_REG_FAC( 1,1,DESID_N_REG ) ) ) Then + XMSG = 'Could not read ' // VNAME // + & 'from file ' // FILENAMES( IFILE ) + CALL M3WARN ( PNAME, 0, 0, XMSG ) + End If +#endif + + END IF + END IF + END DO + +#ifndef mpas +! ! Close Regions File +! IF ( .NOT. CLOSE3( FILENAMES( IFILE ) ) ) THEN +! XMSG = 'Could not close ' // FILENAMES( IFILE ) +! CALL M3EXIT( PNAME, SDATE3D, STIME3D, XMSG, XSTAT1 ) +! END IF +#endif + + ! Error Check the Regions Array + ! Any Negatives? + DO IRGN = 1,DESID_N_REG + IF ( ANY( DESID_REG_FAC( :,:,IRGN ) .LT. 0.0 ) ) THEN + XMSG = 'Region ' // TRIM( DESID_REG( IRGN )%LABEL) // ' on file ' // + & TRIM( FILENAMES( IFILE )) // ' contains a ' // + & 'negative value. The expected range is 0-1.' + CALL M3ERR( PNAME, STDATE, STTIME, XMSG, .TRUE. ) + ELSE IF ( ANY( DESID_REG_FAC( :,:,IRGN ) .GT. 1.01 ) ) THEN + XMSG = 'Region ' // TRIM( DESID_REG( IRGN )%LABEL) // ' on file ' // + & TRIM( FILENAMES( IFILE )) // ' contains a ' // + & 'value greater than 1. The expected range is 0-1.' + CALL M3ERR( PNAME, STDATE, STTIME, XMSG, .TRUE. ) + END IF + + ! Condition mask values to be at most 1.0 + DESID_REG_FAC( :,:,IRGN ) = MIN( 1.0, DESID_REG_FAC( :,:,IRGN ) ) + + END DO + + END DO ! IFILE + + ! Augment Emission Region Structure with Region Families + DO IFAM = 1,Desid_N_Reg_Fams + DESID_N_REG = DESID_N_REG + 1 + CALL UPCASE( RegionFamilyName( IFAM ) ) + DESID_REG( DESID_N_REG )%LABEL = RegionFamilyName( IFAM ) + DESID_REG( DESID_N_REG )%VAR = 'Family' + DESID_REG( DESID_N_REG )%FILE = 'Family' + DESID_REG( DESID_N_REG )%FILENUM = 0 + + DO IRGN = 1,RegionFamilyNum( IFAM ) + CALL UPCASE( RegionFamilyMembers( IFAM,IRGN ) ) + JRGN = INDEX1( RegionFamilyMembers( IFAM,IRGN ), DESID_N_REG-1, + & DESID_REG( 1:(DESID_N_REG-1) )%VAR ) + IF ( JRGN .GT. 0 ) + & DESID_REG_FAC( :,:,DESID_N_REG ) = + & MIN( 1.0, DESID_REG_FAC( :,:,DESID_N_REG ) + + & DESID_REG_FAC( :,:,JRGN ) ) + END DO + END DO + END IF + + DESID_REG = DESID_REG( 1:DESID_N_REG ) + DESID_REG_FAC = DESID_REG_FAC( :,:,1:DESID_N_REG ) + + ! Determine Which Regions are Subsets of Larger Regions and + ! save special relationship for use in EMISS_SCALING. + ALLOCATE( DESID_REG_SUB( DESID_N_REG, DESID_N_REG ) ) + DESID_REG_SUB(:,:) = .FALSE. ! Initialize with no region subsets + DESID_REG_SUB(1,:) = .TRUE. ! All regions are a subset of Region 1 (Everywhere) + DESID_REG_SUB(1,1) = .FALSE. ! No regions are subsets of themselves + + ALLOCATE( REG_FACI(GL_NCOLS,GL_NROWS), + & REG_FACJ(GL_NCOLS,GL_NROWS) ) + + DO IRGN = 2,DESID_N_REG +#ifdef parallel + CALL SUBST_GLOBAL_GATHER( DESID_REG_FAC(:,:,IRGN), REG_FACI ) +#else + REG_FACI = DESID_REG_FAC(:,:,IRGN) +#endif + DO JRGN = 1,DESID_N_REG +#ifdef parallel + CALL SUBST_GLOBAL_GATHER( DESID_REG_FAC(:,:,JRGN), REG_FACJ ) +#else + REG_FACJ = DESID_REG_FAC(:,:,JRGN) +#endif + IF ( MYPE .EQ. 0 ) THEN + IF ( JRGN .NE. IRGN .AND. + & ANY( REG_FACJ(:,:) .GT. 0. ) .AND. + & ALL( REG_FACI(:,:)+1.0E-6 .GT. + & REG_FACJ(:,:) ) ) THEN + ! Assume JRGN is a subset of IRGN. Both have to be + ! non-zero somewhere in the domain. + DESID_REG_SUB( IRGN,JRGN ) = .TRUE. + END IF + END IF ! Only perform algorithm on main processor + END DO + END DO + + DEALLOCATE( REG_FACI, REG_FACJ ) + +#ifdef parallel + CALL SUBST_GLOBAL_BCAST( DESID_REG_SUB ) +#endif + +#ifdef sens +! Populate IREGION(NCOLS,NROW,NLAYS,NPMAX) with regions data if specified +!' + + DO NP = 1, NPMAX + IF ( S_NRGN( NP ) .GT. 0 .AND. S_NRGN( NP ) .LT. 99 ) THEN ! + DO IRGN = 1, S_NRGN( NP ) + IREAD = INDEX1( S_RGNLBL(NP,IRGN), DESID_N_REG, DESID_REG%LABEL ) ! identify region + IF ( IREAD .EQ. 0 ) THEN + XMSG = " User specified DDM3D region - " // + & TRIM( S_RGNLBL(NP,IRGN) ) // + & " - not found in available emissions regions. " // + & " Check sensinput.dat file " + WRITE(LOGDEV,*) " Available region definitions: " + DO IFILE = 1, DESID_N_REG + WRITE(LOGDEV,*) IFILE, DESID_REG( IFILE )%LABEL + END DO + CALL M3EXIT( PNAME, 1, 1, XMSG, XSTAT1 ) + ELSE + IREGION(:,:,1,NP) = IREGION( :,:,1,NP ) + & + DESID_REG_FAC( :,:,IREAD ) + END IF + END DO +! Limit IREGION to < 1.0 incase some regions overlap. + IREGION(:,:,:,NP) = MIN ( IREGION(:,:,:,NP), 1.0 ) +! Copy up to layers above + DO IFILE = 1, NLAYS + IREGION(:,:,IFILE,NP) = IREGION(:,:,1,NP) + END DO + END IF + END DO + +#endif + + END SUBROUTINE DESID_INIT_REGIONS + +!----------------------------------------------------------------------- + SUBROUTINE DESID_READ_NAMELIST( ) +! +! This subroutine opens and reads the Emissions Control Namelist. It +! attempts to deal with errors like missing file or missing file +! sections by error checking and setting defaults. +!----------------------------------------------------------------------- + + use desid_param_module + use util_family_module + use RUNTIME_VARS, only: MISC_CTRL, DESID_CTRL, DESID_CHEM_CTRL, + & logdev, log_message, log_subheading + use PA_DEFN, ONLY : BudgetVariables, MAX_BUDGET_VARS_NML, BUDGET_DIAG +#ifdef mpas +! use util_module, only : junit, upcase +#endif + + IMPLICIT NONE + + ! Define Dummy Variables for Opening Emission Control Namelist + CHARACTER( 300 ) :: XMSG + INTEGER :: Desid_N_Diag_Rules, Desid_Max_Area, Desid_Max_Sd + INTEGER :: FUNIT + INTEGER :: IOST, IFAM, INUM, IRULE + CHARACTER( 200 ) :: TMPLINE + + ! Define Namelist Input from Control Files + ! CMAQ Control Util + Namelist / Budget_Options / Budget_Diag, BudgetVariables + + ! DESID Chem Control + Namelist / Desid_ScalingVars / Desid_Max_Rules + Namelist / Desid_Scaling / Desid_Rules_Nml + + ! DESID Control + Namelist / Desid_Options / Desid_MaxLays + + Namelist / Desid_AreaNormVars / Desid_Max_Area + Namelist / Desid_AreaNorm / Desid_Area_Nml + + Namelist / Desid_SizeDistVars / Desid_Max_Sd + Namelist / Desid_SizeDist / Desid_Sd_Nml + + Namelist / Desid_RegionDefVars / Desid_Max_Reg, + & Desid_N_Reg_Fams, + & Desid_Max_Reg_Fam_Members + Namelist / Desid_RegionDef / Desid_Reg_Nml + + Namelist / Desid_DiagVars / Desid_N_Diag_Rules, + & Desid_Max_Diag_Streams, + & Desid_Max_Diag_Spec + Namelist / Desid_Diag / Desid_Diag_Streams_Nml, + & Desid_Diag_Fmt_Nml, + & Desid_Diag_Spec_Nml + + CALL LOG_MESSAGE( LOGDEV, ' ' ) + CALL LOG_SUBHEADING( LOGDEV, 'Reading Emission Control Namelist') + + !!! Budget Options !!! + ! Allocate and Initialize Budget Variables + Budget_Diag = .FALSE. + ALLOCATE( BudgetVariables( Max_Budget_Vars_Nml ) ) + BudgetVariables = '' + + ! Retrieve the Name of the Emission Control File + IF ( MISC_CTRL .EQ. "MISC_CTRL_NML" ) THEN + XMSG = 'You have chosen not to indicate the location of an' // + & 'CMAQ Control namelist file. You must give a value ' // + & 'for the MISC_CTRL variable in the CMAQ runscript.' + CALL M3EXIT( 'DESID_READ_NAMELIST',0,0,XMSG,1 ) + END IF + + ! Open Emission Control Namelist File + FUNIT = JUNIT() + OPEN( FILE = MISC_CTRL, UNIT = FUNIT, STATUS = 'OLD', + & POSITION = 'REWIND', FORM='FORMATTED', IOSTAT = IOST ) + + ! Check for Error in File Open Process + IF ( IOST .NE. 0 ) THEN + WRITE( XMSG, '(A,A,A)' ),'ERROR: Could not read ', + & 'CMAQ control namelist file: ',TRIM( MISC_CTRL ) + CALL M3EXIT( 'DESID_READ_NAMELIST',0,0,XMSG,1 ) + END IF + + ! Read Budget Variables Specification Section + REWIND( FUNIT ) + READ( NML = Budget_Options, UNIT = FUNIT, IOSTAT= IOST ) + IF ( IOST .EQ. -1 ) THEN + WRITE( LOGDEV, "(5x,A,/,5x,A,/,5x,A,/,5x,A)" ), + & 'Note: The BudgetOptions section of the Emissions Control ', + & 'Namelist is missing. Default values for this section will be ', + & 'assumed.' + Budget_Diag = .FALSE. + BudgetVariables = 'ALL' + ELSE IF ( IOST .NE. 0 ) THEN + ! Read Error Detected for BudgetOptions + backspace( FUNIT ) + read( FUNIT, fmt='(A)' ) tmpline + XMSG = 'ERROR: There was a syntax error reading the Budget_Options '// + & 'variable in the CMAQ control namelist. Please check the format of '// + & 'each line for syntax errors. The invalid line was likely: ' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + WRITE( LOGDEV, '(8x,A)' ) TMPLINE + CALL M3EXIT ( 'DESID_READ_NAMELIST', 0, 0, 'CMAQ must Crash until you '// + & 'fix the Budget Variables specification', 1 ) + END IF + ! Capitalize All Budget Variables Names + DO IFAM = 1,Max_Budget_Vars_Nml + CALL UPCASE( BudgetVariables( IFAM ) ) + END DO + + CLOSE( FUNIT ) + + !----------------------------! + !!! DESID Chemical Mapping !!! + ! Retrieve the Name of the Emission Control File + IF ( DESID_CHEM_CTRL .EQ. "DESID_CHEM_CTRL_NML" ) THEN + XMSG = 'You have chosen not to indicate the location of an' // + & 'Emission Control namelist file. You must give a value ' // + & 'for the DESID_CHEM_CTRL variable in the CMAQ runscript.' + CALL M3EXIT( 'DESID_READ_NAMELIST',0,0,XMSG,1 ) + END IF + + ! Open Emission Control Namelist File + FUNIT = JUNIT() + OPEN( FILE = DESID_CHEM_CTRL, UNIT = FUNIT, STATUS = 'OLD', + & POSITION = 'REWIND', FORM='FORMATTED', IOSTAT = IOST ) + + ! Check for Error in File Open Process + IF ( IOST .NE. 0 ) THEN + WRITE( XMSG, '(A,A,A)' ),'ERROR: Could not read ', + & 'emissions control namelist file: ',TRIM( DESID_CHEM_CTRL ) + CALL M3EXIT( 'DESID_READ_NAMELIST',0,0,XMSG,1 ) + END IF + + ! Read the number of Max Emissions Rules to inform scaling operations + REWIND( FUNIT ) + READ( NML = Desid_ScalingVars, UNIT = FUNIT, IOSTAT=IOST ) + IF ( IOST .EQ. -1 ) THEN + ! The DESID_Max_Rules Variable was completely missing + XMSG = 'WARNING: Maximum Number of DESID Scaling Rules was not specified. '// + & 'If you intended to specify Desid_Max_Rules, check the DESID_CHEM_CTRL file.' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + DESID_MAX_RULES = 500 + + ELSE IF ( IOST .NE. 0 ) THEN + ! Read Error Detected for DESID_RULES_NML + backspace( FUNIT ) + read( FUNIT, fmt='(A)' ) tmpline + XMSG = 'ERROR: There was a syntax error reading ithe max number of '// + & 'Emission Scaling Rules for use by the DESID module. Please '// + & 'check the format of each line for syntax errors. The '// + & 'invalid line was likely: ' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + WRITE( LOGDEV, '(8x,A)' ) TMPLINE + CALL M3EXIT ( 'DESID_READ_NAMELIST', 0, 0, 'CMAQ must Crash until you '// + & 'fix Desid_Max_Rules', 1 ) + END IF + + ! Allocate Initialize Namelist Variables + ALLOCATE( DESID_RULES_NML( DESID_MAX_RULES ), STAT=IOST ) + CALL CHECKMEM( IOST, 'DESID_RULES_NML','DESID_READ_NAMELIST') + DESID_RULES_NML%REGION = '' + DESID_RULES_NML%STREAM = '' + DESID_RULES_NML%EMVAR = '' + DESID_RULES_NML%SPEC = '' + DESID_RULES_NML%PHASE = '' + DESID_RULES_NML%OP = '' + DESID_RULES_NML%BASIS = '' + DESID_RULES_NML%FAC = 0. + + ! Read the Emissions Rules to inform scaling operations + REWIND( FUNIT ) + READ( NML = Desid_Scaling, UNIT = FUNIT, IOSTAT=IOST ) + IF ( IOST .EQ. -1 ) THEN + ! The DESID_RULES_NML Variable was completely missing + XMSG = 'WARNING: There were no valid Emission Scaling Rules specified '// + & 'for use by the DESID module. If you intended to specify '// + & 'rules in the emission control file, check the file you have '// + & 'provided for DESID_CHEM_CTRL.' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + DESID_RULES_NML%REGION = '' + DESID_RULES_NML%STREAM = '' + DESID_RULES_NML%EMVAR = '' + DESID_RULES_NML%SPEC = '' + DESID_RULES_NML%PHASE = '' + DESID_RULES_NML%OP = '' + DESID_RULES_NML%BASIS = '' + DESID_RULES_NML%FAC = 0. + + ELSE IF ( IOST .NE. 0 ) THEN + ! Read Error Detected for DESID_RULES_NML + backspace( FUNIT ) + read( FUNIT, fmt='(A)' ) tmpline + XMSG = 'ERROR: There was a syntax error reading Emission Scaling '// + & 'Rules for use by the DESID module. Please check the format of '// + & 'each line for syntax errors. The invalid line was likely: ' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + WRITE( LOGDEV, '(8x,A)' ) TMPLINE + CALL M3EXIT ( 'DESID_READ_NAMELIST', 0, 0, 'CMAQ must Crash until you '// + & 'fix the Emission Scaling Rules', 1 ) + END IF + + CALL LOG_MESSAGE( LOGDEV,' ' ) + CALL LOG_MESSAGE( LOGDEV,'Performing Basic Error Checks for Emission Scaling Rules' ) + + ! Check that the operator field is correct since it has not so + ! many possible values. + DO IRULE = 1,DESID_MAX_RULES + IF( DESID_RULES_NML( IRULE )%SPEC .EQ. '' ) EXIT + IF( DESID_RULES_NML( IRULE )%OP .NE. 'a' .AND. DESID_RULES_NML( IRULE )%OP .NE. 'A' .AND. + & DESID_RULES_NML( IRULE )%OP .NE. 'o' .AND. DESID_RULES_NML( IRULE )%OP .NE. 'O'.AND. + & DESID_RULES_NML( IRULE )%OP .NE. 'm' .AND. DESID_RULES_NML( IRULE )%OP .NE. 'M' ) THEN + WRITE( XMSG, '(A23,I4,A27,A3)'),'Emission Scaling Rule #',IRULE, + & ' has a bad operator value: ',DESID_RULES_NML(IRULE)%OP + call m3exit ( 'DESID_READ_NAMELIST', 0, 0, XMSG, 1 ) + END IF + ENDDO + + CLOSE( FUNIT ) + + !-----------------------------! + !!! Open DESID Control File !!! + !-----------------------------! + ! Retrieve the Name of the Emission Control File + IF ( DESID_CTRL .EQ. "DESID_CTRL_NML" ) THEN + XMSG = 'You have chosen not to indicate the location of an' // + & 'Emission Control namelist file. You must give a value ' // + & 'for the DESID_CTRL variable in the CMAQ runscript.' + CALL M3EXIT( 'DESID_READ_NAMELIST',0,0,XMSG,1 ) + END IF + + ! Open Emission Control Namelist File + FUNIT = JUNIT() + OPEN( FILE = DESID_CTRL, UNIT = FUNIT, STATUS = 'OLD', + & POSITION = 'REWIND', FORM='FORMATTED', IOSTAT = IOST ) + + ! Check for Error in File Open Process + IF ( IOST .NE. 0 ) THEN + WRITE( XMSG, '(A,A,A)' ),'ERROR: Could not read ', + & 'emissions control namelist file: ',TRIM( DESID_CTRL ) + CALL M3EXIT( 'DESID_READ_NAMELIST',0,0,XMSG,1 ) + END IF + + !----------------------! + !!! DESID Top Layer !!! + ! Read the Maximum Emissions Layer + REWIND( FUNIT ) + READ( NML = Desid_Options, UNIT = FUNIT, IOSTAT=IOST ) + IF ( IOST .EQ. -1 ) THEN + ! The Desid_Max_Lays Variable was completely missing + XMSG = 'WARNING: Maximum Layer for emissions input was not specified. '// + & 'If you intended to specify Desid_Max_Lays, check the DESID_CTRL file.' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + Desid_MaxLays = 0 + + ELSE IF ( IOST .NE. 0 ) THEN + ! Read Error Detected for Desid_Max_Lays + backspace( FUNIT ) + read( FUNIT, fmt='(A)' ) tmpline + XMSG = 'ERROR: There was a syntax error reading the max number of '// + & 'Emission Layers for use by the DESID module. Please '// + & 'check the format of each line for syntax errors. The '// + & 'invalid line was likely: ' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + WRITE( LOGDEV, '(8x,A)' ) TMPLINE + CALL M3EXIT ( 'DESID_READ_NAMELIST', 0, 0, 'CMAQ must Crash until you '// + & 'fix Desid_Max_Lays', 1 ) + END IF + + !------------------------------! + !!! DESID Area Normalization !!! + ! Read the number of Max Emissions Rules to inform scaling operations + REWIND( FUNIT ) + READ( NML = Desid_AreaNormVars, UNIT = FUNIT, IOSTAT=IOST ) + IF ( IOST .EQ. -1 ) THEN + ! The DESID_Max_Rules Variable was completely missing + XMSG = 'WARNING: Maximum Number of DESID Area Normalization Rules was not specified. '// + & 'If you intended to specify Desid_Max_Area, check the DESID_CTRL file.' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + DESID_MAX_AREA = 30 + + ELSE IF ( IOST .NE. 0 ) THEN + ! Read Error Detected for DESID_RULES_NML + backspace( FUNIT ) + read( FUNIT, fmt='(A)' ) tmpline + XMSG = 'ERROR: There was a syntax error reading the max number of '// + & 'Emission Area Normalization Rules for use by the DESID module. Please '// + & 'check the format of each line for syntax errors. The '// + & 'invalid line was likely: ' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + WRITE( LOGDEV, '(8x,A)' ) TMPLINE + CALL M3EXIT ( 'DESID_READ_NAMELIST', 0, 0, 'CMAQ must Crash until you '// + & 'fix Desid_Max_Area', 1 ) + END IF + + ! Allocate Initialize Namelist Variables + ALLOCATE( DESID_AREA_NML( DESID_MAX_AREA ), STAT=IOST ) + CALL CHECKMEM( IOST, 'DESID_AREA_NML','DESID_READ_NAMELIST') + DESID_AREA_NML%STREAM = 'ALL' + DESID_AREA_NML%AREA = 'AUTO' + DESID_AREA_NML%ADJ = 'AUTO' + + ! Read the Area Normalization Registry + REWIND( FUNIT ) + READ( NML = Desid_AreaNorm, UNIT = FUNIT, IOSTAT=IOST ) + IF ( IOST .EQ. -1 ) THEN + XMSG = 'Note: The Area Normalization section of the Emissions Control '// + & 'Interface is missing. Default values for this section will be '// + & 'assumed.' + CALL LOG_MESSAGE( LOGDEV,' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + DESID_AREA_NML%STREAM = 'ALL' + DESID_AREA_NML%AREA = 'AUTO' + DESID_AREA_NML%ADJ = 'AUTO' + ELSE IF ( IOST .NE. 0 ) THEN + ! Read Error Detected for DESID_AREA_NML + backspace( FUNIT ) + read( FUNIT, fmt='(A)' ) tmpline + XMSG = 'ERROR: There was a syntax error reading the Area Normalization '// + & 'variable for use by the DESID module. Please check the format of '// + & 'each line for syntax errors. The invalid line was likely: ' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + WRITE( LOGDEV, '(8x,A)' ) TMPLINE + CALL M3EXIT ( 'DESID_READ_NAMELIST', 0, 0, 'CMAQ must Crash until you '// + & 'fix the Area Normalization section', 1 ) + END IF + + !-----------------------------! + !!! DESID Region Definition !!! + ! Read the number of Max Emissions Rules to inform scaling operations + REWIND( FUNIT ) + READ( NML = Desid_RegionDefVars, UNIT = FUNIT, IOSTAT=IOST ) + IF ( IOST .EQ. -1 ) THEN + ! The DESID_Max_Rules Variable was completely missing + XMSG = 'WARNING: Maximum Number of DESID Region Def Variables was not specified. '// + & 'If you intended to specify Desid_Max_Reg, check the DESID_CTRL file.' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + DESID_MAX_REG = 30 + + ELSE IF ( IOST .NE. 0 ) THEN + ! Read Error Detected for DESID_RULES_NML + backspace( FUNIT ) + read( FUNIT, fmt='(A)' ) tmpline + XMSG = 'ERROR: There was a syntax error reading the max number of '// + & 'Region Definitions for use by the DESID module. Please '// + & 'check the format of each line for syntax errors. The '// + & 'invalid line was likely: ' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + WRITE( LOGDEV, '(8x,A)' ) TMPLINE + CALL M3EXIT ( 'DESID_READ_NAMELIST', 0, 0, 'CMAQ must Crash until you '// + & 'fix Desid_Max_Reg', 1 ) + END IF + + ! Allocate and Initialize Namelist Variables + ALLOCATE( DESID_REG_NML( DESID_MAX_REG ), STAT=IOST ) + CALL CHECKMEM( IOST, 'DESID_REG_NML','DESID_READ_NAMELIST') + DESID_REG_NML%LABEL = '' + DESID_REG_NML%FILE = '' + DESID_REG_NML%VAR = '' + + ! Read the Regions Registry + REWIND( FUNIT ) + READ( NML = Desid_RegionDef, UNIT = FUNIT, IOSTAT=IOST ) + IF ( IOST .EQ. -1 ) THEN + XMSG = 'Note: The Desid_RegionDef component of the Emissions Control '// + & 'Interface is missing. Default values for this section will be '// + & 'assumed.' + CALL LOG_MESSAGE( LOGDEV,' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + DESID_REG_NML%LABEL = '' + DESID_REG_NML%FILE = '' + DESID_REG_NML%VAR = '' + ELSE IF ( IOST .NE. 0 ) THEN + ! Read Error Detected for DESID_REG_NML + backspace( FUNIT ) + read( FUNIT, fmt='(A)' ) tmpline + XMSG = 'ERROR: There was a syntax error reading the Desid_RegionDef '// + & 'variable for use by the DESID module. Please check the format of '// + & 'each line for syntax errors. The invalid line was likely: ' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + WRITE( LOGDEV, '(8x,A)' ) TMPLINE + CALL M3EXIT ( 'DESID_READ_NAMELIST', 0, 0, 'CMAQ must Crash until you '// + & 'fix Desid_RegionDef', 1 ) + END IF + + + !------------------------------! + !!! DESID Size Distributions !!! + ! Read the number of Max Size Dist Rules to inform scaling operations + REWIND( FUNIT ) + READ( NML = Desid_SizeDistVars, UNIT = FUNIT, IOSTAT=IOST ) + IF ( IOST .EQ. -1 ) THEN + ! The DESID_Max_Sd Variable was completely missing + XMSG = 'WARNING: Maximum Number of DESID Size Dist Rules was not specified. '// + & 'If you intended to specify Desid_Max_Sd, check the DESID_CTRL file.' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + DESID_MAX_SD = 10 + + ELSE IF ( IOST .NE. 0 ) THEN + ! Read Error Detected for DESID_RULES_NML + backspace( FUNIT ) + read( FUNIT, fmt='(A)' ) tmpline + XMSG = 'ERROR: There was a syntax error reading the max number of '// + & 'Size Distribution RUles for use by the DESID module. Please '// + & 'check the format of each line for syntax errors. The '// + & 'invalid line was likely: ' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + WRITE( LOGDEV, '(8x,A)' ) TMPLINE + CALL M3EXIT ( 'DESID_READ_NAMELIST', 0, 0, 'CMAQ must Crash until you '// + & 'fix Desid_Max_Sd', 1 ) + END IF + + ! Allocate and Initialize Namelist Variables + ALLOCATE( DESID_SD_NML( DESID_MAX_SD ), STAT=IOST ) + CALL CHECKMEM( IOST, 'DESID_SD_NML','DESID_READ_NAMELIST') + DESID_SD_NML%STREAM = '' + DESID_SD_NML%MODE = '' + DESID_SD_NML%MODE_REF = '' + + !!! Read the size distribution specification section + REWIND( FUNIT ) + READ( NML = Desid_SizeDist, UNIT = FUNIT, IOSTAT=IOST ) + IF ( IOST .EQ. -1 ) THEN + XMSG = 'Note: The Desid_SizeDist component of the Emissions Control '// + & 'Interface is missing. Default values for this section '// + & 'will be assumed.' + CALL LOG_MESSAGE( LOGDEV,' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + DESID_SD_NML%STREAM = '' + DESID_SD_NML%MODE = '' + DESID_SD_NML%MODE_REF = '' + ELSE IF ( IOST .NE. 0 ) THEN + ! Read Error Detected for DESID_SD_NML + backspace( FUNIT ) + read( FUNIT, fmt='(A)' ) tmpline + XMSG = 'ERROR: There was a syntax error reading the Desid_SizeDist '// + & 'variable for use by the DESID module. Please check the format of '// + & 'each line for syntax errors. The invalid line was likely: ' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + WRITE( LOGDEV, '(8x,A)' ) TMPLINE + CALL M3EXIT ( 'DESID_READ_NAMELIST', 0, 0, 'CMAQ must Crash until you '// + & 'fix the Size Distribution Rule', 1 ) + END IF + + !----------------------------------! + !!! DESID Diagnostic File Inputs !!! + ! Read the number of Max Emissions Rules to inform scaling operations + REWIND( FUNIT ) + READ( NML = Desid_DiagVars, UNIT = FUNIT, IOSTAT=IOST ) + IF ( IOST .EQ. -1 ) THEN + ! The DESID_N_Diag_Rules Variable was completely missing + XMSG = 'WARNING: Number of DESID Diagnostic Rules was not specified. '// + & 'If you intended to specify Desid_N_Diag_Rules, check the DESID_CTRL file.' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + DESID_N_DIAG_RULES = 0 + DESID_MAX_DIAG_STREAMS = 0 + DESID_MAX_DIAG_SPEC = 0 + + ELSE IF ( IOST .NE. 0 ) THEN + ! Read Error Detected for DESID_N_DIAG_RULES + backspace( FUNIT ) + read( FUNIT, fmt='(A)' ) tmpline + XMSG = 'ERROR: There was a syntax error reading the number of '// + & 'Diagnostic Rules for use by the DESID module. Please '// + & 'check the format of each line for syntax errors. The '// + & 'invalid line was likely: ' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + WRITE( LOGDEV, '(8x,A)' ) TMPLINE + CALL M3EXIT ( 'DESID_READ_NAMELIST', 0, 0, 'CMAQ must Crash until you '// + & 'fix Desid_N_Diag_Rules', 1 ) + END IF + + ! Allocate and Initialize Namelist Variables + ALLOCATE( DESID_DIAG_STREAMS_NML( DESID_N_DIAG_RULES,DESID_MAX_DIAG_SPEC ), + & DESID_DIAG_FMT_NML( DESID_N_DIAG_RULES ), + & DESID_DIAG_SPEC_NML( DESID_N_DIAG_RULES,DESID_MAX_DIAG_SPEC ), + & STAT=IOST ) + CALL CHECKMEM( IOST, 'DESID_DIAG_NML','DESID_READ_NAMELIST') + Desid_Diag_Streams_Nml = '' + Desid_Diag_Fmt_Nml = '' + Desid_Diag_Spec_Nml = '' + + ! Read the Emissions Diagnostic Section + REWIND( FUNIT ) + READ( NML = Desid_Diag, UNIT = FUNIT, IOSTAT=IOST ) + IF ( IOST .EQ. -1 ) THEN + ! The Emissions Diagnostic Section was completely missing + XMSG = 'WARNING: There were no valid Emission Diagnostic Values specified '// + & 'for use by the DESID module. If you intended to specify '// + & 'diagnostic output in the emission control interface, check the '// + & 'file you have provided for DESID_CTRL_NML.' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + Desid_Diag_Streams_Nml = '' + Desid_Diag_Fmt_Nml = '' + Desid_Diag_Spec_Nml = '' + ELSE IF ( IOST .NE. 0 ) THEN + ! Read Error for Emissions Diagnostic + backspace( FUNIT ) + read( FUNIT, fmt='(A)' ) tmpline + XMSG = 'ERROR: There was a syntax error reading Emission Diagnostic '// + & 'Variables for output by the DESID module. Please check the format of '// + & 'each line for syntax errors. The invalid line was likely: ' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + WRITE( LOGDEV, '(8x,A)' ) TMPLINE + CALL M3EXIT ( 'DESID_READ_NAMELIST', 0, 0, 'CMAQ must Crash until you '// + & 'fix the Emission Diagnostic Specification.', 1 ) + END IF + + CLOSE( UNIT = FUNIT ) + + END SUBROUTINE DESID_READ_NAMELIST + +!#ifdef mpas +! ------------------------------------------------------------------------- +! subroutine r_interpolate_var_1d (vname, date, time, data) +! +! use hgrd_defn, only : ncols, nrows +! use vgrd_defn, only : nlays +! USE UTILIO_DEFN +! use centralized_io_util_module, only : binary_search +! +! character (*), intent(in) :: vname +! integer, intent(in) :: date, time +! real, intent(out) :: data(:) +! +! integer :: var_loc +! character (40) :: msg +! +! var_loc = binary_search (vname, vname_2d, n2d_data) +! +! if (var_loc .gt. 0) then +! data = g2ddata(:,1,var_loc) +! else +! write (msg, *) ' Error: Cannot find species ', trim(vname) +! call prog_interrupt ( 'interpolate_var', 0, 0, msg, 1) +! end if +! +! end subroutine r_interpolate_var_1d +! +!! ------------------------------------------------------------------------- +! subroutine r_interpolate_var_1ds (fname, vname, date, time, data) +! +! use stk_prms, only : my_strt_src, my_end_src, my_nsrc +! use util_module, only : nextime, secsdiff +! use centralized_io_util_module, only : binary_search +! use util_module, only : time2sec +! +! character (*), intent(in) :: fname, vname +! integer, intent(in) :: date, time +! real, intent(out) :: data(:) +! +! integer :: head_beg_ind, head_end_ind, +! & tail_beg_ind, tail_end_ind, +! & store_beg_ind, store_end_ind, +! & var_loc, loc_head, loc_tail, m, r, c, +! & loc_jdate, loc_jtime, dsize, pt, loc_tstep +! integer, save :: prev_time = -1 +! integer, save :: prev_head_time = -1 +! integer, save :: prev_tail_time = -1 +! integer, save :: lcount = 0 +! real, save :: ratio1, ratio2 +! character(200) :: xmsg +! +! pt = binary_search (fname, cio_stack_file_name, NPTGRPS) +! +! var_loc = binary_search (vname, cio_stack_var_name(:,pt), n_cio_stack_emis_vars(pt)) +! +! if (var_loc .lt. 0) then +! write (cio_logdev, '(a9, a, a33)') 'Warning: ', trim(vname), ' is not available in a stack file.' +! write (xmsg, '(A9,A,A,A)' ) 'ERROR: ',trim(vname), ' is not available ', +! & 'on a Stack Emisison file. Simulation will now terminate.' +! call m3exit ( 'Centralized I/O Module', date, time, xmsg, 1 ) +! else +! dsize = my_nsrc(pt) +! +! loc_tstep = file_tstep(f_stk_emis(pt)) +! +! loc_head = head_stack_emis(var_loc, pt) +! loc_tail = tail_stack_emis(var_loc, pt) +! +! if ((cio_stack_emis_data_tstamp(1, loc_tail, var_loc, pt) .lt. date) .or. +!! & ((cio_stack_emis_data_tstamp(1, loc_tail, var_loc, pt) .eq. date) .and. +!! & (cio_stack_emis_data_tstamp(2, loc_tail, var_loc, pt) .eq. 0)) .or. +! & ((cio_stack_emis_data_tstamp(2, loc_tail, var_loc, pt) .lt. time) .and. +! & (cio_stack_emis_data_tstamp(1, loc_tail, var_loc, pt) .eq. date))) then +! +! loc_jdate = cio_stack_emis_data_tstamp(1, loc_tail, var_loc, pt) +! loc_jtime = cio_stack_emis_data_tstamp(2, loc_tail, var_loc, pt) +! CALL NEXTIME ( loc_jdate, loc_jtime, loc_tstep ) +! call retrieve_stack_data_mpas (loc_jdate, loc_jtime, fname, vname) +! loc_head = head_stack_emis(var_loc, pt) +! loc_tail = tail_stack_emis(var_loc, pt) +! end if +! +! if ((cio_stack_emis_data_tstamp(1, 2, var_loc, pt) .eq. date) .and. +! & (cio_stack_emis_data_tstamp(2, 2, var_loc, pt) .eq. time)) then +! count = count + 1 +! else +! +! cio_stack_emis_data_tstamp(1, 2, var_loc, pt) = date +! cio_stack_emis_data_tstamp(2, 2, var_loc, pt) = time +! +! if ((prev_time .ne. time) .or. +! & (prev_head_time .ne. cio_stack_emis_data_tstamp(2, loc_head, var_loc, pt)) .or. +! & (prev_tail_time .ne. cio_stack_emis_data_tstamp(2, loc_tail, var_loc, pt))) then +! +! if (cio_stack_emis_data_tstamp(1, loc_head, var_loc, pt) .eq. date) then +! ratio2 = real(secsdiff(time, cio_stack_emis_data_tstamp(2, loc_head, var_loc, pt))) +! & / real(time2sec(loc_tstep)) +! ratio1 = 1.0 - ratio2 +! else +! ratio2 = real(secsdiff(240000, cio_stack_emis_data_tstamp(2, loc_head, var_loc, pt))) +! & / real(time2sec(loc_tstep)) +! ratio1 = 1.0 - ratio2 +! end if +! prev_time = time +! prev_head_time = cio_stack_emis_data_tstamp(2, loc_head, var_loc, pt) +! prev_tail_time = cio_stack_emis_data_tstamp(2, loc_tail, var_loc, pt) +! +! if ( (ratio1 .lt. 0) .or. (ratio2 .lt. 0) +! & .or. (ratio1 .gt. 1) .or. (ratio2 .gt. 1)) then +! write(logdev,'(5X,a,a)'), +! & 'ERROR: Incorrect Interpolation in 1-D Stack Interpolation for variable: ', +! & trim(vname) +! +! write(logdev,'(5X,a,i7,a,i6)'), +! & 'Requested TIME & DATE: ',date,':',time +! +! write(logdev,'(5X,a,i7,a,i6,a,i7,a,i6)'), +! & 'Interpolation Bounds ',cio_stack_emis_data_tstamp(1,0,var_loc,pt), +! & ':',cio_stack_emis_data_tstamp(2,0,var_loc,pt),' to ', +! & cio_stack_emis_data_tstamp(1,1,var_loc,pt),':',cio_stack_emis_data_tstamp(2,1,var_loc,pt) +! call m3exit( 'Centralized I/O',date,time,'',1 ) +! write(logdev,'(5X,a)'), +! & 'ERROR: Program EXIT in subroutine r_interpolate_var_1ds in module centralized io' +! end if +! else +! lcount = lcount + 1 +! end if +! +! head_beg_ind = cio_stack_emis_data_inx(1,loc_head,var_loc, pt) +! head_end_ind = cio_stack_emis_data_inx(2,loc_head,var_loc, pt) +! tail_beg_ind = cio_stack_emis_data_inx(1,loc_tail,var_loc, pt) +! tail_end_ind = cio_stack_emis_data_inx(2,loc_tail,var_loc, pt) +! store_beg_ind = cio_stack_emis_data_inx(1,2,var_loc, pt) +! store_end_ind = cio_stack_emis_data_inx(2,2,var_loc, pt) +! +! cio_stack_data(store_beg_ind:store_end_ind) = cio_stack_data(head_beg_ind:head_end_ind) * ratio1 +! & + cio_stack_data(tail_beg_ind:tail_end_ind) * ratio2 +! +! end if +! +! store_beg_ind = cio_stack_emis_data_inx(1,2,var_loc, pt) +! +! data(1:dsize) = cio_stack_data(store_beg_ind:store_beg_ind+dsize-1) +! +! end if +! +! end subroutine r_interpolate_var_1ds +! +!! ------------------------------------------------------------------------- +! subroutine r_interpolate_var_2d (vname, date, time, data, +! & scol, ecol, srow, erow, slay) +! +! use hgrd_defn, only : ncols, nrows +! use vgrd_defn, only : nlays +! USE UTILIO_DEFN +! use centralized_io_util_module, only : binary_search +! +! character (*), intent(in) :: vname +! integer, intent(in) :: date, time +! real, intent(out) :: data(:,:) +! integer, intent(in), optional :: scol, ecol, srow, erow, slay +! +! integer :: var_loc +! character (40) :: msg +! +! var_loc = binary_search (vname, vname_2d, n2d_data) +! +! if (var_loc .gt. 0) then +! data = g2ddata(:,:,var_loc) +! else +! write (msg, *) ' Error: Cannot find species ', trim(vname) +! call prog_interrupt ( 'interpolate_var', 0, 0, msg, 1) +! end if +! +! end subroutine r_interpolate_var_2d +! +!! ------------------------------------------------------------------------- +! subroutine i_interpolate_var_2d (vname, date, time, data) +! +! use hgrd_defn, only : ncols, nrows +! use vgrd_defn, only : nlays +! USE UTILIO_DEFN +! use centralized_io_util_module, only : binary_search +! +! character (*), intent(in) :: vname +! integer, intent(in) :: date, time +! integer, intent(out) :: data(:,:) +! +! integer :: var_loc +! character (40) :: msg +! +! var_loc = binary_search (vname, vname_2d, n2d_data) +! +! if (var_loc .gt. 0) then +! data = g2ddata(:,:,var_loc) +! else +! write (msg, *) ' Error: Cannot find species ', trim(vname) +! call prog_interrupt ( 'interpolate_var', 0, 0, msg, 1) +! end if +! +! end subroutine i_interpolate_var_2d +! +!! ------------------------------------------------------------------------- +! subroutine r_interpolate_var_2dx (vname, date, time, data, flag) +! +! use hgrd_defn, only : ncols, nrows +! use vgrd_defn, only : nlays +! USE UTILIO_DEFN +! use centralized_io_util_module, only : binary_search +! +! character (*), intent(in) :: vname +! integer, intent(in) :: date, time +! logical, intent(in) :: flag +! real, intent(out) :: data(:,:) +! +! integer :: var_loc +! character (40) :: msg +! +! var_loc = binary_search (vname, vname_2d, n2d_data) +! +! if (var_loc .gt. 0) then +! data = g2ddata(:,:,var_loc) +! else +! write (msg, *) ' Error: Cannot find species ', trim(vname) +! call prog_interrupt ( 'interpolate_var', 0, 0, msg, 1) +! end if +! +! end subroutine r_interpolate_var_2dx +! +!! ------------------------------------------------------------------------- +! subroutine r_interpolate_var_3d (vname, date, time, data, fname) +! +! use hgrd_defn, only : ncols, nrows +! USE UTILIO_DEFN +! use util_module, only : nextime, secsdiff +! use centralized_io_util_module, only : binary_search +! use util_module, only : time2sec +! +! character (*), intent(in) :: vname +! integer, intent(in) :: date, time +! real, intent(out) :: data(:,:,:) +! character (*), intent(in), optional :: fname +! +! integer :: var_loc, slen, loc_head, loc_tail, +! & loc_jdate, loc_jtime, beg_k, end_k, +! & m, k, r, c, +! & head_beg_ind, head_end_ind, +! & tail_beg_ind, tail_end_ind, +! & store_beg_ind, store_end_ind, loc_tstep, fnum +! integer, save :: prev_time = -1 +! integer, save :: prev_head_time = -1 +! integer, save :: lcount = 0 +! real, save :: ratio1, ratio2 +! character (40) :: msg, loc_vname +! character (20) :: loc_mpas_time_stamp +! +! if (present(fname)) then +! slen = len_trim(fname) +! loc_vname = trim(vname) // fname(slen-3:slen) +! else +! loc_vname = vname +! end if +! +! var_loc = binary_search (loc_vname, vname_3d, n3d_data) +! +! if (var_loc .gt. 0) then +! data = g3ddata(:,:,:,var_loc) +! else +! +! var_loc = binary_search (loc_vname, cio_grid_var_name(:,1), n_cio_grid_vars) +! +! if (var_loc .lt. 0) then +! write (msg, *) ' Error: Cannot find species ', trim(vname) +! call prog_interrupt ( 'interpolate_var', 0, 0, msg, 1) +! else +! loc_head = head_grid(var_loc) +! loc_tail = tail_grid(var_loc) +! +! +! if (cio_grid_var_name(var_loc,3) == 'm') then +! loc_tstep = file_tstep(f_met) +! else if ((cio_grid_var_name(var_loc,2) == 'e2d') .or. +! & (cio_grid_var_name(var_loc,2) == 'e3d')) then +! +! slen = len_trim(cio_grid_var_name(var_loc,1)) +! read (cio_grid_var_name(var_loc,1)(slen-2:slen), *) fnum +! +! loc_tstep = file_tstep(f_emis(fnum)) +! else if (cio_grid_var_name(var_loc,2) == 'lnt') then +! loc_tstep = file_tstep(f_ltng) +! else if (cio_grid_var_name(var_loc,2) == 'ic') then +! loc_tstep = file_tstep(f_icon) +! else if (cio_grid_var_name(var_loc,2) == 'bct') then +! loc_tstep = file_tstep(f_bcon) +! else if (cio_grid_var_name(var_loc,2) == 'is') then +! loc_tstep = file_tstep(f_is_icon) +! end if +! +! call julian_to_mpas_date_time (date, time, loc_mpas_time_stamp) +! +! if (cio_mpas_grid_data_tstamp(loc_tail, var_loc) .lt. loc_mpas_time_stamp) then +! +! call mpas_date_time_to_julian (cio_mpas_grid_data_tstamp(loc_tail, var_loc), loc_jdate, loc_jtime) +! +! call retrieve_time_dep_gridded_data (loc_jdate, loc_jtime, loc_vname) +! loc_head = head_grid(var_loc) +! loc_tail = tail_grid(var_loc) +! end if +! +! if ((cio_grid_data_tstamp(1, 2, var_loc) .eq. date) .and. +! & (cio_grid_data_tstamp(2, 2, var_loc) .eq. time)) then +! count = count + 1 +! else +! +! cio_grid_data_tstamp(1, 2, var_loc) = date +! cio_grid_data_tstamp(2, 2, var_loc) = time +! +! +! if ((prev_time .ne. time) .or. +! & (prev_head_time .ne. cio_grid_data_tstamp(2, loc_head, var_loc))) then +! if (cio_grid_data_tstamp(1, loc_head, var_loc) .eq. date) then +! ratio2 = real(secsdiff(time, cio_grid_data_tstamp(2, loc_head, var_loc))) +! & / real(time2sec(loc_tstep)) +! ratio1 = 1.0 - ratio2 +! else +! ratio2 = real(secsdiff(240000, cio_grid_data_tstamp(2, loc_head, var_loc))) +! & / real(time2sec(loc_tstep)) +! ratio1 = 1.0 - ratio2 +! end if +! prev_time = time +! prev_head_time = cio_grid_data_tstamp(2, loc_head, var_loc) +! else +! lcount = lcount + 1 +! end if +! +! head_beg_ind = cio_grid_data_inx(1,loc_head,var_loc) +! head_end_ind = cio_grid_data_inx(2,loc_head,var_loc) +! tail_beg_ind = cio_grid_data_inx(1,loc_tail,var_loc) +! tail_end_ind = cio_grid_data_inx(2,loc_tail,var_loc) +! store_beg_ind = cio_grid_data_inx(1,2,var_loc) +! store_end_ind = cio_grid_data_inx(2,2,var_loc) +! +! cio_grid_data(store_beg_ind:store_end_ind) = cio_grid_data(head_beg_ind:head_end_ind) * ratio1 +! & + cio_grid_data(tail_beg_ind:tail_end_ind) * ratio2 +! +! end if +! +! beg_k = 1 +! if (cio_grid_var_name(var_loc, 2) .eq. 'e2d') then +! end_k = 1 +! else +! end_k = size(data,3) +! end if +! +! store_beg_ind = cio_grid_data_inx(1,2,var_loc) +! m = store_beg_ind - 1 +! do k = beg_k, end_k +! do r = 1, size(data,2) +! do c = 1, size(data,1) +! m = m + 1 +! data(c,r,k) = cio_grid_data(m) +! end do +! end do +! end do +! +! end if +! end if +! +! end subroutine r_interpolate_var_3d +! +!#else +! ------------------------------------------------------------------------- + subroutine r_interpolate_var_1ds (fname, vname, date, time, data) + +! Function: Interpolation for Stack Group Real 1-D Data + + USE UTILIO_DEFN + USE STK_PRMS, only : MY_STRT_SRC, MY_END_SRC + + character (*), intent(in) :: fname, vname + integer, intent(in) :: date, time + real, intent(out) :: data(:) + + integer :: head_beg_ind, head_end_ind, + & tail_beg_ind, tail_end_ind, + & store_beg_ind, store_end_ind, + & var_loc, loc_head, loc_tail, m, r, c, + & loc_jdate, loc_jtime, dsize, pt, loc_tstep + integer, save :: prev_time = -1 + integer, save :: prev_head_time = -1 + integer, save :: prev_tail_time = -1 + integer, save :: lcount = 0 + real, save :: ratio1, ratio2 + character(200) :: xmsg + + pt = binary_search (fname, cio_stack_file_name, NPTGRPS) + + var_loc = binary_search (vname, cio_stack_var_name(:,pt), n_cio_stack_emis_vars(pt)) + + if (var_loc .lt. 0) then + write (cio_logdev, '(a9, a, a33)') 'Warning: ', trim(vname), ' is not available in a stack file.' + write (xmsg, '(A9,A,A,A)' ) 'ERROR: ',trim(vname), ' is not available ', + & 'on a Stack Emisison file. Simulation will now terminate.' + call m3exit ( 'Centralized I/O Module', date, time, xmsg, 1 ) + else + dsize = MY_END_SRC( pt ) - MY_STRT_SRC( pt ) + 1 + + loc_tstep = file_tstep(f_stk_emis(pt)) + + loc_head = head_stack_emis(var_loc, pt) + loc_tail = tail_stack_emis(var_loc, pt) + + if ((cio_stack_emis_data_tstamp(1, loc_tail, var_loc, pt) .lt. date) .or. +! & ((cio_stack_emis_data_tstamp(1, loc_tail, var_loc, pt) .eq. date) .and. +! & (cio_stack_emis_data_tstamp(2, loc_tail, var_loc, pt) .eq. 0)) .or. + & ((cio_stack_emis_data_tstamp(2, loc_tail, var_loc, pt) .lt. time) .and. + & (cio_stack_emis_data_tstamp(1, loc_tail, var_loc, pt) .eq. date))) then + + loc_jdate = cio_stack_emis_data_tstamp(1, loc_tail, var_loc, pt) + loc_jtime = cio_stack_emis_data_tstamp(2, loc_tail, var_loc, pt) + CALL NEXTIME ( loc_jdate, loc_jtime, loc_tstep ) + call retrieve_stack_data (loc_jdate, loc_jtime, fname, vname) + loc_head = head_stack_emis(var_loc, pt) + loc_tail = tail_stack_emis(var_loc, pt) + end if + + if ((cio_stack_emis_data_tstamp(1, 2, var_loc, pt) .eq. date) .and. + & (cio_stack_emis_data_tstamp(2, 2, var_loc, pt) .eq. time)) then + count = count + 1 + else + + cio_stack_emis_data_tstamp(1, 2, var_loc, pt) = date + cio_stack_emis_data_tstamp(2, 2, var_loc, pt) = time + + if ((prev_time .ne. time) .or. + & (prev_head_time .ne. cio_stack_emis_data_tstamp(2, loc_head, var_loc, pt)) .or. + & (prev_tail_time .ne. cio_stack_emis_data_tstamp(2, loc_tail, var_loc, pt))) then + + if (cio_stack_emis_data_tstamp(1, loc_head, var_loc, pt) .eq. date) then + ratio2 = real(time_diff(time, cio_stack_emis_data_tstamp(2, loc_head, var_loc, pt))) + & / real(time2sec(loc_tstep)) + ratio1 = 1.0 - ratio2 + else + ratio2 = real(time_diff(240000, cio_stack_emis_data_tstamp(2, loc_head, var_loc, pt))) + & / real(time2sec(loc_tstep)) + ratio1 = 1.0 - ratio2 + end if + prev_time = time + prev_head_time = cio_stack_emis_data_tstamp(2, loc_head, var_loc, pt) + prev_tail_time = cio_stack_emis_data_tstamp(2, loc_tail, var_loc, pt) + +#ifdef verbose_cio + if ( (ratio1 .lt. 0) .or. (ratio2 .lt. 0) + & .or. (ratio1 .gt. 1) .or. (ratio2 .gt. 1)) then + write(logdev,'(5X,a,a)'), + & 'ERROR: Incorrect Interpolation in 1-D Stack Interpolation for variable: ', + & trim(vname) + + write(logdev,'(5X,a,i7,a,i6)'), + & 'Requested TIME & DATE: ',date,':',time + + write(logdev,'(5X,a,i7,a,i6,a,i7,a,i6)'), + & 'Interpolation Bounds ',cio_stack_emis_data_tstamp(1,0,var_loc,pt), + & ':',cio_stack_emis_data_tstamp(2,0,var_loc,pt),' to ', + & cio_stack_emis_data_tstamp(1,1,var_loc,pt),':',cio_stack_emis_data_tstamp(2,1,var_loc,pt) + call m3exit( 'Centralized I/O',date,time,'',1 ) + write(logdev,'(5X,a)'), + & 'ERROR: Program EXIT in subroutine r_interpolate_var_1ds in module centralized io' + end if +#endif + else + lcount = lcount + 1 + end if + + head_beg_ind = cio_stack_emis_data_inx(1,loc_head,var_loc, pt) + head_end_ind = cio_stack_emis_data_inx(2,loc_head,var_loc, pt) + tail_beg_ind = cio_stack_emis_data_inx(1,loc_tail,var_loc, pt) + tail_end_ind = cio_stack_emis_data_inx(2,loc_tail,var_loc, pt) + store_beg_ind = cio_stack_emis_data_inx(1,2,var_loc, pt) + store_end_ind = cio_stack_emis_data_inx(2,2,var_loc, pt) + + cio_stack_data(store_beg_ind:store_end_ind) = cio_stack_data(head_beg_ind:head_end_ind) * ratio1 + & + cio_stack_data(tail_beg_ind:tail_end_ind) * ratio2 + + end if + + store_beg_ind = cio_stack_emis_data_inx(1,2,var_loc, pt) + + data(1:dsize) = cio_stack_data(store_beg_ind:store_beg_ind+dsize-1) + + end if + + end subroutine r_interpolate_var_1ds + +! ------------------------------------------------------------------------- + subroutine r_interpolate_var_2d (vname, date, time, data, + & scol, ecol, srow, erow, slay) + +! Function: Interpolation for generic Real 2-D Data + + USE UTILIO_DEFN + use HGRD_DEFN, only : ncols, nrows + USE VGRD_DEFN, ONLY : NLAYS + + character (*), intent(in) :: vname + integer, intent(in) :: date, time + real, intent(out) :: data(:,:) + integer, intent(in), optional :: scol, ecol, srow, erow, slay + + integer :: head_beg_ind, head_end_ind, + & tail_beg_ind, tail_end_ind, + & store_beg_ind, store_end_ind, + & var_loc, loc_head, loc_tail, m, r, c, + & loc_jdate, loc_jtime, adj_lvl, adj1, adj2, + & loc_size_spatial, loc_tstep, str_len, fnum + integer, save :: prev_time = -1 + integer, save :: prev_head_time = -1 + integer, save :: prev_tail_time = -1 + integer, save :: lcount = 0 + real, save :: ratio1, ratio2 + character(200) :: xmsg + + var_loc = binary_search (vname, cio_grid_var_name(:,1), n_cio_grid_vars) + if (var_loc .lt. 0) then + write (xmsg, '(A9,A,A,A)' ) 'ERROR: ',trim(vname), ' is not available ', + & 'on any 2D file. Simulation will now terminate.' + call m3exit ( 'Centralized I/O Module', date, time, xmsg, 1 ) + else + loc_head = head_grid(var_loc) + loc_tail = tail_grid(var_loc) + + if (cio_grid_var_name(var_loc,3) == 'm') then + loc_tstep = file_tstep(f_met) + else if ((cio_grid_var_name(var_loc,2) == 'e2d') .or. + & (cio_grid_var_name(var_loc,2) == 'e3d')) then + + str_len = len_trim(cio_grid_var_name(var_loc,1)) + read (cio_grid_var_name(var_loc,1)(str_len-2:str_len), *) fnum + + loc_tstep = file_tstep(f_emis(fnum)) + else if (cio_grid_var_name(var_loc,2) == 'lnt') then + loc_tstep = file_tstep(f_ltng) + else if (cio_grid_var_name(var_loc,2) == 'ic') then + loc_tstep = file_tstep(f_icon) + else if (cio_grid_var_name(var_loc,2) == 'bct') then + loc_tstep = file_tstep(f_bcon) + else if (cio_grid_var_name(var_loc,2) == 'is') then + loc_tstep = file_tstep(f_is_icon) + end if + + if (cio_grid_var_name(var_loc,2) .eq. 'md3') then + loc_size_spatial = size_d2dx + else + loc_size_spatial = size_c3d / nlays + end if + + if ((cio_grid_data_tstamp(1, loc_tail, var_loc) .lt. date) .or. + & ((cio_grid_data_tstamp(2, loc_tail, var_loc) .lt. time) .and. + & (cio_grid_data_tstamp(1, loc_tail, var_loc) .eq. date))) then + + loc_jdate = cio_grid_data_tstamp(1, loc_tail, var_loc) + loc_jtime = cio_grid_data_tstamp(2, loc_tail, var_loc) + + CALL NEXTIME ( loc_jdate, loc_jtime, loc_tstep ) + + call retrieve_time_dep_gridded_data (loc_jdate, loc_jtime, vname) + loc_head = head_grid(var_loc) + loc_tail = tail_grid(var_loc) + end if + + if ((cio_grid_data_tstamp(1, 2, var_loc) .eq. date) .and. + & (cio_grid_data_tstamp(2, 2, var_loc) .eq. time)) then + count = count + 1 + else + + cio_grid_data_tstamp(1, 2, var_loc) = date + cio_grid_data_tstamp(2, 2, var_loc) = time + + if ((prev_time .ne. time) .or. + & (prev_head_time .ne. cio_grid_data_tstamp(2, loc_head, var_loc)) .or. + & (prev_tail_time .ne. cio_grid_data_tstamp(2, loc_tail, var_loc))) then + + if (cio_grid_data_tstamp(1, loc_head, var_loc) .eq. date) then + ratio2 = real(time_diff(time, cio_grid_data_tstamp(2, loc_head, var_loc))) + & / real(time2sec(loc_tstep)) + ratio1 = 1.0 - ratio2 + else + ratio2 = real(time_diff(240000, cio_grid_data_tstamp(2, loc_head, var_loc))) + & / real(time2sec(loc_tstep)) + ratio1 = 1.0 - ratio2 + end if + prev_time = time + prev_head_time = cio_grid_data_tstamp(2, loc_head, var_loc) + prev_tail_time = cio_grid_data_tstamp(2, loc_tail, var_loc) + +#ifdef verbose_cio + if ( (ratio1 .lt. 0) .or. (ratio2 .lt. 0) + & .or. (ratio1 .gt. 1) .or. (ratio2 .gt. 1)) then + write(logdev,'(5X,a,a)'), + & 'ERROR: Incorrect Interpolation in 2-D Generic Real Interpolation for variable: ', + & trim(vname) + + write(logdev,'(5X,a,i7,a,i6)'), + & 'Requested TIME & DATE: ',date,':',time + + write(logdev,'(5X,a,i7,a,i6,a,i7,a,i6)'), + & 'Interpolation Bounds ',cio_grid_data_tstamp(1,0,var_loc), + & ':',cio_grid_data_tstamp(2,0,var_loc),' to ', + & cio_grid_data_tstamp(1,1,var_loc),':',cio_grid_data_tstamp(2,1,var_loc) + + write(logdev,'(5X,a)'), + & 'ERROR: Program EXIT in subroutine r_interpolate_var_2d in module centralized io' + + call m3exit( 'Centralized I/O',date,time,'',1 ) + end if +#endif + else + lcount = lcount + 1 + end if + + head_beg_ind = cio_grid_data_inx(1,loc_head,var_loc) + head_end_ind = cio_grid_data_inx(2,loc_head,var_loc) + tail_beg_ind = cio_grid_data_inx(1,loc_tail,var_loc) + tail_end_ind = cio_grid_data_inx(2,loc_tail,var_loc) + store_beg_ind = cio_grid_data_inx(1,2,var_loc) + store_end_ind = cio_grid_data_inx(2,2,var_loc) + + cio_grid_data(store_beg_ind:store_end_ind) = cio_grid_data(head_beg_ind:head_end_ind) * ratio1 + & + cio_grid_data(tail_beg_ind:tail_end_ind) * ratio2 + end if + + adj_lvl = 0 + adj1 = 0 + adj2 = 0 + if (present(slay)) then + if (cio_grid_var_name(var_loc,2) .eq. 'mc3') then + if ((window) .and. + & ((size(data,1) - ncols) .eq. 0)) then + adj1 = ncols + 3 + adj2 = 2 + end if + adj_lvl = (slay - 1) * loc_size_spatial + else if (cio_grid_var_name(var_loc,2) .eq. 'md3') then + adj_lvl = (slay - 1) * size_d2dx +#ifndef twoway + if (.not. east_pe) then + adj2 = 1 + end if +#endif + end if + else if (cio_grid_var_name(var_loc,2) .eq. 'mc2') then +#ifndef twoway + if (.not. east_pe) then + adj2 = 1 + end if +#endif + end if + + store_beg_ind = cio_grid_data_inx(1,2,var_loc) + m = store_beg_ind - 1 + adj_lvl + adj1 + + do r = 1, size(data,2) + do c = 1, size(data,1) + m = m + 1 + data(c,r) = cio_grid_data(m) + end do + m = m + adj2 + end do + end if + + end subroutine r_interpolate_var_2d + +! ------------------------------------------------------------------------- + subroutine i_interpolate_var_2d (vname, date, time, data) + +! Function: Interpolation for generic 4 byte Integer 2-D Data + + USE UTILIO_DEFN + use HGRD_DEFN, only : ncols, nrows + USE VGRD_DEFN, ONLY : NLAYS + + character (*), intent(in) :: vname + integer, intent(in) :: date, time + integer, intent(out) :: data(:,:) + + integer :: head_beg_ind, head_end_ind, + & tail_beg_ind, tail_end_ind, + & store_beg_ind, store_end_ind, + & var_loc, loc_head, loc_tail, m, r, c, + & loc_jdate, loc_jtime, adj_lvl, adj1, adj2, + & loc_size_spatial, loc_tstep, str_len, fnum + integer, save :: prev_time = -1 + integer, save :: prev_head_time = -1 + integer, save :: prev_tail_time = -1 + integer, save :: lcount = 0 + real, save :: ratio1, ratio2 + character(200) :: xmsg + + var_loc = binary_search (vname, cio_grid_var_name(:,1), n_cio_grid_vars) + if (var_loc .lt. 0) then + write (xmsg, '(A9,A,A,A)' ) 'ERROR: ',trim(vname), ' is not available ', + & 'on any 2D file. Simulation will now terminate.' + call m3exit ( 'Centralized I/O Module', date, time, xmsg, 1 ) + else + loc_head = head_grid(var_loc) + loc_tail = tail_grid(var_loc) + + if (cio_grid_var_name(var_loc,3) == 'm') then + loc_tstep = file_tstep(f_met) + else if ((cio_grid_var_name(var_loc,2) == 'e2d') .or. + & (cio_grid_var_name(var_loc,2) == 'e3d')) then + + str_len = len_trim(cio_grid_var_name(var_loc,1)) + read (cio_grid_var_name(var_loc,1)(str_len-2:str_len), *) fnum + + loc_tstep = file_tstep(f_emis(fnum)) + else if (cio_grid_var_name(var_loc,2) == 'lnt') then + loc_tstep = file_tstep(f_ltng) + else if (cio_grid_var_name(var_loc,2) == 'ic') then + loc_tstep = file_tstep(f_icon) + else if (cio_grid_var_name(var_loc,2) == 'bct') then + loc_tstep = file_tstep(f_bcon) + else if (cio_grid_var_name(var_loc,2) == 'is') then + loc_tstep = file_tstep(f_is_icon) + end if + + if (cio_grid_var_name(var_loc,2) .eq. 'md3') then + loc_size_spatial = size_d2dx + else + loc_size_spatial = size_c3d / nlays + end if + + if ((cio_grid_data_tstamp(1, loc_tail, var_loc) .lt. date) .or. + & ((cio_grid_data_tstamp(2, loc_tail, var_loc) .lt. time) .and. + & (cio_grid_data_tstamp(1, loc_tail, var_loc) .eq. date))) then + + loc_jdate = cio_grid_data_tstamp(1, loc_tail, var_loc) + loc_jtime = cio_grid_data_tstamp(2, loc_tail, var_loc) + CALL NEXTIME ( loc_jdate, loc_jtime, loc_tstep ) + call retrieve_time_dep_gridded_data (loc_jdate, loc_jtime, vname) + loc_head = head_grid(var_loc) + loc_tail = tail_grid(var_loc) + end if + + if ((cio_grid_data_tstamp(1, 2, var_loc) .eq. date) .and. + & (cio_grid_data_tstamp(2, 2, var_loc) .eq. time)) then + count = count + 1 + else + + cio_grid_data_tstamp(1, 2, var_loc) = date + cio_grid_data_tstamp(2, 2, var_loc) = time + + if ((prev_time .ne. time) .or. + & (prev_head_time .ne. cio_grid_data_tstamp(2, loc_head, var_loc)) .or. + & (prev_tail_time .ne. cio_grid_data_tstamp(2, loc_tail, var_loc))) then + + if (cio_grid_data_tstamp(1, loc_head, var_loc) .eq. date) then + ratio2 = real(time_diff(time, cio_grid_data_tstamp(2, loc_head, var_loc))) + & / real(time2sec(loc_tstep)) + ratio1 = 1.0 - ratio2 + else + ratio2 = real(time_diff(240000, cio_grid_data_tstamp(2, loc_head, var_loc))) + & / real(time2sec(loc_tstep)) + ratio1 = 1.0 - ratio2 + end if + prev_time = time + prev_head_time = cio_grid_data_tstamp(2, loc_head, var_loc) + prev_tail_time = cio_grid_data_tstamp(2, loc_tail, var_loc) + +#ifdef verbose_cio + if ( (ratio1 .lt. 0) .or. (ratio2 .lt. 0) + & .or. (ratio1 .gt. 1) .or. (ratio2 .gt. 1)) then + write(logdev,'(5X,a,a)'), + & 'ERROR: Incorrect Interpolation in 2-D Generic Integer Interpolation for variable: ', + & trim(vname) + + write(logdev,'(5X,a,i7,a,i6)'), + & 'Requested TIME & DATE: ',date,':',time + + write(logdev,'(5X,a,i7,a,i6,a,i7,a,i6)'), + & 'Interpolation Bounds ',cio_grid_data_tstamp(1,0,var_loc), + & ':',cio_grid_data_tstamp(2,0,var_loc),' to ', + & cio_grid_data_tstamp(1,1,var_loc),':',cio_grid_data_tstamp(2,1,var_loc) + + call m3exit( 'Centralized I/O',date,time,'',1 ) + write(logdev,'(5X,a)'), + & 'ERROR: Program EXIT in subroutine i_interpolate_var_2d in module centralized io' + + end if +#endif + else + lcount = lcount + 1 + end if + + head_beg_ind = cio_grid_data_inx(1,loc_head,var_loc) + head_end_ind = cio_grid_data_inx(2,loc_head,var_loc) + tail_beg_ind = cio_grid_data_inx(1,loc_tail,var_loc) + tail_end_ind = cio_grid_data_inx(2,loc_tail,var_loc) + store_beg_ind = cio_grid_data_inx(1,2,var_loc) + store_end_ind = cio_grid_data_inx(2,2,var_loc) + + cio_grid_data(store_beg_ind:store_end_ind) = cio_grid_data(head_beg_ind:head_end_ind) * ratio1 + & + cio_grid_data(tail_beg_ind:tail_end_ind) * ratio2 + + end if + + adj_lvl = 0 + adj1 = 0 + adj2 = 0 + + store_beg_ind = cio_grid_data_inx(1,2,var_loc) + m = store_beg_ind - 1 + adj_lvl + adj1 + + do r = 1, size(data,2) + do c = 1, size(data,1) + m = m + 1 + data(c,r) = int(cio_grid_data(m)) + end do + m = m + adj2 + end do + end if + + end subroutine i_interpolate_var_2d + +! ------------------------------------------------------------------------- + subroutine r_interpolate_var_2db (vname, date, time, data, type, lvl) + +! Function: Interpolation for Boundary Real 2-D Data + + USE UTILIO_DEFN + USE HGRD_DEFN + USE VGRD_DEFN, ONLY : NLAYS + + character (*), intent(in) :: vname + character (1), intent(in) :: type + integer, intent(in) :: date, time + real, intent(out) :: data(:,:) + integer, intent(in), optional :: lvl + + integer :: head_beg_ind, head_end_ind, + & tail_beg_ind, tail_end_ind, + & store_beg_ind, store_end_ind, + & var_loc, loc_head, loc_tail, m, r, c,k, ib, + & loc_jdate, loc_jtime, starting_pt, mype_p1, + & beg_k, end_k, loc_tstep + integer, save :: lns_size, lew_size, gns_size, gew_size, + & ls_start, ls_end, ln_start, ln_end, + & le_start, le_end, lw_start, lw_end, + & gs_skip, ge_skip, gn_skip, gw_skip + logical, save :: loc_firstime = .true. + integer, save :: prev_time = -1 + real :: ratio1, ratio2 + character(200) :: xmsg + + if (loc_firstime) then + loc_firstime = .false. + + mype_p1 = mype + 1 + LNS_SIZE = NTHIK * ( NCOLS + NTHIK ) + LEW_SIZE = NTHIK * ( NROWS + NTHIK ) + + LS_START = 1 + LS_END = LNS_SIZE + LE_START = LS_END + 1 + LE_END = LE_START + LEW_SIZE - 1 + LN_START = LE_END + 1 + LN_END = LN_START + LNS_SIZE - 1 + LW_START = LN_END + 1 + LW_END = LW_START + LEW_SIZE - 1 + + GNS_SIZE = NTHIK * ( GL_NCOLS + NTHIK ) + GEW_SIZE = NTHIK * ( GL_NROWS + NTHIK ) + + GS_SKIP = NTHIK*( COLSX_PE( 1, mype_p1 ) - 1 ) - LS_START + 1 + GE_SKIP = GNS_SIZE + NTHIK*( ROWSX_PE( 1, mype_p1 ) - 1 ) - LE_START + 1 + GN_SKIP = GNS_SIZE + GEW_SIZE + NTHIK*( COLSX_PE( 1, mype_p1 ) - 1 ) - LN_START + 1 + GW_SKIP = 2*GNS_SIZE + GEW_SIZE + NTHIK*( ROWSX_PE( 1, mype_p1 ) - 1 ) - LW_START + 1 + + end if + + var_loc = binary_search (vname, cio_bndy_var_name(:,1), n_cio_bndy_vars) + + if (var_loc .lt. 0) then + write (xmsg, '(A9,A,A,A)' ) 'ERROR: ',trim(vname), ' is not available ', + & 'on any BNDY file. Simulation will now terminate.' + call m3exit ( 'Centralized I/O Module', date, time, xmsg, 1 ) + else + loc_head = head_bndy(var_loc) + loc_tail = tail_bndy(var_loc) + + if (cio_bndy_var_name(var_loc,2) == 'mb') then + loc_tstep = file_tstep(f_met) + else + loc_tstep = file_tstep(f_bcon) + end if + + if (cio_bndy_var_name(var_loc, 2) .ne. 'bc') then + if ((cio_bndy_data_tstamp(1, loc_tail, var_loc) .lt. date) .or. + & ((cio_bndy_data_tstamp(2, loc_tail, var_loc) .lt. time) .and. + & (cio_bndy_data_tstamp(1, loc_tail, var_loc) .eq. date))) then + + loc_jdate = cio_bndy_data_tstamp(1, loc_tail, var_loc) + loc_jtime = cio_bndy_data_tstamp(2, loc_tail, var_loc) + + CALL NEXTIME ( loc_jdate, loc_jtime, loc_tstep ) + + call retrieve_boundary_data (loc_jdate, loc_jtime, vname) + + loc_head = head_bndy(var_loc) + loc_tail = tail_bndy(var_loc) + end if + end if + + if ((cio_bndy_data_tstamp(1, 2, var_loc) .eq. date) .and. + & (cio_bndy_data_tstamp(2, 2, var_loc) .eq. time)) then + count = count + 1 + else + + cio_bndy_data_tstamp(1, 2, var_loc) = date + cio_bndy_data_tstamp(2, 2, var_loc) = time + + head_beg_ind = cio_bndy_data_inx(1,loc_head,var_loc) + head_end_ind = cio_bndy_data_inx(2,loc_head,var_loc) + tail_beg_ind = cio_bndy_data_inx(1,loc_tail,var_loc) + tail_end_ind = cio_bndy_data_inx(2,loc_tail,var_loc) + store_beg_ind = cio_bndy_data_inx(1,2,var_loc) + store_end_ind = cio_bndy_data_inx(2,2,var_loc) + + if (cio_bndy_var_name(var_loc, 2) == 'bc') then + cio_bndy_data(store_beg_ind:store_end_ind) = cio_bndy_data(head_beg_ind:head_end_ind) + else + if (cio_bndy_data_tstamp(1, loc_head, var_loc) .eq. date) then + ratio2 = real(time_diff(time, cio_bndy_data_tstamp(2, loc_head, var_loc))) + & / real(time2sec(loc_tstep)) + ratio1 = 1.0 - ratio2 + else + ratio2 = real(time_diff(240000, cio_bndy_data_tstamp(2, loc_head, var_loc))) + & / real(time2sec(loc_tstep)) + ratio1 = 1.0 - ratio2 + end if + prev_time = time + +#ifdef verbose_cio + if ( (ratio1 .lt. 0) .or. (ratio2 .lt. 0) + & .or. (ratio1 .gt. 1) .or. (ratio2 .gt. 1)) then + write(logdev,'(5X,a)'), + & 'ERROR: Incorrect Interpolation in 2-D Boundary Interpolation for variable: ', + & trim(vname) + + write(logdev,'(5X,a,i7,a,i6)'), + & 'Requested TIME & DATE: ',date,':',time + + write(logdev,'(5X,a,i7,a,i6,a,i7,a,i6)'), + & 'Interpolation Bounds ',cio_bndy_data_tstamp(1,0,var_loc), + & ':',cio_bndy_data_tstamp(2,0,var_loc),' to ', + & cio_bndy_data_tstamp(1,1,var_loc),':',cio_bndy_data_tstamp(2,1,var_loc) + + call m3exit( 'Centralized I/O',date,time,'',1 ) + + write(logdev,'(5X,a)'), + & 'ERROR: Program EXIT in subroutine r_interpolate_var_2db in module centralized io' + + end if +#endif + cio_bndy_data(store_beg_ind:store_end_ind) = cio_bndy_data(head_beg_ind:head_end_ind) * ratio1 + & + cio_bndy_data(tail_beg_ind:tail_end_ind) * ratio2 + + end if + + end if + + if (present(lvl)) then + beg_k = lvl + end_k = lvl + else + beg_k = 1 + end_k = nlays + end if + + data = 0.0 + store_beg_ind = cio_bndy_data_inx(1,2,var_loc) + DO k = beg_k, end_k + starting_pt = store_beg_ind + (k - 1) * size_b2d - 1 +! Construct SOUTH boundary + IF ( SOUTH_PE ) THEN + m = starting_pt + GS_SKIP + DO IB = LS_START, LS_END + data( IB,k ) = cio_bndy_data( m+IB ) + END DO + END IF + +! Construct EAST boundary + IF ( EAST_PE ) THEN + m = starting_pt + GE_SKIP + DO IB = LE_START, LE_END + data( IB,k ) = cio_bndy_data( m+IB) + END DO + END IF + +! Construct NORTH boundary + IF ( NORTH_PE ) THEN + m = starting_pt + GN_SKIP + DO IB = LN_START, LN_END + data( IB,k ) = cio_bndy_data( m+IB) + END DO + END IF + +! Construct WEST boundary + IF ( WEST_PE ) THEN + m = starting_pt + GW_SKIP + DO IB = LW_START, LW_END + data( IB,k ) = cio_bndy_data( m+IB) + END DO + END IF + END DO + + end if + + end subroutine r_interpolate_var_2db + +! ------------------------------------------------------------------------- + subroutine r_interpolate_var_3d (vname, date, time, data, fname) + +!Function: Interpolation for generic Real 3-D Data + + USE UTILIO_DEFN + use HGRD_DEFN, only : ncols, nrows + + character (*), intent(in) :: vname + integer, intent(in) :: date, time + real, intent(out) :: data(:,:,:) + character (*), intent(in), optional :: fname + + integer :: head_beg_ind, head_end_ind, + & tail_beg_ind, tail_end_ind, + & store_beg_ind, store_end_ind, + & var_loc, loc_head, loc_tail, m, r, c, k, + & loc_jdate, loc_jtime, beg_k, end_k, dot, + & col_size, extra_c, extra_r, adj1, adj2, adj3, + & slen, str_len, fnum, loc_tstep + + character (20) :: loc_vname + integer, save :: prev_time = -1 + integer, save :: prev_head_time = -1 + integer, save :: prev_tail_time = -1 + integer, save :: lcount = 0 + real, save :: ratio1, ratio2 + character(200) :: xmsg + + if (present(fname)) then + slen = len_trim(fname) + loc_vname = trim(vname) // fname(slen-3:slen) + else + loc_vname = vname + end if + + var_loc = binary_search (loc_vname, cio_grid_var_name(:,1), n_cio_grid_vars) + if (var_loc .lt. 0) then + write (xmsg, '(A9,A,A,A)' ) 'ERROR: ',trim(vname), ' is not available ', + & 'on any 3D file. Simulation will now terminate.' + call m3exit ( 'Centralized I/O Module', date, time, xmsg, 1 ) + else + loc_head = head_grid(var_loc) + loc_tail = tail_grid(var_loc) + + if (cio_grid_var_name(var_loc,3) == 'm') then + loc_tstep = file_tstep(f_met) + else if ((cio_grid_var_name(var_loc,2) == 'e2d') .or. + & (cio_grid_var_name(var_loc,2) == 'e3d')) then + + str_len = len_trim(cio_grid_var_name(var_loc,1)) + read (cio_grid_var_name(var_loc,1)(str_len-2:str_len), *) fnum + + loc_tstep = file_tstep(f_emis(fnum)) + else if (cio_grid_var_name(var_loc,2) == 'lnt') then + loc_tstep = file_tstep(f_ltng) + else if (cio_grid_var_name(var_loc,2) == 'ic') then + loc_tstep = file_tstep(f_icon) + else if (cio_grid_var_name(var_loc,2) == 'bct') then + loc_tstep = file_tstep(f_bcon) + else if (cio_grid_var_name(var_loc,2) == 'is') then + loc_tstep = file_tstep(f_is_icon) + end if + + if (cio_grid_var_name(var_loc,2) .ne. 'ic') then + if ((cio_grid_data_tstamp(1, loc_tail, var_loc) .lt. date) .or. + & ((cio_grid_data_tstamp(2, loc_tail, var_loc) .lt. time) .and. + & (cio_grid_data_tstamp(1, loc_tail, var_loc) .eq. date))) then + + loc_jdate = cio_grid_data_tstamp(1, loc_tail, var_loc) + loc_jtime = cio_grid_data_tstamp(2, loc_tail, var_loc) + + CALL NEXTIME ( loc_jdate, loc_jtime, loc_tstep ) + + call retrieve_time_dep_gridded_data (loc_jdate, loc_jtime, loc_vname) + loc_head = head_grid(var_loc) + loc_tail = tail_grid(var_loc) + end if + end if + + if ((cio_grid_data_tstamp(1, 2, var_loc) .eq. date) .and. + & (cio_grid_data_tstamp(2, 2, var_loc) .eq. time)) then + count = count + 1 + else + + head_beg_ind = cio_grid_data_inx(1,loc_head,var_loc) + head_end_ind = cio_grid_data_inx(2,loc_head,var_loc) + tail_beg_ind = cio_grid_data_inx(1,loc_tail,var_loc) + tail_end_ind = cio_grid_data_inx(2,loc_tail,var_loc) + store_beg_ind = cio_grid_data_inx(1,2,var_loc) + store_end_ind = cio_grid_data_inx(2,2,var_loc) + + if ((cio_grid_var_name(var_loc, 2) .eq. 'ic') .or. + & (cio_grid_var_name(var_loc, 2) .eq. 'is')) then + cio_grid_data(store_beg_ind:store_end_ind) = cio_grid_data(head_beg_ind:head_end_ind) + else + cio_grid_data_tstamp(1, 2, var_loc) = date + cio_grid_data_tstamp(2, 2, var_loc) = time + + if ((prev_time .ne. time) .or. + & (prev_head_time .ne. cio_grid_data_tstamp(2, loc_head, var_loc)) .or. + & (prev_tail_time .ne. cio_grid_data_tstamp(2, loc_tail, var_loc))) then + + if (cio_grid_data_tstamp(1, loc_head, var_loc) .eq. date) then + ratio2 = real(time_diff(time, cio_grid_data_tstamp(2, loc_head, var_loc))) + & / real(time_to_sec(loc_tstep)) + ratio1 = 1.0 - ratio2 + else + ratio2 = real(time_diff(240000, cio_grid_data_tstamp(2, loc_head, var_loc))) + & / real(time_to_sec(loc_tstep)) + ratio1 = 1.0 - ratio2 + end if + prev_time = time + prev_head_time = cio_grid_data_tstamp(2, loc_head, var_loc) + prev_tail_time = cio_grid_data_tstamp(2, loc_tail, var_loc) + +#ifdef verbose_cio + if ( (ratio1 .lt. 0) .or. (ratio2 .lt. 0) + & .or. (ratio1 .gt. 1) .or. (ratio2 .gt. 1)) then + write(logdev,'(5X,a)'), + & 'ERROR: Incorrect Interpolation in 3-D Generic Interpolation for variable: ', + & trim(vname) + + write(logdev,'(5X,a,i7,a,i6)'), + & 'Requested TIME & DATE: ',date,':',time + + write(logdev,'(5X,a,i7,a,i6,a,i7,a,i6)'), + & 'Interpolation Bounds ',cio_grid_data_tstamp(1,0,var_loc), + & ':',cio_grid_data_tstamp(2,0,var_loc),' to ', + & cio_grid_data_tstamp(1,1,var_loc),':',cio_grid_data_tstamp(2,1,var_loc) + + call m3exit( 'Centralized I/O',date,time,'',1 ) + write(logdev,'(5X,a)'), + & 'ERROR: Program EXIT in subroutine r_interpolate_var_3d in module centralized io' + + end if +#endif + else + lcount = lcount + 1 + end if + + cio_grid_data(store_beg_ind:store_end_ind) = cio_grid_data(head_beg_ind:head_end_ind) * ratio1 + & + cio_grid_data(tail_beg_ind:tail_end_ind) * ratio2 + end if + end if + + beg_k = 1 + if (cio_grid_var_name(var_loc, 2) .eq. 'e2d') then + end_k = 1 + else + end_k = size(data,3) + end if + + adj1 = 0 + adj2 = 0 + adj3 = 0 + if (window) then + if (((size(data,1) - ncols) .eq. 0) .and. + & (cio_grid_var_name(var_loc, 2) .eq. 'mc3')) then + adj1 = ncols + 3 + adj2 = 2 + adj3 = 2 * ncols + 4 + else if (cio_grid_var_name(var_loc, 2) .eq. 'md3') then + adj1 = 0 + + if (.not. east_pe) then + adj2 = 1 + else + adj2 = 0 + end if + + if (north_pe .and. east_pe) then + adj3 = 0 + else if (north_pe) then + adj3 = 1 + else if (east_pe) then + adj3 = x_dot_ncols + else + adj3 = x_dot_ncols + 1 + end if +#ifdef twoway + adj2 = 0 + adj3 = 0 +#endif + end if + else + extra_c = 0 + extra_r = 0 + + if (cio_grid_var_name(var_loc, 2) .eq. 'md3') then + extra_c = x_dot_ncols - size(data, 1) + extra_r = x_dot_nrows - size(data, 2) + col_size = dot_ncols + dot = 1 + else + extra_c = x_cro_ncols - size(data, 1) + extra_r = x_cro_nrows - size(data, 2) + col_size = cro_ncols + dot = 0 + end if + + if ((cio_grid_var_name(var_loc, 2) .ne. 'e2d') .and. + & (cio_grid_var_name(var_loc, 2) .ne. 'e3d') .and. + & (cio_grid_var_name(var_loc, 2) .ne. 'ic') .and. + & (cio_grid_var_name(var_loc, 2) .ne. 'is')) then + adj2 = extra_c + adj3 = extra_r * col_size + extra_c + if (north_pe .and. east_pe) then + adj3 = 0 + else if (north_pe) then + adj3 = adj3 - 1 + end if + end if + + end if + + store_beg_ind = cio_grid_data_inx(1,2,var_loc) + m = store_beg_ind - 1 + adj1 + + do k = beg_k, end_k + do r = 1, size(data,2) + do c = 1, size(data,1) + m = m + 1 + data(c,r,k) = cio_grid_data(m) + end do + m = m + adj2 + end do + if (window .and. (cio_grid_var_name(var_loc, 2) .eq. 'md3')) then + m = m - adj2 + adj3 + else + m = m + adj3 + end if + end do + end if + + end subroutine r_interpolate_var_3d +!#endif !ifdefine mpas for the few functions in the interface (Wei Li) + + END MODULE CENTRALIZED_IO_MODULE diff --git a/src/model/src/centralized_io_util_module.F b/src/model/src/centralized_io_util_module.F index f5b06531..c37a99e3 100644 --- a/src/model/src/centralized_io_util_module.F +++ b/src/model/src/centralized_io_util_module.F @@ -25,12 +25,17 @@ ! 02/01/19, D. Wong: initial implementation ! 08/01/19, D. Wong: modified code to work with two-way model ! 11/20/19, F. Sidi: Modified time to sec to handle negative numbers +! 03/05/20, D. Wong: Expanded CIO functionalities to MPAS as well +! 07/07/20, D. Wong: Formulated a robust routine to compute JDATE1 - JDATE2 +! and JDATE + NDAYS !------------------------------------------------------------------------! module centralized_io_util_module implicit none + private :: leap_year + interface quicksort module procedure quicksort1d, & quicksort2d @@ -38,6 +43,23 @@ module centralized_io_util_module contains +! ----------------------------------------------------------- + logical function leap_year (year) + + integer :: year + + if (mod(year, 4) .ne. 0) then + leap_year = .false. + else if (mod(year, 400) .eq. 0) then + leap_year = .true. + else if (mod(year, 100) .eq. 0) then + leap_year = .false. + else + leap_year = .true. + endif + + end function leap_year + ! ------------------------------------------------------------------------- recursive subroutine quicksort1d (name, begin, end) @@ -202,7 +224,7 @@ integer function time_diff (time1, time2) end function time_diff !-------------------------------------------------------------------------- - integer function next_day (jday) + integer function next_day (jday) ! This function determermins the next day for time interpolation implicit none @@ -236,7 +258,91 @@ integer function next_day (jday) End If End If - end function next_day + end function next_day + +! ------------------------------------------------------------------------- + integer function cal_date (date1, date2, operator) + + integer, intent(in) :: date1, date2 + character, intent(in) :: operator + + integer :: ldate1, ldate2, yr1, yr2, day1, day2, dsum, y, + & adj, adj_yr, remainder, ndays + logical :: done + + if (operator == '-') then + if (date1 <= date2) then + ldate1 = date1 + ldate2 = date2 + adj = -1 + else + ldate1 = date2 + ldate2 = date1 + adj = 1 + end if + + yr1 = ldate1 / 1000 + yr2 = ldate2 / 1000 + day1 = mod(ldate1, 1000) + day2 = mod(ldate2, 1000) + + dsum = 0 + do y = yr1, yr2 + if (leap_year(y)) then + dsum = dsum + 366 + else + dsum = dsum + 365 + end if + end do + + dsum = dsum - day1 + if (leap_year(yr2)) then + dsum = dsum - 366 + day2 + else + dsum = dsum - 365 + day2 + end if + + cal_date = dsum * adj + + else if (operator == '+') then + + yr1 = date1 / 1000 + day1 = mod(date1, 1000) + if (date2 < 0) then + adj_yr = -1 + adj = 1 + else + adj_yr = 1 + adj = -1 + end if + + day1 = day1 + date2 + done = .false. + do while (.not. done) + if (leap_year(yr1)) then + ndays = 366 + else + ndays = 365 + end if + if ((day1 > 0) .and. (day1 <= ndays)) then + done = .true. + else + yr1 = yr1 + adj_yr + day1 = day1 + ndays * adj + end if + end do + + if ((date2 < 0) .and. (leap_year(yr1))) then + cal_date = yr1 * 1000 + day1 + 1 + else + cal_date = yr1 * 1000 + day1 + end if + + else + call m3exit ( 'cal_date', 0, 0, ' Abort: Invalid operator', 2) + end if + + end function cal_date !-------------------------------------------------------------------------- @@ -277,6 +383,6 @@ function interp_linear1_internal(x,y,xout) result(yout) return - end function interp_linear1_internal + end function interp_linear1_internal end module centralized_io_util_module diff --git a/src/model/src/o3totcol.f b/src/model/src/o3totcol.f index 9f8c7fc6..a500cee0 100644 --- a/src/model/src/o3totcol.f +++ b/src/model/src/o3totcol.f @@ -17,10 +17,7 @@ ! subject to their copyright restrictions. ! !------------------------------------------------------------------------! -! RCS file, release, date & time of last delta, author, state, [and locker] -! $Header: /project/yoj/arc/CCTM/src/phot/phot_inline/o3totcol.f,v 1.2 2011/10/21 16:11:28 yoj Exp $ - - subroutine o3totcol ( latitude, longitude, jdate, ozone ) + subroutine o3totcol ( latitude, longitude, jdate, jtime, ozone ) !---------------------------------------------------------------------- ! Function: @@ -37,6 +34,7 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) ! Jun 2015 J.Young: maintain code stnds !---------------------------------------------------------------------- + use runtime_vars use utilio_defn implicit none @@ -44,11 +42,15 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) ! arguments integer, intent( in ) :: jdate ! Julian day of the year (yyyyddd) + integer, intent( in ) :: jtime ! time (hhmmss) real, intent( in ) :: latitude ! latitude of point on earth's surface real, intent( in ) :: longitude ! longitude of point on earth's surface real, intent( inout ) :: ozone ! total column ozone [DU] +! parameters + + real, parameter :: sec2day = 1.0 / 8.64E+4 ! local variables character( 16 ), save :: tmfile = 'OMI' @@ -64,14 +66,17 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) integer :: ios integer :: nrecs integer :: jyear - integer, save :: nlat - integer, save :: nlon + integer :: time - integer, save :: logdev ! output log unit number + integer, save :: nlat ! = 17 ! or 19 + integer, save :: nlon ! = 17 integer, save :: nt integer, save :: it + integer, save :: icolumn_prev = 1 + integer, save :: icolumn_next = 2 integer, save :: tmunit integer, save :: jdate_prev = 0 + integer, save :: jtime_prev = 0 integer, save :: jstdate, jenddate, jtdate_temp real :: flag( 8 ) @@ -84,25 +89,24 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) real :: tdate_temp, tdate real, save :: x1 - real, save :: stdate, enddate + real, save :: strdate, enddate + real, save :: max_lat, min_lat real, allocatable, save :: t( : ) real, allocatable, save :: lat( : ) real, allocatable, save :: lon( : ) real, allocatable, save :: oz( :, :, : ) ! two timesteps for interpolation - character( 8 ) :: label - logical, save :: firsttime = .true. - real, external :: yr2day - character*24, external :: dt2str + character( 8 ) :: label !(Wei li) + real, external :: yr2day !(Wei Li: from io/ioapi/yr2day.F) + character*24, external :: dt2str !(Wei Li) !---------------------------------------------------------------------- if ( firsttime ) then firsttime = .false. - logdev = init3() tmunit = getefile( tmfile, .true., .true., pname ) @@ -111,10 +115,13 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) call m3exit ( pname, jdate, 0, xmsg, xstat1 ) end if - ! read nlat, nlon + ! read nlat, nlon (Wei Li) rewind( tmunit ) - read( tmunit, * ) label, nlat - read( tmunit, * ) label, nlon + read( tmunit, *) label, nlat + read( tmunit, *) label, nlon + + write(logdev,'(a,i7,a,i7)')'OMI Ozone column data has Lat by Lon Resolution: ', + & nlat,'X',nlon allocate ( lat( nlat ), stat = allocstat ) if ( allocstat .ne. 0 ) then @@ -127,10 +134,18 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) xmsg = 'Failure allocating lon' call m3exit ( pname, jdate, 0, xmsg, xstat1 ) end if + +! Assign values to array of longitudes: lon +! x2 = 360.0 / real( nlon - 1 ) +! do ilon = 1, nlon +! lon( ilon ) = -180.0 + x2 * real( ilon - 1 ) +! end do - read( tmunit, * ) label, label, lon ! read in longitudes + !read in longitudes instead (Wei Li) + read( tmunit, * ) label, label, lon nrecs = 0 + ! read( tmunit, * ) !skip header record. Wei Li:no need here do read( tmunit, *, iostat=ios ) if ( ios .ne. 0 ) exit @@ -152,9 +167,9 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) rewind( tmunit ) ! skip header records - do it = 1, 3 - read( tmunit, * ) - end do + read( tmunit, * ) + read( tmunit, * ) + read( tmunit, * ) ! When adding x lines of data to OMI.dat, increase upper limit by x ! Note: ilat(1) => North to South in degrees @@ -168,102 +183,112 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) end do end do - stdate = minval( t ) + max_lat = maxval( lat ) + min_lat = minval( lat ) + strdate = minval( t ) enddate = maxval( t ) end if ! firsttime - if ( jdate .ne. jdate_prev ) then -! reset oz and jdate_prev - jdate_prev = jdate - oz = 0.0 - + if ( jdate .ne. jdate_prev .or. jtime .ne. jtime_prev ) then ! Use a temporary dummy variable jdate_temp so as not to overwrite jdate + jtime_prev = jtime jyear = jdate / 1000 - tdate = real( jyear ) + real( jdate - jyear * 1000 ) * yr2day( jyear ) + time = mod(jtime, 100) + 60*mod(jtime/100, 100)+ 3600*(jtime/10000) + + tdate = real( jyear ) + & + ( real( jdate - jyear * 1000 ) + real( time ) * sec2day ) * yr2day( jyear ) + tdate_temp = tdate ! Determine if the ozone database includes the requested jdate - + if ( tdate .ge. enddate ) then ! Submitted date is outside of ozone database range. ! Total column ozone will be estimated from the corresponding Julian Day ! of the prior year - - if ( tdate .ge. enddate ) then - tdate_temp = aint( enddate ) + ( tdate - aint( tdate ) ) - if ( tdate_temp .gt. enddate ) then - tdate_temp = tdate_temp - 1.0 - end if - jenddate = int( enddate ) * 1000 - & + int( ( 1.0 / yr2day( int( enddate ) ) ) + tdate_temp = aint( enddate ) + ( tdate - aint( tdate ) ) + if ( tdate_temp .gt. enddate ) then + tdate_temp = tdate_temp - 1.0 + end if + jenddate = int( enddate ) * 1000 + & + int( ( 1.0 / yr2day( int( enddate ) ) ) & * ( enddate - aint( enddate ) ) ) - jtdate_temp = int( tdate_temp ) * 1000 - & + nint( ( 1.0 / yr2day( int( tdate_temp ) ) ) - & * ( tdate_temp - aint( tdate_temp ) ) ) - xmsg = 'Requested date is beyond available data on OMI file: <' - & // dt2str( jenddate, 0 ) - call m3warn ( pname, jdate, 0, xmsg ) - xmsgs( 1 ) = 'Total column ozone will be estimated from the corresponding Julian Day ' - xmsgs( 2 ) = 'of the last available year on the ' - & // 'OMI input file:' // dt2str( jtdate_temp, 0 ) // '<<---<<' - xmsgs( 3 ) = ' ' - call m3parag ( 3, xmsgs ) - + jtdate_temp = int( tdate_temp ) * 1000 + & + nint( ( 1.0 / yr2day( int( tdate_temp ) ) ) + & * ( tdate_temp - aint( tdate_temp ) ) ) + if( jdate_prev .ne. jdate )then ! write message to log + xmsg = 'Requested date is beyond available data on OMI file: <' + & // dt2str( jenddate, 0 ) + call m3warn ( pname, jdate, 0, xmsg ) + xmsgs( 1 ) = 'Total column ozone will be estimated from the corresponding Julian Day ' + xmsgs( 2 ) = 'of the last available year on the ' + & // 'OMI input file:' // dt2str( jtdate_temp, 0 ) // '<<---<<' + write(xmsgs( 3 ),'(A,F14.8)')'Exact date: ',tdate_temp + call m3parag ( 3, xmsgs ) + end if + else if ( tdate .le. strdate ) then ! Submitted date is outside of ozone database range. ! Total column ozone will be estimated from the corresponding Julian Day of ! the subsequent year - - else if ( tdate .le. stdate ) then - tdate_temp = real( int( stdate ) ) + ( tdate - real( int( tdate ) ) ) - if ( tdate_temp .lt. stdate ) then - tdate_temp = tdate_temp + 1.0 - end if - jstdate = int( stdate ) * 1000 - & + int( ( 1.0 / yr2day( int( stdate ) ) ) - & * ( stdate - aint( stdate ) ) ) - jtdate_temp = int( tdate_temp ) * 1000 - & + nint( ( 1.0 / yr2day( int( tdate_temp ) ) ) - & * ( tdate_temp - aint( tdate_temp ) ) ) - xmsg = 'Requested date preceeds available data on OMI file: >' - & // dt2str( jstdate, 0 ) - call m3warn ( pname, jdate, 0, xmsg ) - xmsgs( 1 ) = 'Total column ozone will be estimated from the corresponding Julian Day' - xmsgs( 2 ) = 'of the next available year on the OMI input file:' - & // dt2str( jtdate_temp, 0 ) // '<<---<<' - xmsgs( 3 ) = ' ' - call m3parag ( 3, xmsgs ) + tdate_temp = real( int( strdate ) ) + ( tdate - real( int( tdate ) ) ) + if ( tdate_temp .lt. strdate ) then + tdate_temp = tdate_temp + 1.0 + end if + jstdate = int( strdate ) * 1000 + & + int( ( 1.0 / yr2day( int( strdate ) ) ) + & * ( strdate - aint( strdate ) ) ) + jtdate_temp = int( tdate_temp ) * 1000 + & + nint( ( 1.0 / yr2day( int( tdate_temp ) ) ) + & * ( tdate_temp - aint( tdate_temp ) ) ) + if( jdate_prev .ne. jdate )then ! write message to log + xmsg = 'Requested date preceeds available data on OMI file: >' + & // dt2str( jstdate, 0 ) + call m3warn ( pname, jdate, 0, xmsg ) + xmsgs( 1 ) = 'Total column ozone will be estimated from the corresponding Julian Day' + xmsgs( 2 ) = 'of the next available year on the OMI input file:' + & // dt2str( jtdate_temp, 0 ) // '<<---<<' + xmsgs( 3 ) = ' ' + call m3parag ( 3, xmsgs ) + end if ! Submitted date falls within the satellite data measurement gap beginning ! on 24 Nov 1994 and ending on 22 Jul 1996. - else if ( ( tdate .ge. 1994.899 ) .and. - & ( tdate .le. 1996.557 ) ) then + else if ( ( tdate .ge. 1994.899 ) .and. + & ( tdate .le. 1996.557 ) ) then - if ( tdate .le. 1995.738 ) then - tdate_temp = tdate - 1.0 ! use previous year - else - tdate_temp = tdate + 1.0 ! use subsequent year - end if - jtdate_temp = int( tdate_temp ) * 1000 + if ( tdate .le. 1995.738 ) then + tdate_temp = tdate - 1.0 ! use previous year + else + tdate_temp = tdate + 1.0 ! use subsequent year + end if + jtdate_temp = int( tdate_temp ) * 1000 & + nint( ( 1.0 / yr2day( int( tdate_temp ) ) ) & * ( tdate_temp - aint( tdate_temp ) ) ) - xmsg = 'Requested date falls within satellite data' - & // ' measurement gap: 24 Nov 1994 - 22 Jul 1996' - call m3warn ( pname, jdate, 0, xmsg ) - xmsgs( 1 ) = 'Total column ozone will be estimated from the corresponding Julian Day' - xmsgs( 2 ) = 'of the closest available year on the OMI input file:' - & // dt2str( jtdate_temp, 0 ) // '<<---<<' - xmsgs( 3 ) = ' ' - call m3parag ( 3, xmsgs ) - - else - xmsgs( 1 ) = 'Total column ozone will be interpolated to day ' - & // dt2str( jdate, 0 ) - xmsgs( 2 ) = 'from data available on the OMI input file' - xmsgs( 3 ) = ' ' - call m3parag ( 3, xmsgs ) - end if + if( jdate_prev .ne. jdate )then ! write message to log + xmsg = 'Requested date falls within satellite data' + & // ' measurement gap: 24 Nov 1994 - 22 Jul 1996' + call m3warn ( pname, jdate, 0, xmsg ) + xmsgs( 1 ) = 'Total column ozone will be estimated from the corresponding Julian Day' + xmsgs( 2 ) = 'of the closest available year on the OMI input file:' + & // dt2str( jtdate_temp, 0 ) // '<<---<<' + xmsgs( 3 ) = ' ' + call m3parag ( 3, xmsgs ) + end if + else + if( jdate_prev .ne. jdate )then ! write message to log + xmsgs( 1 ) = 'Total column ozone will be interpolated to day ' + & // dt2str( jdate, 0 ) + xmsgs( 2 ) = 'from data available on the OMI input file' + xmsgs( 3 ) = ' ' + call m3parag ( 3, xmsgs ) + end if + end if + + if( jdate_prev .ne. jdate )then ! need to update day interpolation points + jdate_prev = jdate + oz = 0.0 ! When adding x lines of data to OMI.dat, increase upper limit by x ! and increase the dimension of t as needed @@ -272,41 +297,44 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) ! i.e. (it) < (jdate_temp) < (it+1) ! where it is the index var for the database ! and determine the interpolation factor ?x1? between the bounding dates +! reset oz and jdate_prev - x1 = 0.0 - x1loop: do it = 1, nt-1 - if ( ( tdate_temp .ge. t( it ) ) .and. - & ( tdate_temp .le. t( it+1 ) ) ) then - x1 = ( tdate_temp - t( it ) ) / ( t( it+1) - t( it ) ) - exit x1loop - end if - end do x1loop - + x1 = 0.0 + x1loop: do it = 1, nt-1 + if ( ( tdate_temp .ge. t( it ) ) .and. + & ( tdate_temp .le. t( it+1 ) ) ) then + icolumn_prev = it + icolumn_next = it + 1 + exit x1loop + end if + end do x1loop ! Determine the corresponding bounding ozone values for all lats and lons - - rewind( tmunit ) - ! skip header records - do i = 1, 3 - read( tmunit, * ) - end do + rewind( tmunit ) + ! skip header records + read( tmunit,* ) + read( tmunit,* ) + read( tmunit,* ) - do i = 1, it-1 - do ilat = 1, nlat - read( tmunit,* ) - end do - end do + do i = 1, it-1 + do ilat = 1, nlat + read( tmunit,* ) + end do + end do - do ilat = 1, nlat - read( tmunit,* ) t( it ), lat( ilat ), ( oz( ilat, ilon, 1 ), ilon=1,(nlon-1) ) - oz( ilat, nlon, 1 ) = oz( ilat, 1, 1 ) - end do + do ilat = 1, nlat + read( tmunit,* ) t( it ), lat( ilat ), ( oz( ilat, ilon, 1 ), ilon=1,(nlon-1) ) + oz( ilat, nlon, 1 ) = oz( ilat, 1, 1 ) + end do - do ilat = 1, nlat - read( tmunit,* ) t( it+1 ), lat( ilat ), ( oz( ilat, ilon, 2 ), ilon=1,(nlon-1) ) - oz( ilat, nlon, 2 ) = oz( ilat, 1, 2 ) - end do + do ilat = 1, nlat + read( tmunit,* ) t( it+1 ), lat( ilat ), ( oz( ilat, ilon, 2 ), ilon=1,(nlon-1) ) + oz( ilat, nlon, 2 ) = oz( ilat, 1, 2 ) + end do + end if + + x1 = ( tdate_temp - t( icolumn_prev ) ) / ( t( icolumn_next ) - t( icolumn_prev ) ) - end if ! jdate .ne. jdate_prev + end if ! jdate .ne. jdate_prev and jtime .ne. jday flag = 0.0 ozone = 0.0 @@ -314,13 +342,13 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) x2 = 0.0 x3 = 0.0 -! Handle the special case of abs(lat) > 80. +! Handle the special case of lat > max_lat or lat < min_lat. ! use a dummy latitude variable latitudem so as to prevent overwriting latitude - if ( latitude .gt. 80.0 ) then - latitudem = 80.0 - else if ( latitude .lt. -80.0 ) then - latitudem = -80.0 + if ( latitude .gt. max_lat ) then + latitudem = max_lat + else if ( latitude .lt. min_lat ) then + latitudem = min_lat else latitudem = latitude end if @@ -420,9 +448,9 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) total = sum( flag ) -! Special case of abs(lat) > 80 +! Special case of min_lat > lat or lat > max_lat - if ( latitude .ge. 80.0 ) then + if ( latitude .ge. max_lat ) then np_oz = 0.0 icount = 0 @@ -444,7 +472,7 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) np_oz = np_oz / real( icount ) - else if ( latitude .le. -80.0 ) then + else if ( latitude .le. min_lat ) then sp_oz = 0.0 icount = 0 @@ -473,15 +501,15 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) if ( total .le. 0.0 ) then ozone = 300.0 else - if ( latitude .ge. 80.0 ) then + if ( latitude .ge. max_lat ) then np_oz = np_oz / total - ozone = ( ( latitude - 80.0 ) * 0.1 ) * np_oz - & + ( 1.0 - ( ( ( latitude - 80.0 ) * 0.1 ) ) ) * ozone / total + ozone = ( ( latitude - max_lat ) * 0.1 ) * np_oz + & + ( 1.0 - ( ( ( latitude - max_lat ) * 0.1 ) ) ) * ozone / total - else if ( latitude .le. -80.0 ) then + else if ( latitude .le. min_lat ) then sp_oz = sp_oz / total - ozone = ( ( latitude + 80.0 ) * 0.1 ) * sp_oz - & + ( 1.0 - ( ( ( latitude + 80.0 ) * 0.1 ) ) ) * ozone / total + ozone = ( ( latitude - min_lat ) * 0.1 ) * sp_oz + & + ( 1.0 - ( ( ( latitude - min_lat ) * 0.1 ) ) ) * ozone / total else ozone = ozone / total @@ -490,8 +518,36 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) 899 if ( ozone .lt. 100.0 ) then ozone = 100.0 - else if ( ozone .gt. 600.0 ) then - ozone = 600.0 +! xmsg = 'interpolated ozone column below 100 DU' +! write(logdev,'(A,20(F10.4,1X))')'For time:',tdate_temp +! write(logdev,'(A,20(F10.4,1X))')'At lat,lon:',latitude,longitude +! write(logdev,'(A,20(F10.4,1X))')'Intepolated data' +! write(logdev,'(A,20(F10.4,1X))')'Time Point 1', +! & t( icolumn_prev ),lat( ilat ),lat( ilat+1 ),lon( ilon),lon( ilon+1 ), +! & oz( ilat, ilon+1, 1 ), oz( ilat , ilon , 1 ), +! & oz( ilat+1, ilon+1, 1 ), oz( ilat+1, ilon , 1 ) +! write(logdev,'(A,20(F10.4,1X))')'Time Point 2', +! & t( icolumn_next ),lat( ilat ),lat( ilat+1 ),lon( ilon),lon( ilon+1 ), +! & oz( ilat, ilon+1, 2 ), oz( ilat , ilon , 2 ), +! & oz( ilat+1, ilon+1, 2 ), oz( ilat+1, ilon , 2 ) +! write(logdev,'(A,20(F10.4,1X))')'Weights, x1, x2,x3: ',x1, x2,x3 +! CALL M3EXIT( 'o3totcol', JDATE, JTIME, XMSG, XSTAT1 ) + else if ( ozone .gt. 800.0 ) then +! xmsg = 'interpolated ozone column above 800 DU' +! write(logdev,'(A,20(F10.4,1X))')'For time:',tdate_temp +! write(logdev,'(A,20(F10.4,1X))')'At lat,lon:',latitude,longitude +! write(logdev,'(A,20(F10.4,1X))')'Intepolated data' +! write(logdev,'(A,20(F10.4,1X))')'Time Point 1', +! & t( icolumn_prev ),lat( ilat ),lat( ilat+1 ),lon( ilon),lon( ilon+1 ), +! & oz( ilat, ilon+1, 1 ), oz( ilat , ilon , 1 ), +! & oz( ilat+1, ilon+1, 1 ), oz( ilat+1, ilon , 1 ) +! write(logdev,'(A,20(F10.4,1X))')'Time Point 2', +! & t( icolumn_next ),lat( ilat ),lat( ilat+1 ),lon( ilon),lon( ilon+1 ), +! & oz( ilat, ilon+1, 2 ), oz( ilat , ilon , 2 ), +! & oz( ilat+1, ilon+1, 2 ), oz( ilat+1, ilon , 2 ) +! write(logdev,'(A,20(F10.4,1X))')'Weights, x1, x2,x3: ',x1, x2,x3 +! CALL M3EXIT( 'o3totcol', JDATE, JTIME, XMSG, XSTAT1 ) + ozone = 800.0 end if return diff --git a/src/model/src/phot.F b/src/model/src/phot.F index 99862a3a..15040886 100644 --- a/src/model/src/phot.F +++ b/src/model/src/phot.F @@ -17,15 +17,8 @@ ! subject to their copyright restrictions. ! !------------------------------------------------------------------------! - -! RCS file, release, date & time of last delta, author, state, [and locker] -! $Header: /project/yoj/arc/CCTM/src/phot/phot_inline/phot.F,v 1.7 2011/10/21 16:11:28 yoj Exp $ - -! what(1) key, module and SID; SCCS file; date and time of last delta: -! %W% %P% %G% %U% - !::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) + SUBROUTINE PHOT ( CGRID, JDATE, JTIME, DTSTEP ) !----------------------------------------------------------------------- ! @@ -37,11 +30,11 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) ! Preconditions: HGRD_INIT() called from PAR_INIT, which is called from ! DRIVER ! -! Subroutines/Functions called: INIT3, M3EXIT, SUBHFILE, CGRID_MAP, +! Subroutines/Functions called: M3EXIT, SUBHFILE, CGRID_MAP, ! OPPHOT, LOAD_CSQY_DATA, LOAD_OPTICS_DATA, INITIALIZE_ALBEDO, ! GET_PHOT_MET, UPDATE_SUN, GET_ALBEDO, GET_DROPLET_OPTICS, ! GET_ICE_OPTICS, GET_AGGREGATE_OPTICS, CLEAR_HYDROMETEOR_OPTICS, -! GET_AERO_DATA, O3TOTCOL, and NEW_OPTICS +! GET_AERO_DATA, O3TOTCOL, and NEW_OPTICS, GET_ENVLIST ! ! Revision History. ! Started 10/08/2004 with existing PHOT and JPROC coded by @@ -89,7 +82,7 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) ! reads this input file ! - added call to a routine called AERO_PHOTDATA that returns opacity data ! on the aerosol distribution -! - revised NEW_OPTICS' arguments based on aerosol redesign in CMAQ +! - revised NEW_OPTICS' arguments based on aerosol redesign in CMAQ ! version 5.0 ! March 29, 2011 S.Roselle ! - Replaced I/O API include files with UTILIO_DEFN @@ -101,9 +94,9 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) ! 3) reading and calculation of met and geo data ! now acomplished by a fortran module ! 4) changed description and accounting of cloud effects -! from 2D liquid water clouds to 3D resolved and subgrid +! from 2D liquid water clouds to 3D resolved and subgrid ! clouds with multi-phases of water -! 5) inserted calculation of aerosol optical properites via +! 5) inserted calculation of aerosol optical properties via ! fortran module to improve efficiency in radiative ! transfer solution ! 6) moved the O3TOTCOL routine from the PHOT_MOD to simplify @@ -112,14 +105,17 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) ! June 10 15 J.Young: Modified diagnostic output timestamp to fix for other than one ! hour time steps. ! Aug 12, 15 D. Wong: Replaced MYPE with IO_PE_INCLUSIVE for parallel I/O implementation +! Feb 01, 19 David Wong: Implemented centralized I/O approach, removed all MY_N +! clauses !---------------------------------------------------------------------- C...modules + USE RUNTIME_VARS, ONLY : START_DATE => STDATE, START_TIME => STTIME USE RXNS_DATA ! chemistry varaibles and data + USE GRID_CONF ! horizontal & vertical domain specifications USE CGRID_SPCS ! CGRID species number and offsets - USE PCGRID_DEFN ! get cgrid USE UTILIO_DEFN USE AERO_DATA ! describes aerosol distribution USE PHOT_MOD ! photolysis in-line module - inherits CSQY_DATA module @@ -127,12 +123,12 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) USE PHOTOLYSIS_ALBEDO ! surface albedo data and routines USE PHOT_MET_DATA ! Met and Grid data USE CLOUD_OPTICS ! data and routines for optics of cloud hydrometeors -! USE STRATOS_O3_MINFRACS ! annual minimum fraction of ozone column density above Pressure TOP -! USE SEAS_STRAT_O3_FRACS ! monthly minimum fraction of ozone column density above Pressure TOP USE SEAS_STRAT_O3_MIN ! monthly minimum fraction of ozone column density above Pressure TOP -!Used for canopy shade calculation + !Used for canopy shade calculation (Wei Li) USE ASX_DATA_MOD, ONLY : MET_DATA !uses met data - USE centralized_io_util_module, ONLY: IntegrateTrapezoid, interp_linear1_internal !basic utilities + USE CENTRALIZED_IO_MODULE, ONLY : LAT, LON, HT + USE centralized_io_util_module, ONLY: IntegrateTrapezoid,interp_linear1_internal + USE ELMO_DATA, ONLY : ELMO_AOD_550, ELMO_EXT_550 #ifdef parallel USE SE_MODULES ! stenex (using SE_UTIL_MODULE) @@ -145,21 +141,14 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) !...include files INCLUDE SUBST_FILES_ID ! file name parameters -! INCLUDE SUBST_CONST ! physical constants--moved to PHOT_MOD. !...arguments - INTEGER, INTENT( IN ) :: MDATE ! "centered" Julian date (YYYYDDD) - INTEGER, INTENT( IN ) :: MTIME ! "centered" time (HHMMSS) + REAL, POINTER :: CGRID( :,:,:,: ) ! Species concentrations INTEGER, INTENT( IN ) :: JDATE ! current Julian date (YYYYDDD) INTEGER, INTENT( IN ) :: JTIME ! current time (HHMMSS) INTEGER, INTENT( IN ) :: DTSTEP( : ) ! time step vector (HHMMSS) -! REAL RJ( NCOLS,NROWS,NLAYS, NPHOTAB ) - REAL, INTENT( OUT ) :: RJ( :,:,:,: ) ! gridded J-values (1/min units) - -! REAL CGRID( NCOLS,NROWS,NLAYS, * ) ! Conc array - REAL, SAVE, POINTER :: CGRID( :,:,:,: ) ! species concentrations !...parameters @@ -170,7 +159,7 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) REAL, PARAMETER :: PRES_CONV = 1.0 / STDATMPA ! conversion factor Pa to atm REAL, PARAMETER :: ZTOA = 50.0E3 ! height of top of atmosphere [ m ] (=50km) ! based a 2005 WRF model Documentation - + REAL, PARAMETER :: EPSLON = 1.0E-30 ! Small number !...external functions: none @@ -178,24 +167,27 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) !...local variables LOGICAL, SAVE :: FIRSTIME = .TRUE. ! Flag for first call to PHOT - LOGICAL, SAVE :: PHOTDIAG ! Flag for PHOTDIAG file LOGICAL, SAVE :: CALL_INIT_ALBEDO = .TRUE. LOGICAL, SAVE :: CALL_GET_ALBEDO = .TRUE. - + LOGICAL :: ZERO_ICE CHARACTER( 3 ), ALLOCATABLE, SAVE :: WLTXT( : ) CHARACTER( 16 ) :: VARNM CHARACTER( 16 ), SAVE :: PNAME = 'PHOT' - CHARACTER( 16 ), SAVE :: CTM_PHOTDIAG = 'CTM_PHOTDIAG' + CHARACTER( 16 ) :: V_LIST( 2 ) + CHARACTER( 16 ) :: REQUESTED_WAVE + CHARACTER( 16 ), ALLOCATABLE :: WAVE_LIST( : ) CHARACTER( 80 ) :: VARDESC ! environment variable description CHARACTER( 240 ) :: XMSG = ' ' - INTEGER, SAVE :: LOGDEV - INTEGER, SAVE :: LGC_O3 ! pointer to O3 in CGRID - INTEGER, SAVE :: LGC_NO2 ! pointer to NO2 in CGRID + INTEGER, SAVE :: LGC_O3 = 0 ! pointer to O3 in CGRID + INTEGER, SAVE :: LGC_NO2 = 0 ! pointer to NO2 in CGRID + INTEGER, SAVE :: LGC_CO = 0 ! pointer to CO in CGRID + INTEGER, SAVE :: LGC_SO2 = 0 ! pointer to SO2 in CGRID + INTEGER, SAVE :: LGC_HCHO = 0 ! pointer to formaldehyde in CGRID INTEGER, SAVE :: TSTEP ! output timestep in sec INTEGER ESTAT ! status from environment var check @@ -207,23 +199,23 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) INTEGER IWL INTEGER L INTEGER V, N, MODE - LOGICAL JTIME_CHK ! To check for JTIME to write RJ values - INTEGER ODATE ! output date - INTEGER OTIME ! output time + + LOGICAL :: JTIME_CHK ! To check for JTIME to write RJ values + INTEGER, SAVE :: ODATE ! output date + INTEGER, SAVE :: OTIME ! output time + INTEGER, SAVE :: OSTEP ! time since last write diagnostics INTEGER ALLOCSTAT + INTEGER ITMSTEP ! one half synchronization timestep (sec) + INTEGER MIDDATE ! Date at time step midpoint + INTEGER MIDTIME ! Time at time step midpoint + INTEGER, SAVE :: TDATE - INTEGER, SAVE :: GXOFF, GYOFF ! global origin offset from file INTEGER, SAVE :: PECOL_OFFSET ! Local Column Offset for processor INTEGER, SAVE :: PEROW_OFFSET ! Local Column Offset for processor INTEGER, SAVE :: TSTEP_COUNT ! counter between calls to write diagnostics -! for INTERPX - INTEGER, SAVE :: STRTCOLGC2, ENDCOLGC2, STRTROWGC2, ENDROWGC2 - INTEGER, SAVE :: STRTCOLMC2, ENDCOLMC2, STRTROWMC2, ENDROWMC2 - INTEGER, SAVE :: STRTCOLMC3, ENDCOLMC3, STRTROWMC3, ENDROWMC3 - REAL CURRHR ! current GMT hour REAL JULIAN_DAY ! time of year [days] REAL CURRHR_LST ! local standard time at each grid cell @@ -251,19 +243,19 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) REAL RES_SKY_TRANSD ! direct transmission coefficient based on resolved sky REAL :: TOTAL_O3_COLUMN ! total ozone column density, DU - + REAL, SAVE :: JYEAR = 0.0 ! year REAL, SAVE :: JD_STRAT_O3MIN = 0.0 ! Julian day (YYYYDDD) of min fraction for stratos ozone INTEGER, PARAMETER :: DAYS( 12 ) = (/ 0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30 /) INTEGER, SAVE :: IMONTH = 0 - REAL, ALLOCATABLE, SAVE :: ETOT_SFC ( : ) ! total downward irradiance at sfc [ Watts / m**2 ] - REAL, ALLOCATABLE, SAVE :: TAUO3_TOP( : ) ! optical depth of ozone above model domain - REAL, ALLOCATABLE, SAVE :: TAU_RAY ( : ) ! Rayleigh optical depth above model domain - REAL, ALLOCATABLE, SAVE :: TAUC_AERO( :,: ) ! aerosol optical depth at layer bottom - REAL, ALLOCATABLE, SAVE :: TAU_TOT ( :,: ) ! total optical depth at layer bottom - REAL, ALLOCATABLE, SAVE :: TAU_CLOUD( :,: ) ! cloud optical depth at layer bottom + REAL, ALLOCATABLE, SAVE :: ETOT_SFC ( : ) ! total downward irradiance at sfc [ Watts / m**2 ] + REAL, ALLOCATABLE, SAVE :: TAUO3_TOP( : ) ! optical depth of ozone above model domain + REAL, ALLOCATABLE, SAVE :: TAU_RAY ( : ) ! Rayleigh optical depth above model domain + REAL, ALLOCATABLE, SAVE :: TAUC_AERO( :,: ) ! aerosol optical depth at layer bottom + REAL, ALLOCATABLE, SAVE :: TAU_TOT ( :,: ) ! total optical depth at layer bottom + REAL, ALLOCATABLE, SAVE :: TAU_CLOUD( :,: ) ! cloud optical depth at layer bottom REAL, ALLOCATABLE, SAVE :: SSA ( : ) ! aerosol single scattering albedo, column average @@ -288,27 +280,26 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) REAL, ALLOCATABLE, SAVE :: BLKRJ_RES( :, : ) ! photolysis rates REAL, ALLOCATABLE, SAVE :: BLKRJ_ACM( :, : ) ! photolysis rates - + LOGICAL, ALLOCATABLE, SAVE :: CLOUDS( : ) ! Does layer have clouds? LOGICAL :: NEW_PROFILE ! Has atmospheric temperature and density profile changed? LOGICAL :: DARK ! Are this processor's cells in darkness? -! Canopy in-line control - CHARACTER( 20 ), SAVE :: CTM_CANOPY_SHADE = 'CTM_CANOPY_SHADE ' ! env var for in-line +! Canopy in-line control (Wei Li) + CHARACTER( 20 ), SAVE :: CTM_CANOPY_SHADE = 'CTM_CANOPY_SHADE '! env var for in-line LOGICAL, SAVE :: CANOPY_SHADE ! flag in-lining canopy shading - ! Canopy arrays - REAL, ALLOCATABLE, SAVE :: RJ_CORR_C1R ( :, :) ! canopy shading correction to J-values (hc to 0.75*hc) - REAL, ALLOCATABLE, SAVE :: RJ_CORR_C2R ( :, :) ! canopy shading correction to J-values (hc to 0.50*hc) - REAL, ALLOCATABLE, SAVE :: RJ_CORR_C3R ( :, :) ! canopy shading correction to J-values (hc to 0.35*hc) - REAL, ALLOCATABLE, SAVE :: RJ_CORR_C4R ( :, :) ! canopy shading correction to J-values (hc to 0.20*hc) - REAL, ALLOCATABLE, SAVE :: RJ_CORR_BOT ( :, :) ! canopy shading correction to J-values (0.20*hc to bottom) + REAL, ALLOCATABLE, SAVE :: RJ_CORR_C1R ( :, :) ! canopyshading correction to J-values (hc to 0.75*hc) + REAL, ALLOCATABLE, SAVE :: RJ_CORR_C2R ( :, :) ! canopyshading correction to J-values (hc to 0.50*hc) + REAL, ALLOCATABLE, SAVE :: RJ_CORR_C3R ( :, :) ! canopyshading correction to J-values (hc to 0.35*hc) + REAL, ALLOCATABLE, SAVE :: RJ_CORR_C4R ( :, :) ! canopyshading correction to J-values (hc to 0.20*hc) + REAL, ALLOCATABLE, SAVE :: RJ_CORR_BOT ( :, :) ! canopyshading correction to J-values (0.20*hc to bottom) REAL, ALLOCATABLE, SAVE :: RJ_CORR ( :, :) ! total/integrated canopy shading correction to J-values - REAL, ALLOCATABLE, SAVE :: ZCANX ( : ) ! canopy heights[m] - REAL, ALLOCATABLE, SAVE :: RJ_CORRX ( : ) ! canopy height dependent photolysis attenuation factor - REAL :: XCAN ( 2 ) ! canopy height interpolation bounds + REAL, ALLOCATABLE, SAVE :: ZCANX ( : ) ! canopy heights[m] + REAL, ALLOCATABLE, SAVE :: RJ_CORRX ( : ) ! canopy height dependent photolysis attenuation factor + REAL :: XCAN ( 2 ) ! canopy height interpolation bounds REAL :: YCAN ( 2 ) ! photolysisattenuation interpolation bounds - REAL ZFL, ZCAN, COUNTCAN, XCANOUT ! local canopyvariables + REAL ZFL, ZCAN, COUNTCAN, XCANOUT ! local canopy variables INTEGER, PARAMETER :: MAXCAN = 1000 ! Declare local maximum canopy layers !...Variables for diagnostic outputs @@ -317,45 +308,56 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) REAL, ALLOCATABLE, SAVE :: TOTAL_OC( :,: ) ! total ozone column [DU] REAL, ALLOCATABLE, SAVE :: TROPO_OC( :,: ) ! tropospheric ozone column [DU] + REAL, ALLOCATABLE, SAVE :: NO2_COLUMN ( :,: ) ! tropospheric NO2 column [] + REAL, ALLOCATABLE, SAVE :: CO_COLUMN ( :,: ) ! tropospheric CO column [] + REAL, ALLOCATABLE, SAVE :: HCHO_COLUMN( :,: ) ! tropospheric HCHO column [DU] + REAL, ALLOCATABLE, SAVE :: SO2_COLUMN ( :,: ) ! tropospheric SO2 column [DU] REAL, ALLOCATABLE, SAVE :: TROPO_O3_EXCEED( :,: ) ! Factor used to adjust tropospheric ozone optical depth REAL, ALLOCATABLE, SAVE :: TRANSMIS_DIFFUSE( :,: ) ! diffuse transmission coefficient at surface REAL, ALLOCATABLE, SAVE :: TRANSMIS_DIRECT( :,: ) ! direct transmission coefficient at surface REAL, ALLOCATABLE, SAVE :: REFLECT_COEFF( :,: ) ! reflection coefficient at top of atmosphere - REAL, ALLOCATABLE, SAVE :: ETOT_SFC_WL ( :,:,: ) ! total downward irradiance at sfc [ Watts / m**2 ] REAL, ALLOCATABLE, SAVE :: TAU_AERO_WL ( :,:,: ) ! total aerosol optical depth REAL, ALLOCATABLE, SAVE :: TAU_CLOUD_WL( :,:,: ) ! total cloud optical depth REAL, ALLOCATABLE, SAVE :: CLR_TRANSMISSION( :,: ) ! diffuse transmission coefficient of clouds REAL, ALLOCATABLE, SAVE :: CLR_REFLECTION ( :,: ) ! reflection coefficient of cloud REAL, ALLOCATABLE, SAVE :: CLR_TRANS_DIRECT( :,: ) ! direct transmission coefficient of clouds -#ifdef phot_debug +#ifdef phot_debug REAL, ALLOCATABLE, SAVE :: ASY_CLOUD_WL( :,:,: ) ! columm average of cloud asymmetry factor REAL, ALLOCATABLE, SAVE :: SSA_CLOUD_WL( :,:,: ) ! columm average of cloud single scattering albedo -#endif +#endif REAL, ALLOCATABLE, SAVE :: TAU_TOT_WL ( :,:,: ) ! total optical depth REAL, ALLOCATABLE, SAVE :: TAUO3_TOP_WL( :,:,: ) ! optical depth of ozone above model domain REAL, ALLOCATABLE, SAVE :: AERO_SSA ( :,:,:,: ) ! aerosol single scattering albedo REAL, ALLOCATABLE, SAVE :: AERO_ASYM ( :,:,:,: ) ! aerosol asymmetry factor - REAL, ALLOCATABLE, SAVE :: TAU ( :,:,:,: ) ! optical depth - REAL, ALLOCATABLE, SAVE :: TAU_AERO ( :,:,:,: ) ! aerosol optical depth + REAL, ALLOCATABLE, SAVE :: TOT_EXT ( :,:,:,: ) ! total extinction for layer [1/Km] + REAL, ALLOCATABLE, SAVE :: GAS_EXT ( :,:,:,: ) ! clear sky extinction for layer [1/Km] + REAL, ALLOCATABLE, SAVE :: AERO_EXT ( :,:,:,: ) ! aerosol extinction for layer [1/Km] REAL, ALLOCATABLE, SAVE :: ACTINIC_FX( :,:,:,: ) ! net actinic flux [watts/m**2] + REAL, ALLOCATABLE, SAVE :: OUTPUT_BUFF ( :,:,: ) ! output buffer for DIAG2 and DIAG3 files - INTEGER IOSX ! i/o and allocate memory status + INTEGER IOSX ! i/o and allocate memory status (Wei Li) INTERFACE - SUBROUTINE O3TOTCOL ( LATITUDE, LONGITUDE, JDATE, OZONE ) + SUBROUTINE O3TOTCOL ( LATITUDE, LONGITUDE, JDATE, JTIME, OZONE ) INTEGER, INTENT( IN ) :: JDATE ! Julian day of the year (yyyyddd) + INTEGER, INTENT( IN ) :: JTIME ! time (hhmmss) REAL, INTENT( IN ) :: LATITUDE ! latitude of point on earth's surface REAL, INTENT( IN ) :: LONGITUDE ! longitude of point on earth's surface REAL, INTENT( INOUT ) :: OZONE ! total column ozone [DU] END SUBROUTINE O3TOTCOL + SUBROUTINE CONVCLD_PROP_ACM( JDATE, JTIME, TSTEP ) + INTEGER, INTENT( IN ) :: JDATE + INTEGER, INTENT( IN ) :: JTIME + INTEGER, INTENT( IN ) :: TSTEP( 3 ) + END SUBROUTINE CONVCLD_PROP_ACM END INTERFACE ! ---------------------------------------------------------------------- IF ( FIRSTIME ) THEN -C In-line canopy shading option? (default = false) +C In-line canopy shading option? (default = false) (Wei Li) CANOPY_SHADE = ENVYN( 'CTM_CANOPY_SHADE', & 'Flag for in-line canopy shading', @@ -363,105 +365,82 @@ END SUBROUTINE O3TOTCOL IF ( CANOPY_SHADE ) THEN XMSG = 'Using in-line canopy shading option' - CALL M3MSG2( XMSG ) + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF + FIRSTIME = .FALSE. - LOGDEV = INIT3() TSTEP = TIME2SEC( DTSTEP( 1 ) ) ! output timestep for phot diagnostic files - CGRID => PCGRID( 1:MY_NCOLS,1:MY_NROWS,:,: ) - -!...Get photolysis rate diagnostic file flag - - PHOTDIAG = .FALSE. ! default - VARDESC= 'Flag for writing the photolysis rate diagnostic file' - PHOTDIAG = ENVYN( CTM_PHOTDIAG, VARDESC, PHOTDIAG, ESTAT ) - IF ( ESTAT .NE. 0 ) WRITE( LOGDEV, '(5X, A)' ) VARDESC - IF ( ESTAT .EQ. 1 ) THEN - XMSG = 'Environment variable improperly formatted' - CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT2 ) - ELSE IF ( ESTAT .EQ. -1 ) THEN - XMSG = - & 'Environment variable set, but empty ... Using default:' - WRITE( LOGDEV, '(5X, A, I9)' ) XMSG, JTIME - ELSE IF ( ESTAT .EQ. -2 ) THEN - XMSG = 'Environment variable not set ... Using default:' - WRITE( LOGDEV, '(5X, A, I9)' ) XMSG, JTIME - END IF - -!...Get met file offsets +!...Set flag to initialize calculating aerosol extinction at 550 nm via Angstrom Exponents + CALCULATE_EXT_550 = .TRUE. !PHOTDIAG - CALL SUBHFILE ( GRID_CRO_2D, GXOFF, GYOFF, - & STRTCOLGC2, ENDCOLGC2, STRTROWGC2, ENDROWGC2 ) - CALL SUBHFILE ( MET_CRO_2D, GXOFF, GYOFF, - & STRTCOLMC2, ENDCOLMC2, STRTROWMC2, ENDROWMC2 ) - CALL SUBHFILE ( MET_CRO_3D, GXOFF, GYOFF, - & STRTCOLMC3, ENDCOLMC3, STRTROWMC3, ENDROWMC3 ) - PECOL_OFFSET = COLSD_PE( 1, MYPE+1 ) - 1 PEROW_OFFSET = ROWSD_PE( 1, MYPE+1 ) - 1 - CALL LOAD_CSQY_DATA( ) + CALL INIT_PHOT_SHARED() - CALL LOAD_OPTICS_DATA( ) - !...Allocate array needed to calculation aerosol and cloud optical properties CALL INIT_AERO_DATA( ) - + CALL INIT_CLOUD_OPTICS( ) -!...Allocate and initialize new canopy arrays - IF ( CANOPY_SHADE ) THEN - ALLOCATE( RJ_CORRX ( MAXCAN ) ) - ALLOCATE( ZCANX ( MAXCAN ) ) +!...Allocate and initialize new canopy arrays (Wei Li) + IF ( CANOPY_SHADE ) THEN + ALLOCATE( RJ_CORRX ( MAXCAN ) ) + ALLOCATE( ZCANX ( MAXCAN ) ) - ALLOCATE( RJ_CORR_C1R ( NCOLS, NROWS ), + ALLOCATE( RJ_CORR_C1R ( NCOLS, NROWS ), & RJ_CORR_C2R ( NCOLS, NROWS ), & RJ_CORR_C3R ( NCOLS, NROWS ), & RJ_CORR_C4R ( NCOLS, NROWS ), & RJ_CORR_BOT ( NCOLS, NROWS ), & RJ_CORR ( NCOLS, NROWS ), STAT = ALLOCSTAT ) - IF ( ALLOCSTAT .NE. 0 ) THEN - XMSG = 'Failure allocating canopy photolysis rate correction arrays' - CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - END IF - - RJ_CORRX=0.0 - ZCANX=0.0 - RJ_CORR_C1R=0.0 - RJ_CORR_C2R=0.0 - RJ_CORR_C3R=0.0 - RJ_CORR_C4R=0.0 - RJ_CORR_BOT=0.0 - RJ_CORR=0.0 - END IF + IF ( ALLOCSTAT .NE. 0 ) THEN + XMSG = 'Failure allocating canopy photolysis rate correction arrays' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + RJ_CORRX=0.0 + ZCANX=0.0 + RJ_CORR_C1R=0.0 + RJ_CORR_C2R=0.0 + RJ_CORR_C3R=0.0 + RJ_CORR_C4R=0.0 + RJ_CORR_BOT=0.0 + RJ_CORR=0.0 + END IF + + +! set cosine values for sun effectively below horizon + COS85 = COS( 85.0 * PI180 ) !...Initialize Surface albedo method - IF ( .NOT. INITIALIZE_ALBEDO( JDATE, JTIME, LOGDEV ) ) THEN + IF ( .NOT. INITIALIZE_ALBEDO( JDATE, JTIME ) ) THEN XMSG = 'Failure initializing photolysis surface albedo algorithm' CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF ALLOCATE( ETOT_SFC ( NWL ) ) - ALLOCATE( LWC ( NLAYS ) ) - ALLOCATE( RWC ( NLAYS ) ) - ALLOCATE( IWC ( NLAYS ) ) - ALLOCATE( SWC ( NLAYS ) ) - ALLOCATE( GWC ( NLAYS ) ) - ALLOCATE( BLKPRS ( NLAYS ) ) - ALLOCATE( BLKTA ( NLAYS ) ) - ALLOCATE( BLKDENS( NLAYS ) ) - ALLOCATE( BLKZH ( NLAYS ) ) - ALLOCATE( BLKO3 ( NLAYS ) ) - ALLOCATE( BLKNO2 ( NLAYS ) ) + ALLOCATE( LWC ( NLAYS ) ) + ALLOCATE( RWC ( NLAYS ) ) + ALLOCATE( IWC ( NLAYS ) ) + ALLOCATE( SWC ( NLAYS ) ) + ALLOCATE( GWC ( NLAYS ) ) + ALLOCATE( BLKPRS ( NLAYS ) ) + ALLOCATE( BLKTA ( NLAYS ) ) + ALLOCATE( BLKDZ ( NLAYS ) ) + ALLOCATE( BLKDENS( NLAYS ) ) + ALLOCATE( BLKZH ( NLAYS ) ) + ALLOCATE( BLKO3 ( NLAYS ) ) + ALLOCATE( BLKNO2 ( NLAYS ) ) ALLOCATE( BLKZF ( NLAYS+1 ) ) - ALLOCATE( CLOUDS ( NLAYS ) ) - ALLOCATE( CLDFRAC( NLAYS ) ) + ALLOCATE( CLOUDS ( NLAYS ) ) + ALLOCATE( CLDFRAC( NLAYS ) ) ALLOCATE( BLKRJ_RES( NLAYS,NPHOTAB ) ) ALLOCATE( BLKRJ_ACM( NLAYS,NPHOTAB ) ) @@ -475,9 +454,16 @@ END SUBROUTINE O3TOTCOL ALLOCATE( TAU_TOT ( NLAYS,NWL ) ) ALLOCATE( TOTAL_OC ( NCOLS,NROWS ) ) + ALLOCATE( TAU_AERO_550 ( NCOLS,NROWS ) ) + TAU_AERO_550 = 0.0 IF ( PHOTDIAG ) THEN - ALLOCATE( TROPO_OC ( NCOLS,NROWS ) ) + + ALLOCATE( TROPO_OC ( NCOLS,NROWS ) ) + ALLOCATE( CO_COLUMN ( NCOLS,NROWS ) ) + ALLOCATE( SO2_COLUMN ( NCOLS,NROWS ) ) + ALLOCATE( NO2_COLUMN ( NCOLS,NROWS ) ) + ALLOCATE( HCHO_COLUMN( NCOLS,NROWS ) ) ALLOCATE( TROPO_O3_EXCEED( NCOLS,NROWS ) ) ALLOCATE( N_EXCEED_TROPO3( NCOLS,NROWS ) ) ALLOCATE( TRANSMIS_DIFFUSE( NCOLS,NROWS ) ) @@ -486,73 +472,205 @@ END SUBROUTINE O3TOTCOL ALLOCATE( CLR_TRANSMISSION( NCOLS,NROWS ) ) ALLOCATE( CLR_TRANS_DIRECT( NCOLS,NROWS ) ) ALLOCATE( CLR_REFLECTION ( NCOLS,NROWS ) ) - ALLOCATE( ETOT_SFC_WL ( NCOLS,NROWS,NWL ) ) ALLOCATE( TAU_AERO_WL ( NCOLS,NROWS,NWL ) ) ALLOCATE( TAU_CLOUD_WL ( NCOLS,NROWS,NWL ) ) -#ifdef phot_debug +#ifdef phot_debug ALLOCATE( SSA_CLOUD_WL( NCOLS,NROWS,NWL ) ) ALLOCATE( ASY_CLOUD_WL( NCOLS,NROWS,NWL ) ) -#endif +#endif ALLOCATE( TAU_TOT_WL ( NCOLS,NROWS,NWL ) ) ALLOCATE( TAUO3_TOP_WL( NCOLS,NROWS,NWL ) ) - + N_EXCEED_TROPO3 = 0.0 TROPO_O3_EXCEED = 0.0 TSTEP_COUNT = 0 + TROPO_OC = 0.0 + CO_COLUMN = 0.0 + SO2_COLUMN = 0.0 + NO2_COLUMN = 0.0 + HCHO_COLUMN = 0.0 + + +!...write wavelength data to a character array + + ALLOCATE ( WLTXT( NWL ) ) + + DO IWL = 1, NWL + WRITE( WLTXT( IWL ),'(I3.3)' ) INT( WAVELENGTH( IWL ) ) + END DO + +! get wanted number of layers for PHOTDIAG2 and PHOTDIAG3 files + IF ( NLAYS_DIAG .EQ. 0 ) NLAYS_DIAG = NLAYS + NLAYS_DIAG = MAX( 1, MIN( NLAYS_DIAG, NLAYS)) + +! get wanted wavelengths for PHOTDIAG2 and PHOTDIAG3 files + ALLOCATE( WAVE_LIST( NWL ) ) + WAVE_LIST( : ) = '' + IF ( NWAVE .GT. NWL ) + & CALL LOG_MESSAGE( LOGDEV, 'Error: the number of ' // + & 'wavelengths the user has requested for diagnostic ' // + & 'photolysis output exceeds the number of internal model ' // + & 'wavelengths.' ) + IF ( NWAVE .EQ. 0 ) THEN ! use all wavelenghts + N_DIAG_WVL = NWL + ALLOCATE ( DIAG_WVL( N_DIAG_WVL ) , STAT = ALLOCSTAT ) + IF ( ALLOCSTAT .NE. 0 ) THEN + XMSG = 'Failure allocating DIAG_WVL' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + DO IWL = 1, NWL + DIAG_WVL( IWL ) = IWL + END DO + WRITE(LOGDEV,'(5X,A,I3)')'Environment Variable NWAVE_PHOTDIAG not found ' + & // 'setting PHOTDIAG2 and PHOTDIAG3 to output all wavelengths. Integer ' + & // 'truncated values are below.' + DO IWL = 1, N_DIAG_WVL + SPC = DIAG_WVL( IWL ) + WRITE(LOGDEV,'(5X,I3,1X,A16)')IWL, WLTXT(SPC) + END DO + ELSE ! use the environment list + WAVE_LIST( 1:NWAVE ) = WAVE_ENV( 1:NWAVE ) + N_DIAG_WVL = 0 + ! first remove identical values + DO V = 1, NWAVE-1 + DO L = (V+1), NWAVE + IF( TRIM( WAVE_LIST( V ) ) .EQ. TRIM( WAVE_LIST( L ) ) )THEN + WAVE_LIST( L ) = " " + END IF + END DO + END DO + ! Now count number of unique values + DO V = 1, NWAVE + IF( LEN_TRIM( WAVE_LIST( V ) ) .GT. 0 )N_DIAG_WVL = N_DIAG_WVL + 1 + END DO + ALLOCATE ( DIAG_WVL( N_DIAG_WVL ) , STAT = ALLOCSTAT ) + IF ( ALLOCSTAT .NE. 0 ) THEN + XMSG = 'Failure allocating DIAG_WVL' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + ! Next find unique list value in wavelenght spectrum + IWL = 0 + DO V = 1, NWAVE + IF( LEN_TRIM( WAVE_LIST( V ) ) .LT. 1 )CYCLE + IWL = IWL + 1 + DIAG_WVL( IWL ) = INDEXR ( TRIM( WAVE_LIST( V ) ), NWL, WLTXT ) + IF ( DIAG_WVL( IWL ) .LT. 1 ) THEN + WRITE(LOGDEV,'(5X,A)')'PHOT: Cannot find requested wavelength, ' + & // TRIM( WAVE_LIST( IWL ) ) // ' for DIAG2 and DIAG3 files ' + & // ' in spectrum ' + END IF + END DO + IF( MINVAL( DIAG_WVL ) .LT. 1 )THEN + XMSG = 'FAILED TO find the above requested wavelenght spectrum ' + WRITE( LOGDEV,'(5X,A)')XMSG + XMSG = 'Permitted integer truncated values of wavelenght spectrum ' + DO IWL = 1, NWL + WRITE(LOGDEV,'(10X,I3,1X,A16)')IWL, WLTXT(IWL) + END DO + XMSG = 'ERROR using the environment variable, NWAVE_PHOTDIAG ' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + ELSE + WRITE(LOGDEV,'(5X,A,I3)')'Environment Variable NWAVE_PHOTDIAG found ' + & // 'setting PHOTDIAG2 and PHOTDIAG3 to output below wavelenghts' + DO IWL = 1, N_DIAG_WVL + SPC = DIAG_WVL( IWL ) + WRITE(LOGDEV,'(5X,I3,1X,A16)')IWL, WLTXT(SPC) + END DO + END IF + END IF + WRITE(LOGDEV,'(/)') - DIAG_WVL( 1 ) = 1 - DIAG_WVL( N_DIAG_WVL ) = NWL - ALLOCATE ( AERO_ASYM( NCOLS,NROWS,NLAYS,N_DIAG_WVL ), STAT = ALLOCSTAT ) + ALLOCATE ( AERO_ASYM( NCOLS,NROWS,NLAYS_DIAG,N_DIAG_WVL ), STAT = ALLOCSTAT ) IF ( ALLOCSTAT .NE. 0 ) THEN XMSG = 'Failure allocating 3D AERO_ASYM' CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF - ALLOCATE ( AERO_SSA( NCOLS,NROWS,NLAYS,N_DIAG_WVL ), STAT = ALLOCSTAT ) + ALLOCATE ( AERO_SSA( NCOLS,NROWS,NLAYS_DIAG,N_DIAG_WVL ), STAT = ALLOCSTAT ) IF ( ALLOCSTAT .NE. 0 ) THEN XMSG = 'Failure allocating 3D AERO_SSA' CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF - ALLOCATE ( TAU_AERO( NCOLS,NROWS,NLAYS,N_DIAG_WVL ), STAT = ALLOCSTAT ) + ALLOCATE ( AERO_EXT( NCOLS,NROWS,NLAYS_DIAG,N_DIAG_WVL ), STAT = ALLOCSTAT ) IF ( ALLOCSTAT .NE. 0 ) THEN - XMSG = 'Failure allocating 3D TAU_AERO' + XMSG = 'Failure allocating 3D AERO_EXT' CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF - ALLOCATE ( TAU( NCOLS,NROWS,NLAYS,N_DIAG_WVL ), STAT = ALLOCSTAT ) + ALLOCATE ( TOT_EXT( NCOLS,NROWS,NLAYS_DIAG,N_DIAG_WVL ), STAT = ALLOCSTAT ) IF ( ALLOCSTAT .NE. 0 ) THEN - XMSG = 'Failure allocating 3D TAU' + XMSG = 'Failure allocating 3D TOT_EXT' CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF - ALLOCATE ( ACTINIC_FX( NCOLS,NROWS,NLAYS,NWL ), STAT = ALLOCSTAT ) + ALLOCATE ( GAS_EXT( NCOLS,NROWS,NLAYS_DIAG,N_DIAG_WVL ), STAT = ALLOCSTAT ) IF ( ALLOCSTAT .NE. 0 ) THEN - XMSG = 'Failure allocating ACTINIC_FX' + XMSG = 'Failure allocating 3D GAS_EXT' CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF -!...write wavelength data to a character array - - ALLOCATE ( WLTXT( NWL ) ) - - DO IWL = 1, NWL - WRITE( WLTXT( IWL ),'(I3.3)' ) INT( WAVELENGTH( IWL ) ) - END DO + ALLOCATE ( ACTINIC_FX( NCOLS,NROWS,NLAYS_DIAG,N_DIAG_WVL ), STAT = ALLOCSTAT ) + IF ( ALLOCSTAT .NE. 0 ) THEN + XMSG = 'Failure allocating ACTINIC_FX' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF -!...open the photolysis rate diagnostic files + ALLOCATE ( OUTPUT_BUFF( NCOLS,NROWS,NLAYS_DIAG ), STAT = ALLOCSTAT ) + IF ( ALLOCSTAT .NE. 0 ) THEN + XMSG = 'Failure allocating OUTPUT_BUFF' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF - ODATE = JDATE; OTIME = JTIME -#ifndef phot_extra_tstep + VARNM = 'CO' + LGC_CO = INDEX1( VARNM, N_GC_SPC, GC_SPC ) + IF ( LGC_CO .LE. 0 ) THEN + XMSG = 'Could not find ' // VARNM // 'in species table' + CALL M3WARN ( PNAME, JDATE, JTIME, XMSG ) + WRITE(LOGDEV,95101) + END IF + + VARNM = 'SO2' + LGC_SO2 = INDEX1( VARNM, N_GC_SPC, GC_SPC ) + IF ( LGC_SO2 .LE. 0 ) THEN + XMSG = 'Could not find ' // VARNM // 'in species table' + CALL M3WARN ( PNAME, JDATE, JTIME, XMSG ) + WRITE(LOGDEV,95101) + END IF + + VARNM = 'HCHO' + LGC_HCHO = INDEX1( VARNM, N_GC_SPC, GC_SPC ) + IF ( LGC_HCHO .LE. 0 ) THEN + VARNM = 'FORM' + LGC_HCHO = INDEX1( VARNM, N_GC_SPC, GC_SPC ) + IF ( LGC_HCHO .LE. 0 ) THEN + XMSG = 'Could not find HCHO or FORM, i.e., formaldehyde, in species table' + CALL M3WARN ( PNAME, JDATE, JTIME, XMSG ) + WRITE(LOGDEV,95101) + END IF + END IF + +!...open the photolysis diagnostic files + ODATE = START_DATE; OTIME = START_TIME; OSTEP = 0 +#ifdef phot_write_start + IF ( IO_PE_INCLUSIVE ) CALL OPPHOT ( ODATE, OTIME, DTSTEP( 1 ) ) +#else CALL NEXTIME ( ODATE, OTIME, DTSTEP( 1 ) ) ! output timestamp ending time -#endif IF ( IO_PE_INCLUSIVE ) CALL OPPHOT ( ODATE, OTIME, DTSTEP( 1 ) ) - - CALL SUBST_BARRIER +! reset ODATE and OTIME for counting + ODATE = START_DATE; OTIME = START_TIME +#endif END IF ! photdiag + CALL SUBST_BARRIER + ALLOCATE ( AERO_EXT_550( NCOLS,NROWS,NLAYS ), STAT = ALLOCSTAT ) + IF ( ALLOCSTAT .NE. 0 ) THEN + XMSG = 'Failure allocating 3D AERO_EXT_550' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + !...set pointers to species O3 and NO2 in CGRID VARNM = 'O3' @@ -569,23 +687,14 @@ END SUBROUTINE O3TOTCOL CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT3 ) END IF -#ifdef phot_extra_tstep - ELSE - IF ( PHOTDIAG ) THEN - ODATE = JDATE; OTIME = JTIME - CALL NEXTIME ( ODATE, OTIME, DTSTEP( 2 ) ) ! sync time step - END IF -#endif + END IF ! firstime - IF ( JD_STRAT_O3MIN .NE. JDATE ) THEN + IF ( INT ( JD_STRAT_O3MIN ) .NE. JDATE ) THEN !...set minimum fraction of ozone column above PTOP - CALL SEASONAL_STRAT_O3( JDATE, JTIME ) MIN_STRATO3_FRAC = MONTH_STRAT_03_FRAC MAX_TROPOO3_FRAC = MAX( 1.0 - MONTH_STRAT_03_FRAC, 0.0 ) - WRITE( LOGDEV,*)'PHOT: MIN_STRATO3_FRAC = ',MIN_STRATO3_FRAC - JD_STRAT_O3MIN = REAL( JDATE, 4) END IF !...initialize variables tracking whether stratosphere ozone column satisfies @@ -596,12 +705,18 @@ END SUBROUTINE O3TOTCOL N_TROPO_O3_TOGGLE = 0 TSTEP_COUNT = TSTEP_COUNT + 1 - CALL GET_PHOT_MET( JDATE, JTIME, MDATE, MTIME ) + MIDDATE = JDATE + MIDTIME = JTIME + ITMSTEP = TIME2SEC( DTSTEP( 2 ) ) / 2 + CALL NEXTIME( MIDDATE, MIDTIME, SEC2TIME( ITMSTEP ) ) + + CALL CONVCLD_PROP_ACM( JDATE, JTIME, DTSTEP ) + CALL GET_PHOT_MET( JDATE, JTIME, MIDDATE, MIDTIME ) !...Get cosine of solar parameters and set DARK - CALL UPDATE_SUN( JDATE, JTIME, MDATE, MTIME ) - + CALL UPDATE_SUN( JDATE, JTIME, MIDDATE, MIDTIME ) + RSQD = DIST_TO_SUN * DIST_TO_SUN IF ( MAXVAL( COSINE_ZENITH ) .LE. 0.0 ) THEN @@ -612,16 +727,22 @@ END SUBROUTINE O3TOTCOL !...set surface albedos - CALL GET_ALBEDO( MDATE, MTIME, LOGDEV, COSINE_ZENITH, LAT, LON ) + CALL GET_ALBEDO( MIDDATE, MIDTIME, COSINE_ZENITH, LAT, LON ) !...SA Write COSINE_ZENITH array at the end of each output tstep + JTIME_CHK = .FALSE. + OSTEP = OSTEP + TIME2SEC( DTSTEP( 2 ) ) + JTIME_CHK = ( OSTEP .GE. TIME2SEC( DTSTEP( 1 ) ) ) + IF ( JTIME_CHK ) THEN + OSTEP = 0 + CALL NEXTIME( ODATE, OTIME, DTSTEP( 1 ) ) + END IF +#ifdef phot_write_start + JTIME_CHK = ( ODATE .EQ. STDATE .AND. OTIME .EQ. STTIME ) +#endif + IF ( PHOTDIAG ) THEN -#ifndef phot_extra_tstep - ODATE = JDATE; OTIME = JTIME - CALL NEXTIME ( ODATE, OTIME, DTSTEP( 2 ) ) ! sync time step -#endif - JTIME_CHK = ( MOD( TIME2SEC( OTIME ), TSTEP ) .EQ. 0 ) #ifdef parallel_io IF ( .NOT. IO_PE_INCLUSIVE ) THEN IF ( .NOT. OPEN3( CTM_RJ_1, FSREAD3, PNAME ) ) THEN @@ -632,99 +753,144 @@ END SUBROUTINE O3TOTCOL XMSG = 'Could not open ' // TRIM(CTM_RJ_2) CALL M3EXIT( PNAME, ODATE, OTIME, XMSG, XSTAT1 ) END IF + IF ( .NOT. OPEN3( CTM_RJ_3, FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open ' // TRIM(CTM_RJ_3) + CALL M3EXIT( PNAME, ODATE, OTIME, XMSG, XSTAT1 ) + END IF END IF #endif - ELSE - JTIME_CHK = .FALSE. - END IF + END IF + + CALCULATE_EXT_550 = .TRUE. !JTIME_CHK - !...If sun below horizon at all cells, zero photolysis rates & exit !... (assumes sun below horizon at *all* levels!) IF ( DARK ) THEN RJ = 0.0 - -!...write to the log file, CTM_RJ_1 file and return - - WRITE( LOGDEV, 1003 ) MYPE, JDATE, JTIME + RJ_SUB = 0.0 + RJ_RES = 0.0 + ETOT_SFC_WL = 0.0 + AERO_EXT_550 = 0.0 + TAU_AERO_550 = 0.0 !...Initialize ETOT_SFC, TAU_AERO, TAU_TOT, TAUO3_TOP to 0.0 !...Write data to output diagnostic file - TOTAL_OC = 0.0 + IF ( JTIME_CHK .AND. PHOTDIAG ) THEN - IF ( JTIME_CHK ) THEN - - TROPO_OC = 0.0 - ETOT_SFC_WL = 0.0 TAUO3_TOP_WL = 0.0 TAU_AERO_WL = 0.0 TAU_CLOUD_WL = 0.0 -#ifdef phot_debug +#ifdef phot_debug SSA_CLOUD_WL = 0.0 ASY_CLOUD_WL = 0.0 -#endif +#endif TAU_TOT_WL = 0.0 - TAU = 0.0 - TAU_AERO = 0.0 + TOT_EXT = 0.0 + GAS_EXT = 0.0 + AERO_EXT = 0.0 AERO_SSA = 0.0 AERO_ASYM = 0.0 ACTINIC_FX = 0.0 -! TROPO_O3_EXCEED = 0.0 TRANSMIS_DIFFUSE = 0.0 TRANSMIS_DIRECT = 0.0 REFLECT_COEFF = 0.0 CLR_TRANSMISSION = 0.0 CLR_TRANS_DIRECT = 0.0 - CLR_REFLECTION = 0.0 - - END IF ! if JTIME_CHK + CLR_REFLECTION = 0.0 + + DO ROW = 1, NROWS + DO COL = 1, NCOLS + BLKDENS( 1 ) = DENS ( COL,ROW,1 ) * DENS_CONV ! [molecules / cm**3] + BLKDZ ( 1 ) = ZFULL( COL,ROW,1 ) + DO L = 2, NLAYS + BLKDENS( L ) = DENS( COL,ROW,L ) * DENS_CONV ! [molecules / cm**3] + BLKDZ ( L ) = ZFULL( COL,ROW,L ) - ZFULL( COL,ROW,L-1 ) + END DO + MSCALE = 1.0E-19 ! 100.0*10E-15*PPM_MCM3, so units are petamolecules/cm2 + CALL COLUMN_GAS( IGAS=LGC_CO, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=CO_COLUMN ) + CALL COLUMN_GAS( IGAS=LGC_SO2, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=SO2_COLUMN ) + CALL COLUMN_GAS( IGAS=LGC_NO2, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=NO2_COLUMN ) + CALL COLUMN_GAS( IGAS=LGC_HCHO, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=HCHO_COLUMN ) + MSCALE = 1.0E-4 * CONC_TO_DU ! so units are Dobsons + CALL COLUMN_GAS( IGAS=LGC_O3, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=TROPO_OC ) +!...get total ozone column based on OMI observations + CALL O3TOTCOL ( LAT( COL,ROW ), LON( COL,ROW ), MIDDATE, MIDTIME, TOTAL_OC( COL,ROW ) ) + END DO + END DO + ELSE + DO ROW = 1, NROWS + DO COL = 1, NCOLS +!...get total ozone column based on OMI observations + CALL O3TOTCOL ( LAT( COL,ROW ), LON( COL,ROW ), MIDDATE,MIDTIME, TOTAL_OC( COL,ROW ) ) + END DO + END DO + END IF ! if JTIME_CHK and PHOTDIAG ELSE ! all cells not dark - + !...MAIN loop over all rows and columns - LOOP_ROWS: DO ROW = 1, MY_NROWS - LOOP_COLS: DO COL = 1, MY_NCOLS - + LOOP_ROWS: DO ROW = 1, NROWS + LOOP_COLS: DO COL = 1, NCOLS + PHOT_COL = COL + PECOL_OFFSET PHOT_ROW = ROW + PEROW_OFFSET COSZEN = COSINE_ZENITH( COL,ROW ) ! local cosine of solar zenith angle + TAU_AERO_550( COL,ROW ) = 0.0 + AERO_EXT_550( COL,ROW,: ) = 0.0 IF ( COSZEN .LE. 0.0 ) THEN !...the cell is dark: set variables to zero and cycle RJ( COL,ROW, :,: ) = 0.0 - - IF ( JTIME_CHK ) THEN - TOTAL_OC( COL,ROW ) = 0.0 - TROPO_OC( COL,ROW ) = 0.0 - ETOT_SFC_WL ( COL,ROW, : ) = 0.0 + RJ_RES( COL,ROW, :,: ) = 0.0 + RJ_SUB( COL,ROW, :,: ) = 0.0 + ETOT_SFC_WL ( COL,ROW, : ) = 0.0 + + IF ( JTIME_CHK .AND. PHOTDIAG ) THEN TAUO3_TOP_WL( COL,ROW, : ) = 0.0 TAU_AERO_WL ( COL,ROW, : ) = 0.0 TAU_CLOUD_WL( COL,ROW, : ) = 0.0 -#ifdef phot_debug +#ifdef phot_debug SSA_CLOUD_WL( COL,ROW, : ) = 0.0 ASY_CLOUD_WL( COL,ROW, : ) = 0.0 -#endif - TAU_TOT_WL( COL,ROW, : ) = 0.0 - TAU ( COL,ROW, :,: ) = 0.0 - TAU_AERO ( COL,ROW, :,: ) = 0.0 - AERO_SSA ( COL,ROW, :,: ) = 0.0 - AERO_ASYM ( COL,ROW, :,: ) = 0.0 - ACTINIC_FX( COL,ROW, :,: ) = 0.0 - +#endif + TAU_TOT_WL ( COL,ROW, : ) = 0.0 + TOT_EXT ( COL,ROW, :,: ) = 0.0 + GAS_EXT ( COL,ROW, :,: ) = 0.0 + AERO_EXT ( COL,ROW, :,: ) = 0.0 + AERO_SSA ( COL,ROW, :,: ) = 0.0 + AERO_ASYM ( COL,ROW, :,: ) = 0.0 + ACTINIC_FX ( COL,ROW, :,: ) = 0.0 + ! TROPO_O3_EXCEED( COL,ROW ) = 0.0 TRANSMIS_DIFFUSE( COL,ROW ) = 0.0 TRANSMIS_DIRECT ( COL,ROW ) = 0.0 REFLECT_COEFF ( COL,ROW ) = 0.0 CLR_TRANSMISSION( COL,ROW ) = 0.0 CLR_TRANS_DIRECT( COL,ROW ) = 0.0 - CLR_REFLECTION ( COL,ROW ) = 0.0 - END IF + CLR_REFLECTION ( COL,ROW ) = 0.0 + + BLKDENS( 1 ) = DENS ( COL,ROW,1 ) * DENS_CONV ! [molecules / cm**3] + BLKDZ ( 1 ) = ZFULL( COL,ROW,1 ) + DO L = 2, NLAYS + BLKDENS( L ) = DENS( COL,ROW,L ) * DENS_CONV ! [molecules / cm**3] + BLKDZ ( L ) = ZFULL( COL,ROW,L ) - ZFULL( COL,ROW,L-1 ) + END DO + MSCALE = 1.0E-19 ! 100.0*10E-15*PPM_MCM3, so units are petamolecules/cm2 + CALL COLUMN_GAS( IGAS=LGC_CO, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=CO_COLUMN ) + CALL COLUMN_GAS( IGAS=LGC_SO2, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=SO2_COLUMN ) + CALL COLUMN_GAS( IGAS=LGC_NO2, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=NO2_COLUMN ) + CALL COLUMN_GAS( IGAS=LGC_HCHO, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=HCHO_COLUMN ) + MSCALE = 1.0E-4 * CONC_TO_DU ! so units are Dobsons + CALL COLUMN_GAS( IGAS=LGC_O3, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=TROPO_OC ) +!...get total ozone column based on OMI observations + CALL O3TOTCOL ( LAT( COL,ROW ), LON( COL,ROW ), MIDDATE, MIDTIME, TOTAL_OC( COL,ROW ) ) + END IF CYCLE LOOP_COLS @@ -742,20 +908,15 @@ END SUBROUTINE O3TOTCOL ZSFC = HT( COL,ROW ) ! surface height [m] SINZEN = SQRT( 1.0 - COSZEN * COSZEN ) ! sine of zenith angle -!...local latitude and longitude - -! LATCR = LAT( COL,ROW ) -! LONCR = LON( COL,ROW ) - !...get total ozone column based on OMI observations - CALL O3TOTCOL ( LAT( COL,ROW ), LON( COL,ROW ), JDATE, TOTAL_O3_COLUMN ) - + CALL O3TOTCOL ( LAT( COL,ROW ), LON( COL,ROW ), MIDDATE, MIDTIME, TOTAL_O3_COLUMN ) + IF ( USE_ACM_CLOUD .OR. CLDATT ) THEN OWATER_FRAC = MAX( ( 1.0 - SEAICE( COL,ROW ) ), 0.0 ) & * WATER_FRACTION( COL,ROW ) SEAICE_FRAC = SEAICE( COL,ROW ) * WATER_FRACTION( COL,ROW ) SNOW_FRAC = SNOCOV( COL,ROW ) - COL_CLOUD = PHOT_COL + COL_CLOUD = PHOT_COL ROW_CLOUD = PHOT_ROW END IF @@ -785,7 +946,7 @@ END SUBROUTINE O3TOTCOL IF ( CLDATT .AND. CFRAC_2D( COL,ROW ) .GT. 0.0 ) THEN DO L = 1, NLAYS - + IF ( CFRAC_3D( COL,ROW,L ) .GT. 0.0 ) THEN CLOUDS ( L ) = .TRUE. CLOUD_LAYERING( L ) = .TRUE. @@ -794,7 +955,7 @@ END SUBROUTINE O3TOTCOL MSCALE = 1.0E+3 * DENS ( COL,ROW,L ) IWC( L ) = MSCALE * QI( COL,ROW,L ) GWC( L ) = MSCALE * QG( COL,ROW,L ) - SWC( L ) = MSCALE * QS( COL,ROW,L ) + SWC( L ) = MSCALE * QS( COL,ROW,L ) LWC( L ) = MSCALE * QC( COL,ROW,L ) RWC( L ) = MSCALE * QR( COL,ROW,L ) ELSE @@ -803,15 +964,15 @@ END SUBROUTINE O3TOTCOL CLDFRAC( L ) = 0.0 IWC( L ) = 0.0 GWC( L ) = 0.0 - SWC( L ) = 0.0 + SWC( L ) = 0.0 LWC( L ) = 0.0 RWC( L ) = 0.0 END IF END DO ! loop on layers clouds ! get optical properties of resolved cloud hydrometeors - CALL GET_DROPLET_OPTICS( NLAYS, BLKTA, OWATER_FRAC, SEAICE_FRAC, SNOW_FRAC, LWC ) + CALL GET_DROPLET_OPTICS( NLAYS, BLKTA, OWATER_FRAC, SEAICE_FRAC, SNOW_FRAC, LWC ) CALL GET_ICE_OPTICS( NLAYS, BLKTA, IWC ) - CALL GET_AGGREGATE_OPTICS( NLAYS, RWC, SWC, GWC ) + CALL GET_AGGREGATE_OPTICS( NLAYS, RWC, SWC, GWC ) ELSE CLOUDS = .FALSE. CLOUD_LAYERING = .FALSE. @@ -824,31 +985,26 @@ END SUBROUTINE O3TOTCOL RWC = 0.0 CALL CLEAR_HYDROMETEOR_OPTICS() END IF - + !..calculate needed aerosol properties in column ! IF ( CORE_SHELL ) THEN - CALL GET_AERO_DATA ( COL,ROW, NLAYS, CGRID ) + CALL GET_AERO_DATA ( COL,ROW, NLAYS, DENS, CGRID ) ! ELSE ! CALL AERO_OPTICS_INTERNAL( COL,ROW, NLAYS, CGRID ) ! END IF ! set surface albedo - FORALL ( IWL = 1:NWL ) + DO IWL = 1, NWL ALB( IWL ) = SURFACE_ALBEDO( IWL, COL,ROW ) - END FORALL -!set min/max fractions of ozone column in stratosphere and troposphere -! MIN_STRATO3_FRAC = MIN_STRAT_03_FRAC( COL, ROW ) -! MAX_TROPOO3_FRAC = MAX( 1.0 - MIN_STRAT_03_FRAC( COL, ROW ), 0.0 ) -! MIN_STRATO3_FRAC = MONTH_STRAT_03_FRAC( COL, ROW ) -! MAX_TROPOO3_FRAC = MAX( 1.0 - MONTH_STRAT_03_FRAC( COL, ROW ), 0.0 ) + END DO !...calculate resolved-sky photolysis rates at all layers: - NEW_PROFILE = .TRUE. - ONLY_SOLVE_RAD = .FALSE. - - CALL NEW_OPTICS ( JDATE, JTIME, NLAYS, + NEW_PROFILE = .TRUE. + ONLY_SOLVE_RAD = .FALSE. + + CALL NEW_OPTICS ( JDATE, JTIME, NLAYS, & BLKTA, BLKPRS, BLKDENS, BLKZH, BLKZF, & BLKO3, BLKNO2, & ZSFC, COSZEN, SINZEN, RSQD, @@ -857,59 +1013,87 @@ END SUBROUTINE O3TOTCOL & TAU_RAY, SSA, TAU_CLOUD, TOTAL_O3_COLUMN ) !...load diagnostic file arrays + ! Aerosol extinction and optical depth are saved every + ! time step + FORALL ( L = 1:NLAYS ) + AERO_EXT_550( COL,ROW,L ) = 1000.0 * AERO_EXTI_550( L ) + END FORALL + DO LEV = 1, NLAYS + TAU_AERO_550 ( COL,ROW ) = TAU_AERO_550 ( COL,ROW ) + & + AERO_EXTI_550( LEV ) * BLKDZ( LEV ) + END DO + IF ( PHOTDIAG .AND. .NOT. STRATO3_MINS_MET ) THEN N_EXCEED_TROPO3( COL,ROW ) = N_EXCEED_TROPO3( COL,ROW ) + 1.0 TROPO_O3_EXCEED( COL,ROW ) = TROPO_O3_COLUMN/(MAX_TROPOO3_FRAC*TOTAL_O3_COLUMN) - 1.0 -! & + 1.0 / TROPO_O3_TOGGLE - 1.0 & + TROPO_O3_EXCEED( COL,ROW ) -! ELSE IF( PHOTDIAG ) THEN -! TROPO_O3_EXCEED( COL,ROW ) = 0.0 - END IF + END IF - IF ( JTIME_CHK ) THEN - TOTAL_OC( COL,ROW ) = REAL( TOTAL_O3_COLUMN ) - TROPO_OC( COL,ROW ) = REAL( TROPO_O3_COLUMN ) + FORALL ( IWL = 1:NWL ) + ETOT_SFC_WL ( COL,ROW,IWL ) = IRRADIANCE( 1,IWL ) + END FORALL + + IF ( JTIME_CHK .AND. PHOTDIAG ) THEN + TOTAL_OC( COL,ROW ) = TOTAL_O3_COLUMN TRANSMIS_DIFFUSE( COL,ROW ) = TRANSMISSION TRANSMIS_DIRECT( COL,ROW ) = TRANS_DIRECT REFLECT_COEFF( COL,ROW ) = REFLECTION - FORALL( IWL = 1:NWL ) - ETOT_SFC_WL ( COL,ROW,IWL ) = IRRADIANCE( 1,IWL ) - TAUO3_TOP_WL( COL,ROW,IWL ) = TAUO3_TOP( IWL ) - TAU_AERO_WL ( COL,ROW,IWL ) = TAUC_AERO( 1,IWL ) - TAU_TOT_WL ( COL,ROW,IWL ) = TAU_TOT ( 1,IWL ) - TAU_CLOUD_WL( COL,ROW,IWL ) = TAU_CLOUD( 1,IWL ) -#ifdef phot_debug + DO IWL = 1, NWL + TAUO3_TOP_WL( COL,ROW,IWL ) = TAUO3_TOP( IWL ) + TAU_AERO_WL ( COL,ROW,IWL ) = TAUC_AERO( 1,IWL ) + TAU_TOT_WL ( COL,ROW,IWL ) = TAU_TOT ( 1,IWL ) + TAU_CLOUD_WL( COL,ROW,IWL ) = TAU_CLOUD( 1,IWL ) +#ifdef phot_debug SSA_CLOUD_WL( COL,ROW,IWL ) = AVE_SSA_CLD ( IWL ) ASY_CLOUD_WL( COL,ROW,IWL ) = AVE_ASYMM_CLD( IWL ) -#endif - END FORALL - FORALL ( LEV = 1:NLAYS, IWL = 1:NWL ) - ACTINIC_FX( COL,ROW,LEV,IWL ) = ACTINIC_FLUX( LEV,IWL ) - END FORALL - +#endif + END DO + + DO L = 1, N_DIAG_WVL IWL = DIAG_WVL( L ) - FORALL ( LEV = 1:NLAYS ) - TAU ( COL,ROW,LEV,L ) = TAU_TOT ( LEV,IWL ) - TAU_AERO( COL,ROW,LEV,L ) = TAUC_AERO( LEV,IWL ) + FORALL ( LEV = 1:NLAYS_DIAG ) + ACTINIC_FX( COL,ROW,LEV,L ) = ACTINIC_FLUX( LEV,IWL ) + TOT_EXT ( COL,ROW,LEV,L ) = 1000.0 * EXTINCTION( LEV,IWL ) + GAS_EXT ( COL,ROW,LEV,L ) = 1000.0 * GAS_EXTINCTION( LEV,IWL ) + AERO_EXT( COL,ROW,LEV,L ) = 1000.0 * AERO_EXTI_COEF( LEV,IWL ) END FORALL - FORALL ( LEV = 1:NLAYS, AERO_EXTI_COEF( LEV,IWL ) .GT. EPSLON ) + FORALL ( LEV = 1:NLAYS_DIAG, AERO_EXTI_COEF( LEV,IWL ) .GT. EPSLON ) AERO_SSA ( COL,ROW,LEV,L ) = AERO_SCAT_COEF( LEV,IWL ) & / AERO_EXTI_COEF( LEV,IWL ) AERO_ASYM( COL,ROW,LEV,L ) = AERO_ASYM_FAC( LEV,IWL ) END FORALL - FORALL ( LEV = 1:NLAYS, AERO_EXTI_COEF( LEV,IWL ) .LE. EPSLON ) + FORALL ( LEV = 1:NLAYS_DIAG, AERO_EXTI_COEF( LEV,IWL ) .LE. EPSLON ) AERO_SSA ( COL,ROW,LEV,L ) = 1.0 AERO_ASYM( COL,ROW,LEV,L ) = 0.0 END FORALL END DO + IF ( COSZEN .LE. COS85 ) THEN + ! calculate because NEW_OPTICS sets BLKDZ and TROPO_O3_COLUMN to zero + BLKDZ( 1 ) = BLKZF( 2 ) + DO L = 2, NLAYS + BLKDZ( L ) = BLKZF( L+1 ) - BLKZF( L ) + END DO + MSCALE = 1.0E-4 * CONC_TO_DU ! so units are Dobsons + CALL COLUMN_GAS( IGAS=LGC_O3, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=TROPO_OC ) + ELSE + TROPO_OC( COL,ROW ) = TROPO_O3_COLUMN + END IF + MSCALE = 1.0E-19 ! 100.0*10E-15*PPM_MCM3, so units are petamolecules/cm2 + CALL COLUMN_GAS( IGAS=LGC_CO, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=CO_COLUMN ) + CALL COLUMN_GAS( IGAS=LGC_SO2, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=SO2_COLUMN ) + CALL COLUMN_GAS( IGAS=LGC_NO2, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=NO2_COLUMN ) + CALL COLUMN_GAS( IGAS=LGC_HCHO, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=HCHO_COLUMN ) END IF !Set Photolysis rates to resolved sky values FORALL ( L = 1:NLAYS, IPHOT = 1:NPHOTAB ) - RJ( COL,ROW, L,IPHOT ) = 60.0 * BLKRJ_RES( L,IPHOT ) + RJ( COL,ROW, L,IPHOT ) = 60.0 * BLKRJ_RES( L,IPHOT ) + END FORALL ! Loop on layers and NPHOTAB + FORALL ( L = 1:NLAYS, IPHOT = 1:NPHOTAB ) + RJ_RES( COL,ROW, L,IPHOT ) = 60.0 * BLKRJ_RES( L,IPHOT ) END FORALL ! Loop on layers and NPHOTAB IF ( USE_ACM_CLOUD ) THEN @@ -943,16 +1127,14 @@ END SUBROUTINE O3TOTCOL END IF CLOUD_LAYERING( L ) = .FALSE. END DO -! write(logdev,*)'ACM cloud present fraction, cloud lwc(lev),iwc(lev),rwc(1),gwc(1) = ', -! & ACM_CLOUDS( COL,ROW ),lwc(lev),iwc(lev),rwc(1),gwc(1) - + ! get optical properties of of subgrid cloud hydrometeors - CALL GET_DROPLET_OPTICS( LEV, BLKTA, OWATER_FRAC, SEAICE_FRAC, SNOW_FRAC, LWC ) - CALL GET_ICE_OPTICS( LEV, BLKTA, IWC ) - CALL GET_AGGREGATE_OPTICS( LEV, RWC, SWC, GWC ) + CALL GET_DROPLET_OPTICS( LEV, BLKTA, OWATER_FRAC, SEAICE_FRAC, SNOW_FRAC, LWC ) + CALL GET_ICE_OPTICS( LEV, BLKTA, IWC ) + CALL GET_AGGREGATE_OPTICS( LEV, RWC, SWC, GWC ) !...calculate the acm-cloud photolysis rates for all layers: - NEW_PROFILE = .FALSE. + NEW_PROFILE = .FALSE. CALL NEW_OPTICS ( JDATE, JTIME, NLAYS, & BLKTA, BLKPRS, BLKDENS, BLKZH, BLKZF, & BLKO3, BLKNO2, @@ -966,8 +1148,12 @@ END SUBROUTINE O3TOTCOL !... note that both TAUC_AERO and TAUO3_TOP are the same for clear and !... cloudy regions MSCALE = MAX( 1.0 - ACM_CLOUDS( COL,ROW ), 0.0 ) + DO IWL = 1, NWL + ETOT_SFC_WL ( COL,ROW,IWL ) = MSCALE * ETOT_SFC_WL( COL,ROW,IWL ) + & + ACM_CLOUDS( COL,ROW ) * IRRADIANCE( 1,IWL ) + END DO - IF ( JTIME_CHK ) THEN + IF ( JTIME_CHK .AND. PHOTDIAG ) THEN TRANSMIS_DIRECT( COL,ROW ) = MSCALE * TRANSMIS_DIRECT( COL,ROW ) & + ACM_CLOUDS( COL,ROW ) * TRANS_DIRECT @@ -975,9 +1161,7 @@ END SUBROUTINE O3TOTCOL & + ACM_CLOUDS( COL,ROW ) * TRANSMISSION REFLECT_COEFF( COL,ROW ) = MSCALE * REFLECT_COEFF( COL,ROW ) & + ACM_CLOUDS( COL,ROW ) * REFLECTION - FORALL ( IWL = 1:NWL ) - ETOT_SFC_WL ( COL,ROW,IWL ) = MSCALE * ETOT_SFC_WL( COL,ROW,IWL ) - & + ACM_CLOUDS( COL,ROW ) * IRRADIANCE( 1,IWL ) + DO IWL = 1, NWL TAU_TOT_WL ( COL,ROW,IWL ) = MSCALE * TAU_TOT_WL( COL,ROW,IWL ) & + ACM_CLOUDS( COL,ROW ) * TAU_TOT( 1,IWL ) TAU_CLOUD_WL( COL,ROW,IWL ) = MSCALE * TAU_CLOUD_WL( COL,ROW,IWL ) @@ -988,28 +1172,28 @@ END SUBROUTINE O3TOTCOL ASY_CLOUD_WL( COL,ROW,IWL ) = MSCALE * ASY_CLOUD_WL( COL,ROW,IWL ) & + ACM_CLOUDS( COL,ROW ) * AVE_ASYMM_CLD( IWL ) #endif - END FORALL ! iwl - FORALL ( LEV = 1:NLAYS, IWL = 1:NWL ) - ACTINIC_FX( COL,ROW,LEV,IWL ) = MSCALE * ACTINIC_FX( COL,ROW,LEV,IWL ) - & + ACM_CLOUDS( COL,ROW ) * ACTINIC_FLUX( LEV,IWL ) - END FORALL ! lev and iwl - - DO L = 1, N_DIAG_WVL - IWL = DIAG_WVL( L ) - FORALL ( LEV = 1:NLAYS) - TAU( COL,ROW,LEV,L ) = MSCALE * TAU( COL,ROW,LEV,L ) - & + ACM_CLOUDS( COL,ROW ) * TAU_TOT( LEV,IWL ) - END FORALL + END DO ! iwl + + DO LEV = 1, NLAYS_DIAG + DO L = 1, N_DIAG_WVL + IWL = DIAG_WVL( L ) + TOT_EXT( COL,ROW,LEV,L ) = MSCALE * TOT_EXT( COL,ROW,LEV,L ) + & + ACM_CLOUDS( COL,ROW ) * EXTINCTION( LEV,IWL ) + ACTINIC_FX( COL,ROW,LEV,L ) = MSCALE * ACTINIC_FX( COL,ROW,LEV,L ) + & + ACM_CLOUDS( COL,ROW ) * ACTINIC_FLUX( LEV,IWL ) + END DO END DO END IF ! photdiag !Photolysis rates become a weighted average of the values from resolved and ACM skies FORALL ( L = 1:NLAYS, IPHOT = 1:NPHOTAB ) - RJ( COL,ROW, L, IPHOT ) = 60.0 * ACM_CLOUDS( COL,ROW ) * BLKRJ_ACM( L,IPHOT ) - & + MSCALE * RJ( COL,ROW,L,IPHOT ) - END FORALL ! Loop on layers and PHOT + RJ_SUB( COL,ROW, L, IPHOT ) = 60.0 * BLKRJ_ACM( L,IPHOT ) + RJ( COL,ROW, L, IPHOT ) = ACM_CLOUDS( COL,ROW ) * RJ_SUB( COL,ROW, L, IPHOT ) + & + MSCALE * RJ( COL,ROW,L,IPHOT ) + END FORALL ! Loop on layers and PHOT END IF END IF ! not USE_ACM_CLOUD and ACM_CLOUDS > 0 +!(Wei Li) !------------------------CANOPY PHOTOLYSIS CORRECTION/REDUCTION Section NOAA-ARL------------------------------------------- !Conditions to reduce weighted average of photolysis rates (RJ) due to canopy shading (if user-defined=true); P. C. Campbell !Following is based on work of ECCC in GEM-MACHv2.1: Makar et al. (2017) @@ -1128,15 +1312,16 @@ END SUBROUTINE O3TOTCOL ! RJ( COL,ROW, 1, : ) = ( RJ( COL,ROW, 1, : ) ! & + (RJ( COL,ROW, 1, : )*RJ_CORR( COL,ROW )) )/2.0 END IF !contigous canopy conditions - END IF !canopy shade + END IF !canopy shade + - IF ( JTIME_CHK ) THEN ! compute clear sky reflection and transmission coefficients + IF ( JTIME_CHK .AND. PHOTDIAG ) THEN ! compute clear sky reflection and transmission coefficients IF ( ANY( CLOUDS ) ) THEN IF ( CFRAC_2D( COL,ROW ) .GT. 0.0 ) THEN ! resolved and subgrid clouds exist CLOUDS = .FALSE. NEW_PROFILE = .FALSE. ONLY_SOLVE_RAD = .TRUE. - CALL NEW_OPTICS ( JDATE, JTIME, NLAYS, + CALL NEW_OPTICS ( JDATE, JTIME, NLAYS, & BLKTA, BLKPRS, BLKDENS, BLKZH, BLKZF, & BLKO3, BLKNO2, & ZSFC, COSZEN, SINZEN, RSQD, @@ -1162,6 +1347,10 @@ END SUBROUTINE O3TOTCOL END DO LOOP_ROWS END IF + + ! Store PM Diagnostic AOD and extinction + ELMO_AOD_550 = TAU_AERO_550 + ELMO_EXT_550 = AERO_EXT_550 !...report on whether stratospheric ozone column satisfies climatological minimums IF( N_TROPO_O3_TOGGLE .GT. 0 )THEN @@ -1175,6 +1364,7 @@ END SUBROUTINE O3TOTCOL !...write diagnostic data to output file at the end of every output tstep IF ( JTIME_CHK ) THEN + IF ( PHOTDIAG ) THEN VARNM = 'COSZENS' IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, @@ -1189,26 +1379,32 @@ END SUBROUTINE O3TOTCOL CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF - VARNM = 'TROPO_O3_COLUMN' - IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, TROPO_OC ) ) THEN + VARNM = 'CO_COLUMN' + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, CO_COLUMN ) ) THEN XMSG = 'Error writing variable ' // VARNM CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF - - IMONTH = IMONTH + 1 - IF( IMONTH .GT. 12 )THEN - IMONTH = 1 - TDATE = 2011001 + VARNM = 'SO2_COLUMN' + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, SO2_COLUMN ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + VARNM = 'NO2_COLUMN' + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, NO2_COLUMN ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + VARNM = 'HCHO_COLUMN' + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, HCHO_COLUMN ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF - TDATE = TDATE + DAYS( IMONTH ) -! CALL SEASONAL_STRAT_O3(TDATE, JTIME ) - -! VARNM = 'MIN_FRAC_STRATO3' -! IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, MONTH_STRAT_03_FRAC ) ) THEN -! XMSG = 'Error writing variable ' // VARNM -! CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) -! END IF + VARNM = 'TROPO_O3_COLUMN' + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, TROPO_OC ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF VARNM = 'TRANS_DIFFUSE' @@ -1309,7 +1505,7 @@ END SUBROUTINE O3TOTCOL CALL M3EXIT ( PNAME, ODATE, OTIME, XMSG, XSTAT1 ) END IF - VARNM = 'TAU_AERO_W' // WLTXT( IWL ) + VARNM = 'AOD_W' // WLTXT( IWL ) IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, & OTIME, TAU_AERO_WL( :,:,IWL ) ) ) THEN XMSG = 'Error writing variable ' // VARNM @@ -1362,70 +1558,117 @@ END SUBROUTINE O3TOTCOL END DO ! iwl + VARNM = 'AOD_W550_ANGST' + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, TAU_AERO_550 ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + WRITE( LOGDEV, '( /5X, 3( A, :, 1X ), I8, ":", I6.6 )' ) - & 'RJ Values written to', CTM_RJ_1, + & 'Photolysis Surface Summary written to', CTM_RJ_1, & 'for date and time', ODATE, OTIME DO IPHOT = 1, NPHOTAB + OUTPUT_BUFF( 1:NCOLS,1:NROWS,1:NLAYS_DIAG ) = RJ( 1:NCOLS,1:NROWS,1:NLAYS_DIAG,IPHOT ) IF ( .NOT. WRITE3( CTM_RJ_2, PHOTAB( IPHOT ), ODATE, - & OTIME, RJ( :,:,:,IPHOT ) ) ) THEN + & OTIME, OUTPUT_BUFF ) ) THEN XMSG = 'Could not write ' // CTM_RJ_2 // ' file' CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF END DO + WRITE( LOGDEV, '( /5X, 3( A, :, 1X ), I8, ":", I6.6 )' ) + & 'Photolysis Rates written to', CTM_RJ_2, + & 'for date and time', ODATE, OTIME + VARNM = 'CFRAC_3D' - IF ( .NOT. WRITE3( CTM_RJ_2, VARNM, ODATE, OTIME, CFRAC_3D ) ) THEN - XMSG = 'Could not write ' // TRIM( VARNM ) // ' to ' // CTM_RJ_2 // ' file' + OUTPUT_BUFF( 1:NCOLS,1:NROWS,1:NLAYS_DIAG ) = CFRAC_3D( 1:NCOLS,1:NROWS,1:NLAYS_DIAG ) + IF ( .NOT. WRITE3( CTM_RJ_3, VARNM, ODATE, OTIME, OUTPUT_BUFF ) ) THEN + XMSG = 'Could not write ' // TRIM( VARNM ) // ' to ' // CTM_RJ_3 // ' file' CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF - - DO IWL = 1, NWL + + DO L = 1, N_DIAG_WVL + IWL = DIAG_WVL( L ) + VARNM = 'ACTINIC_FX_W' // WLTXT( IWL ) - IF ( .NOT. WRITE3( CTM_RJ_2, VARNM, ODATE, OTIME, ACTINIC_FX( :,:,:,IWL ) ) ) THEN + IF ( .NOT. WRITE3( CTM_RJ_3, VARNM, ODATE, OTIME, ACTINIC_FX( :,:,:,L ) ) ) THEN XMSG = 'Error writing variable ' // VARNM CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF - END DO - - DO L = 1, N_DIAG_WVL - IWL = DIAG_WVL( L ) VARNM = 'AERO_SSA_W' // WLTXT( IWL ) - IF ( .NOT. WRITE3( CTM_RJ_2, VARNM, ODATE, OTIME, AERO_SSA( :,:,:,L ) ) ) THEN + IF ( .NOT. WRITE3( CTM_RJ_3, VARNM, ODATE, OTIME, AERO_SSA( :,:,:,L ) ) ) THEN XMSG = 'Error writing variable ' // VARNM CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF VARNM = 'AERO_ASYM_W' // WLTXT( IWL ) - IF ( .NOT. WRITE3( CTM_RJ_2, VARNM, ODATE, OTIME, AERO_ASYM( :,:,:,L ) ) ) THEN + IF ( .NOT. WRITE3( CTM_RJ_3, VARNM, ODATE, OTIME, AERO_ASYM( :,:,:,L ) ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + VARNM = 'EXT_AERO_W' // WLTXT( IWL ) + IF ( .NOT. WRITE3( CTM_RJ_3, VARNM, ODATE, OTIME, AERO_EXT( :,:,:,L ) ) ) THEN XMSG = 'Error writing variable ' // VARNM CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF - VARNM = 'TAU_AERO_W' // WLTXT( IWL ) - IF ( .NOT. WRITE3( CTM_RJ_2, VARNM, ODATE, OTIME, TAU_AERO( :,:,:,L ) ) ) THEN + VARNM = 'EXT_W' // WLTXT( IWL ) + IF ( .NOT. WRITE3( CTM_RJ_3, VARNM, ODATE, OTIME, TOT_EXT( :,:,:,L ) ) ) THEN XMSG = 'Error writing variable ' // VARNM CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF - VARNM = 'TAU_W' // WLTXT( IWL ) - IF ( .NOT. WRITE3( CTM_RJ_2, VARNM, ODATE, OTIME, TAU( :,:,:,L ) ) ) THEN + VARNM = 'GAS_EXT_W' // WLTXT( IWL ) + IF ( .NOT. WRITE3( CTM_RJ_3, VARNM, ODATE, OTIME, GAS_EXT( :,:,:,L ) ) ) THEN XMSG = 'Error writing variable ' // VARNM CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF END DO + VARNM = 'EXT_AERO_W550' + IF ( .NOT. WRITE3( CTM_RJ_3, VARNM, ODATE, OTIME, AERO_EXT_550( :,:,: ) ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + WRITE( LOGDEV, '( /5X, 3( A, :, 1X ), I8, ":", I6.6 )' ) - & 'RJ and Optical Data written to', CTM_RJ_2, + & 'Radiative and Optical Data written to', CTM_RJ_3, & 'for date and time', ODATE, OTIME - END IF ! if JTIME_CHK + END IF ! PHOTDIAG + END IF ! if JTIME_CHK + TAU_AERO_550 = 0.0 1003 FORMAT( 8X, 'Processor ',I4.4,' is in darkness at ', I8.7, ':', I6.6, & 1X, 'GMT - no photolysis') 9500 FORMAT(3(/ A), I7, 1X, I6.6, 1X, / "Total Number: ", I9, ";Mean Value: ", F9.6, & "; Max Value: ",F9.6 /) - RETURN +95101 FORMAT('Diagnostic Output will have zero values for the column density.', + & / 'The lack of information does not affect model predictions.' ) + + CONTAINS + SUBROUTINE COLUMN_GAS( IGAS, UNIT_FACTOR, COLUMN_DENSITY ) +! Purpose: calculates column density in unit based on the value of UNIT_FACTOR + IMPLICIT NONE +! argument: + INTEGER, INTENT( IN ) :: IGAS ! species index in CGRID + REAL, INTENT( OUT ) :: COLUMN_DENSITY( :,: ) ! units determined by inputs + REAL, INTENT( IN ) :: UNIT_FACTOR ! converts from 10E6*molecules*cm-2 +! local parameter: +! REAL, PARAMETER :: UNIT_FACTOR = 1.0E-6 * CONC_TO_DU ! unit conversion factor + + IF( IGAS .LE. 0 )RETURN ! assumes column_density set to zero at allocation + + COLUMN_DENSITY( COL,ROW ) = 0.0 + DO LEV = 1, NLAYS + COLUMN_DENSITY( COL,ROW ) = ( UNIT_FACTOR * BLKDENS( LEV ) ) + & * CGRID( COL,ROW,LEV,IGAS ) * BLKDZ ( LEV ) + & + COLUMN_DENSITY( COL,ROW ) + END DO + + END SUBROUTINE COLUMN_GAS END SUBROUTINE PHOT diff --git a/src/shr/aqm_methods.F90 b/src/shr/aqm_methods.F90 index a3c87877..7412e7de 100644 --- a/src/shr/aqm_methods.F90 +++ b/src/shr/aqm_methods.F90 @@ -86,6 +86,7 @@ LOGICAL FUNCTION DESC3( FNAME ) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: FNAME + CHARACTER(LEN=len(FNAME)) :: FNAME_TRIM !(Wei Li) INCLUDE SUBST_FILES_ID @@ -106,10 +107,9 @@ LOGICAL FUNCTION DESC3( FNAME ) STIME3D = 0 TSTEP3D = 0 - IF ( (TRIM(FNAME) .EQ. TRIM(INIT_GASC_1)) .OR. & - (TRIM(FNAME) .EQ. TRIM(INIT_AERO_1)) .OR. & - (TRIM(FNAME) .EQ. TRIM(INIT_NONR_1)) .OR. & - (TRIM(FNAME) .EQ. TRIM(INIT_TRAC_1)) ) THEN + FNAME_TRIM = TRIM(FNAME_TRIM) + !!Replace INIT_GASC,AERO,NONR,TRAC to INIT_CONC_1 (Wei Li) + IF ( (TRIM(FNAME) .EQ. TRIM(INIT_CONC_1)) ) THEN ! -- Input initial background values for the following species NVARS3D = 3 @@ -126,7 +126,9 @@ LOGICAL FUNCTION DESC3( FNAME ) call aqm_emis_desc("biogenic", NLAYS3D, NVARS3D, VNAME3D, UNITS3D) - ELSE IF ( TRIM( FNAME ) .EQ. TRIM( EMIS_1 ) ) THEN +! EMIS_1 is not used anymore. Change to other env variables. (Wei Li) + ELSE IF ( ( (FNAME_TRIM(1:8) .EQ. 'GR_EMIS_') .AND. (len(FNAME_TRIM) .EQ. 11 )) .OR. & + ( (FNAME_TRIM(1:9) .EQ. 'STK_EMIS_').AND. (len(FNAME_TRIM) .EQ. 12 )) ) THEN NLAYS3D = 0 @@ -364,14 +366,14 @@ logical function envyn(name, description, defaultval, status) envyn = .false. em => aqm_emis_get("biogenic") if (associated(em)) envyn = (trim(em % period) == "summer") - case ('CTM_AOD') - envyn = config % ctm_aod + ! case ('CTM_AOD') + ! envyn = config % ctm_aod case ('CTM_BIOGEMIS') envyn = aqm_emis_ispresent("biogenic") case ('CTM_DEPVFILE') envyn = config % ctm_depvfile - case ('CTM_PMDIAG') - envyn = config % ctm_pmdiag + ! case ('CTM_PMDIAG') + ! envyn = config % ctm_pmdiag case ('CTM_PHOTODIAG') envyn = config % ctm_photodiag case ('CTM_PT3DEMIS') @@ -619,6 +621,7 @@ logical function interpx( fname, vname, pname, & implicit none character(len=*), intent(in) :: fname, vname, pname + CHARACTER(LEN=len(fname)) :: FNAME_TRIM !(Wei Li) integer, intent(in) :: col0, col1, row0, row1, lay0, lay1 integer, intent(in) :: jdate, jtime real, intent(out) :: buffer(*) @@ -643,6 +646,7 @@ logical function interpx( fname, vname, pname, & ! -- begin interpx = .false. + FNAME_TRIM = TRIM(fname) !(Wei Li) lbuf = (col1-col0+1) * (row1-row0+1) * (lay1-lay0+1) buffer(1:lbuf) = 0. @@ -857,8 +861,8 @@ logical function interpx( fname, vname, pname, & return end select - else if (trim(fname) == trim(EMIS_1)) then - +! EMIS_1 is not used anymore. Change to other env variables. (Wei Li) + else if ( ( (FNAME_TRIM(1:8) .EQ. 'GR_EMIS_') .AND. (len(FNAME_TRIM) .EQ. 11 )) ) then ! -- read in emissions call aqm_emis_read("anthropogenic", vname, buffer, rc=localrc) if (aqm_rc_test((localrc /= 0), & @@ -1129,8 +1133,8 @@ LOGICAL FUNCTION XTRACT3 ( FNAME, VNAME, & end do END IF - - ELSE IF ( TRIM(FNAME) .EQ. TRIM(INIT_GASC_1) ) THEN + !!Replace INIT_GASC,AERO,NONR,TRAC to INIT_CONC_1 (Wei Li) + ELSE IF ( TRIM(FNAME) .EQ. TRIM(INIT_CONC_1) ) THEN ! -- initialize gas-phase species (ppmV) SELECT CASE (TRIM(VNAME)) @@ -1227,25 +1231,25 @@ LOGICAL FUNCTION WRITE3_REAL2D( FNAME, VNAME, JDATE, JTIME, BUFFER ) type(aqm_state_type), pointer :: stateOut WRITE3_REAL2D = .TRUE. - - IF ( TRIM( FNAME ) .EQ. TRIM( CTM_AOD_1 ) ) THEN - - WRITE3_REAL2D = .FALSE. - - IF ( TRIM( VNAME ) .EQ. TRIM( ALLVAR3 ) ) THEN - - nullify(stateOut) - call aqm_model_get(stateOut=stateOut, rc=localrc) - if (aqm_rc_check(localrc, msg="Failure to retrieve model output state", & - file=__FILE__, line=__LINE__)) return - - stateOut % aod = BUFFER - - END IF - - WRITE3_REAL2D = .TRUE. - - END IF +!CTM_AOD_1 seems to be removed. (Wei Li) +! IF ( TRIM( FNAME ) .EQ. TRIM( CTM_AOD_1 ) ) THEN +! +! WRITE3_REAL2D = .FALSE. +! +! IF ( TRIM( VNAME ) .EQ. TRIM( ALLVAR3 ) ) THEN +! +! nullify(stateOut) +! call aqm_model_get(stateOut=stateOut, rc=localrc) +! if (aqm_rc_check(localrc, msg="Failure to retrieve model output state", & +! file=__FILE__, line=__LINE__)) return +! +! stateOut % aod = BUFFER +! +! END IF +! +! WRITE3_REAL2D = .TRUE. +! +! END IF END FUNCTION WRITE3_REAL2D @@ -1273,29 +1277,29 @@ LOGICAL FUNCTION WRITE3_REAL4D( FNAME, VNAME, JDATE, JTIME, BUFFER ) integer, parameter :: p_pm25at = 23 WRITE3_REAL4D = .TRUE. - - IF ( TRIM( FNAME ) .EQ. TRIM( CTM_PMDIAG_1 ) ) THEN - - WRITE3_REAL4D = .FALSE. - - IF ( TRIM( VNAME ) .EQ. TRIM( ALLVAR3 ) ) THEN - - nullify(config) - nullify(stateOut) - call aqm_model_get(config=config, stateOut=stateOut, rc=localrc) - if (aqm_rc_check(localrc, msg="Failure to retrieve model output state", & - file=__FILE__, line=__LINE__)) return - - do s = 0, config % species % ndiag - 2 - stateOut % tr(:,:,:,config % species % p_diag_beg + s) = & - buffer(:,:,:,p_pm25at + s) - end do - - END IF - - WRITE3_REAL4D = .TRUE. - - END IF +!CTM_PMDIAG_1 seems to be removed. (Wei Li) +! IF ( TRIM( FNAME ) .EQ. TRIM( CTM_PMDIAG_1 ) ) THEN +! +! WRITE3_REAL4D = .FALSE. +! +! IF ( TRIM( VNAME ) .EQ. TRIM( ALLVAR3 ) ) THEN +! +! nullify(config) +! nullify(stateOut) +! call aqm_model_get(config=config, stateOut=stateOut, rc=localrc) +! if (aqm_rc_check(localrc, msg="Failure to retrieve model output state", & +! file=__FILE__, line=__LINE__)) return +! +! do s = 0, config % species % ndiag - 2 +! stateOut % tr(:,:,:,config % species % p_diag_beg + s) = & +! buffer(:,:,:,p_pm25at + s) +! end do +! +! END IF +! +! WRITE3_REAL4D = .TRUE. +! +! END IF END FUNCTION WRITE3_REAL4D