diff --git a/.gitmodules b/.gitmodules index b13c486..6031757 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,4 +1,4 @@ [submodule "src/model/CMAQ"] path = src/model/CMAQ url = https://github.com/USEPA/CMAQ - branch = 5.2.1 + branch = 5.4+ diff --git a/CMakeLists.txt b/CMakeLists.txt index fc6c8f4..3613463 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -20,7 +20,8 @@ if(CMAKE_Fortran_COMPILER_ID MATCHES "GNU") set(CMAKE_Fortran_FLAGS "-ffree-line-length-none -ffixed-line-length-none") elseif(CMAKE_Fortran_COMPILER_ID MATCHES "Intel") set(CMAKE_Fortran_FLAGS "-extend-source 132") - set(CMAKE_Fortran_FLAGS_DEBUG "-O0 -g -check bounds -check uninit -fpe0 -fno-alias -ftrapuv -traceback") + set(CMAKE_Fortran_FLAGS_DEBUG "-O0 -g -check all -check noarg_temp_created -fpe0 -fno-alias -ftrapuv -traceback") + # set(CMAKE_Fortran_FLAGS_DEBUG "-O0 -g -check bounds -check uninit -fpe0 -fno-alias -ftrapuv -traceback") else() message(WARNING "Fortran compiler with ID ${CMAKE_Fortran_COMPILER_ID} will be used with CMake default options") endif() @@ -93,6 +94,7 @@ target_compile_definitions(CCTM PUBLIC SUBST_FILES_ID="FILES_CTM.EXT" SUBST_PE_COMM="PE_COMM.EXT" SUBST_COMM=NOOP_COMM SUBST_BARRIER=NOOP_BARRIER + SUBST_HI_LO_BND_PE=NOOP_HI_LO_BND_PE SUBST_SUBGRID_INDEX=NOOP_SUBGRID_INDEX AQCHEM=DUMMY_AQCHEM CONVCLD_ACM=DUMMY_CONVCLD_ACM @@ -105,7 +107,8 @@ target_compile_definitions(CCTM PUBLIC SUBST_FILES_ID="FILES_CTM.EXT" WR_INIT=DUMMY_WR_INIT verbose_aero verbose_gas - mpas + verbose_cio + # mpas _AQM_) # AQM diff --git a/README b/README index 8b13789..d1a50ac 100644 --- a/README +++ b/README @@ -1 +1 @@ - +Modified branch to account for in-canopy effects on composition/weather diff --git a/aqm_files.cmake b/aqm_files.cmake index 527cf3d..36bae14 100644 --- a/aqm_files.cmake +++ b/aqm_files.cmake @@ -36,6 +36,7 @@ list(APPEND aqm_aqmio_files list(APPEND aqm_ioapi_files src/io/ioapi/FDESC3.EXT src/io/ioapi/PARMS3.EXT + src/io/ioapi/IODECL3.EXT src/io/ioapi/crlf.F src/io/ioapi/currec.f src/io/ioapi/currstep.f @@ -59,55 +60,56 @@ list(APPEND aqm_ioapi_files src/io/ioapi/upcase.f src/io/ioapi/wkday.F src/io/ioapi/yr2day.F + src/io/ioapi/daymon.F src/io/ioapi/m3exit.F90 src/io/ioapi/m3mesg.F90 src/io/ioapi/m3msg2.F90 src/io/ioapi/m3warn.F90 + src/io/ioapi/m3err.F src/io/ioapi/m3utilio.F90 ) 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(MEGAN "${CCTM_ROOT}/biog/megan3") 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/ros3") 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(CIO "${CCTM_ROOT}/cio") 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}/AERO_EMIS.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 @@ -115,6 +117,13 @@ list(APPEND aqm_CCTM_files ${BIOG}/parsline.f ${BIOG}/tmpbeis.F ${BIOG}/wrdaymsg.f + ${MEGAN}/MEGAN_DEFN.F + ${MEGAN}/megan_gspro.F + ${MEGAN}/megan_hrno_mod.F + ${MEGAN}/megan_fx_mod.f90 + ${MEGAN}/BDSNP_MOD.F + ${MEGAN}/MAP_CV2CB6_AE7.EXT + ${MEGAN}/SPC_CB6_AE7.EXT ${CLOUD}/hlconst.F ${CLOUD}/cldproc_acm.F ${CLOUD}/getalpha.F @@ -131,42 +140,43 @@ 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 - ${GAS}/hrdata_mod.F - ${GAS}/hrdriver.F - ${GAS}/hrg1.F - ${GAS}/hrg2.F - ${GAS}/hrg3.F - ${GAS}/hrg4.F - ${GAS}/hrinit.F - ${GAS}/hrprodloss.F - ${GAS}/hrrates.F - ${GAS}/hrsolver.F - ${GAS}/init_degrade.F + ${EMIS}/biog_emis_param_module.F + ${EMIS}/CMAQ_Control_DESID.nml + ${EMIS}/desid_param_module.F + ${EMIS}/desid_util.F + ${EMIS}/desid_vars.F + ${EMIS}/desid_module.F + ${EMIS}/lus_data_module.F + ${EMIS}/stack_group_data_module.F + # ${EMIS}/PT3D_DEFN.F + ${EMIS}/PTMET.F + ${GAS}/../../reactive_tracers/DEGRADE_PARAMETERS.F + ${GAS}/../../reactive_tracers/DEGRADE_ROUTINES.F + ${GAS}/rbdata_mod.F + #${GAS}/rbdriver.F + ${GAS}/rbdecomp.F + ${GAS}/rbfeval.F + ${GAS}/rbinit.F + ${GAS}/rbjacob.F + ${GAS}/rbsolve.F + ${GAS}/rbsolver.F + ${GAS}/rbsparse.F + ${GAS}/../../reactive_tracers/DEGRADE_SETUP_TOX.F ${GRID}/GRID_CONF.F ${GRID}/HGRD_DEFN.F ${GRID}/VGRD_DEFN.F @@ -181,19 +191,23 @@ 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.F ${PHOT}/PHOT_MET_DATA.F ${PHOT}/PHOT_MOD.F ${PHOT}/PHOTOLYSIS_ALBEDO.F ${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 @@ -201,9 +215,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 @@ -215,32 +231,45 @@ 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}/RUNTIME_VARS.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 + #${CIO}/centralized_io_module.F ${localCCTM}/o3totcol.f - ${localCCTM}/vdiffacmx.F - ${localCCTM}/PTMAP.F - ${localCCTM}/PT3D_DATA_MOD.F + #${localCCTM}/AERO_EMIS.F + #${localCCTM}/PTMAP.F + #${localCCTM}/PT3D_DATA_MOD.F + #rbdriver.F has a typo in CMAQ.Put it back to {GAS} if they solve it in the future + ${localCCTM}/rbdriver.F ${localCCTM}/PT3D_DEFN.F ${localCCTM}/PT3D_FIRE_DEFN.F ${localCCTM}/PT3D_STKS_DEFN.F + ${localCCTM}/vdiffacmx.F ${localCCTM}/ASX_DATA_MOD.F ${localCCTM}/DUST_EMIS.F ${localCCTM}/AERO_PHOTDATA.F + ${localCCTM}/phot.F + ${localCCTM}/RUNTIME_VARS.F + ${localCCTM}/get_env_mod.f90 + ${localCCTM}/centralized_io_module.F + ${localCCTM}/centralized_io_util_module.F ) diff --git a/examples/aqm.rc b/examples/aqm.rc index 13246de..70240c0 100644 --- a/examples/aqm.rc +++ b/examples/aqm.rc @@ -34,6 +34,31 @@ omi_data: /scratch1/NCEPDEV/nems/Raffaele.Montuoro/dev/aqm/epa/data/omi_cmaq_ # - set to true for cold start init_concentrations: true +# +# Inline Canopy Effects +# +canopy_yn: true + +canopy_type: canopy + +canopy_format: netcdf + +canopy_file: /scratch2/NAGAPE/arl/Patrick.C.Campbell/canopy_geofiles/gfs.t12z.geo.08.canopy_regrid.nc + +canopy_frequency: static + +canopy_species:: + FCH 1.00000 FCH m + FRT 1.00000 FRT 1 + CLU 1.00000 CLU 1 + POPU 1.00000 POPU 10000_people/10km2 + LAIE 1.00000 LAIE 1 + C1R 1.00000 C1R 1 + C2R 1.00000 C2R 1 + C3R 1.00000 C3R 1 + C4R 1.00000 C4R 1 +:: + # # Run options: # @@ -83,7 +108,7 @@ ctm_stdout: all emission_sources: myemis # -# Emission type: anthropogenic, biogenic, gbbepx, fengsha +# Emission type: anthropogenic, biogenic, gbbepx, fengsha, canopy # myemis_type: anthropogenic diff --git a/src/aqm_cap.F90 b/src/aqm_cap.F90 index 15a3231..94cc8a6 100644 --- a/src/aqm_cap.F90 +++ b/src/aqm_cap.F90 @@ -14,6 +14,7 @@ module AQM ! -- import fields integer, parameter :: importFieldCount = 36 +! integer, parameter :: importFieldCount = 45 !with canopy character(len=*), dimension(importFieldCount), parameter :: & importFieldNames = (/ & "canopy_moisture_storage ", & @@ -52,6 +53,15 @@ module AQM "surface_cell_area ", & "surface_snow_area_fraction ", & "temperature_of_soil_layer " & +! "forest_canopy_height ", & +! "forest_fraction ", & +! "clumping_index ", & +! "population_density ", & +! "leaf_area_index_eccc ", & +! "cum_lai_frac1_eccc ", & +! "cum_lai_frac2_eccc ", & +! "cum_lai_frac3_eccc ", & +! "cum_lai_frac4_eccc ", & /) ! -- export fields integer, parameter :: exportFieldCount = 2 diff --git a/src/aqm_comp_mod.F90 b/src/aqm_comp_mod.F90 index c255316..62f4f8d 100644 --- a/src/aqm_comp_mod.F90 +++ b/src/aqm_comp_mod.F90 @@ -12,6 +12,10 @@ module aqm_comp_mod use aqm_prod_mod use aqm_internal_mod use cmaq_model_mod + USE CENTRALIZED_IO_MODULE !(CMAQ) + USE ELMO_PROC !(CMAQ) + USE RUNTIME_VARS, ONLY: STDATE, STTIME !(CMAQ) + implicit none @@ -147,6 +151,7 @@ subroutine aqm_comp_advance(model, rc) type(ESMF_Time) :: currTime type(ESMF_TimeInterval) :: timeStep type(aqm_config_type), pointer :: config => null() + logical, save :: first_step = .true. !(add new) ! -- begin rc = ESMF_SUCCESS @@ -176,8 +181,11 @@ subroutine aqm_comp_advance(model, rc) return ! bail out ! -- set model internal timestep vector (HHMMSS) - tstep( 1 ) = config % ctm_tstep ! TSTEP(1) = local output step - tstep( 2 ) = tstep( 1 ) ! TSTEP(2) = sciproc sync. step (chem) + !tstep( 1 ) = config % ctm_tstep ! TSTEP(1) = local output step + !tstep( 2 ) = tstep( 1 ) ! TSTEP(2) = sciproc sync. step (chem) + !test different tstep(1) and tstep(2) + tstep( 1 ) = 1 * 10000 ! TSTEP(1) = local output step + tstep( 2 ) = config % ctm_tstep ! TSTEP(2) = sciproc sync. step (chem) tstep( 3 ) = tstep( 2 ) ! TSTEP(3) = twoway model time step call ESMF_TimeGet(currTime, yy=yy, mm=mm, dd=dd, h=h, m=m, s=s, & @@ -198,6 +206,15 @@ subroutine aqm_comp_advance(model, rc) file=__FILE__)) & return ! bail out + !Initiliaze IO Arrays and Open Files (CMAQ) + if (first_step) then + first_step = .false. + !update STDATE(default is 1995192) and STTIME here for restart + STDATE = jdate + STTIME = jtime + call centralized_io_init + endif + ! -- advance CMAQ call cmaq_model_advance(jdate, jtime, tstep, rc=localrc) if (aqm_rc_check(localrc, file=__FILE__, line=__LINE__)) then @@ -605,6 +622,61 @@ subroutine aqm_comp_import(state, fieldNames, rc) line=__LINE__, & file=__FILE__)) & return ! bail +!canopy variables +! case ("forest_canopy_height") +! call ESMF_FieldGet(field, localDe=localDe, farrayPtr=stateIn % stemp, rc=rc) +! if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & +! line=__LINE__, & +! file=__FILE__)) & +! return ! bail +! case ("forest_fraction") +! call ESMF_FieldGet(field, localDe=localDe, farrayPtr=stateIn % stemp, rc=rc) +! if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & +! line=__LINE__, & +! file=__FILE__)) & +! return ! bail +! case ("clumping_index") +! call ESMF_FieldGet(field, localDe=localDe, farrayPtr=stateIn % stemp, rc=rc) +! if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & +! line=__LINE__, & +! file=__FILE__)) & +! return ! bail +! case ("population_density") +! call ESMF_FieldGet(field, localDe=localDe, farrayPtr=stateIn % stemp, rc=rc) +! if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & +! line=__LINE__, & +! file=__FILE__)) & +! return ! bail +! case ("leaf_area_index_eccc") +! call ESMF_FieldGet(field, localDe=localDe, farrayPtr=stateIn % stemp, rc=rc) +! if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & +! line=__LINE__, & +! file=__FILE__)) & +! return ! bail +! case ("cum_lai_frac1_eccc") +! call ESMF_FieldGet(field, localDe=localDe, farrayPtr=stateIn % stemp, rc=rc) +! if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & +! line=__LINE__, & +! file=__FILE__)) & +! return ! bail +! case ("cum_lai_frac2_eccc") +! call ESMF_FieldGet(field, localDe=localDe, farrayPtr=stateIn % stemp, rc=rc) +! if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & +! line=__LINE__, & +! file=__FILE__)) & +! return ! bail +! case ("cum_lai_frac3_eccc") +! call ESMF_FieldGet(field, localDe=localDe, farrayPtr=stateIn % stemp, rc=rc) +! if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & +! line=__LINE__, & +! file=__FILE__)) & +! return ! bail +! case ("cum_lai_frac4_eccc") +! call ESMF_FieldGet(field, localDe=localDe, farrayPtr=stateIn % stemp, rc=rc) +! if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & +! line=__LINE__, & +! file=__FILE__)) & +! return ! bail case default ! -- unused field end select diff --git a/src/drv/cmaq_mod.F90 b/src/drv/cmaq_mod.F90 index ac47610..5b95dda 100644 --- a/src/drv/cmaq_mod.F90 +++ b/src/drv/cmaq_mod.F90 @@ -14,16 +14,19 @@ module cmaq_mod use cgrid_spcs use AERO_DATA, only : aerolist, n_aerolist, & - aerospc_mw, n_emis_pm, & - map_pmemis, pmem_map, & - pmem_map_name, pmem_units + aerospc_mw use M3UTILIO, only : M3MESG use UTILIO_DEFN, only : INDEX1, INIT3, MXVARS3 + use DESID_VARS !(CMAQ) + USE CENTRALIZED_IO_MODULE !(CMAQ) + USE ELMO_PROC, ONLY : ELMO_DRIVER, WRITE_ELMO, MAP_ELMO !(CMAQ) implicit none integer :: cmaq_logdev + integer, save :: my_ncols + integer, save :: my_nrows ! -- pointer to CMAQ concentration array real, pointer :: CGRID(:,:,:,:) => null() @@ -65,6 +68,7 @@ subroutine cmaq_species_read(nspecies, rc) ! -- read from namelist CGRID gas chem, aerosol, non-reactive, ! -- and tracer species definitions ! -- This is done only on DE 0 and shared with other DEs on this PET + nspecies = 0 if (aqm_rc_test(.not.cgrid_spcs_init(), & msg="Error in CGRID_SPCS:CGRID_SPCS_INIT", & @@ -75,7 +79,10 @@ subroutine cmaq_species_read(nspecies, rc) file=__FILE__, line=__LINE__, rc=rc)) return nspecies = n_gc_trns + n_ae_trns + n_nr_trns - + + !add log + write(-1,* ) ' GC/AE/NR Species Number: ', n_gc_trns,'/',n_ae_trns,'/',n_nr_trns + end subroutine cmaq_species_read subroutine cmaq_init(rc) @@ -98,6 +105,10 @@ subroutine cmaq_init(rc) msg="Failure defining horizontal domain", & file=__FILE__, line=__LINE__, rc=rc)) return + !define 'my_ncols' here + my_ncols = NCOLS + my_nrows = NROWS + ! -- set I/O flag IO_PE_INCLUSIVE = ( MYPE .EQ. 0 ) @@ -107,7 +118,8 @@ subroutine cmaq_init(rc) ! -- Set up horizontal domain and calculate processor-to-subdomain maps for ! -- process analysis, if required IF ( LIPR .OR. LIRR ) THEN - IF (aqm_rc_test( .NOT. PAGRD_INIT( NPROCS, MYPE ), & +! IF (aqm_rc_test( .NOT. PAGRD_INIT( NPROCS, MYPE ), & + IF (aqm_rc_test( .NOT. PAGRD_INIT( MYPE ), & msg="Failure defining PA domain configuration", & FILE=__FILE__, LINE=__LINE__, rc=rc)) RETURN END IF @@ -119,6 +131,12 @@ subroutine cmaq_init(rc) CGRID => PCGRID( 1:MY_NCOLS,1:MY_NROWS,:,: ) ! required for PinG + !Initiliaze IO Arrays and Open Files (CMAQ) + call desid_read_namelist() + call desid_init_regions() + !Initialize ELMO Arrays and Maps + call map_elmo + end subroutine cmaq_init subroutine cmaq_advance(jdate, jtime, tstep, run_aero, run_rescld, rc) @@ -136,6 +154,12 @@ SUBROUTINE VDIFF ( CGRID, JDATE, JTIME, TSTEP ) INTEGER :: JDATE, JTIME INTEGER :: TSTEP( 3 ) END SUBROUTINE VDIFF + !add PHOT + SUBROUTINE PHOT ( CGRID, JDATE, JTIME, TSTEP ) + REAL, POINTER :: CGRID( :,:,:,: ) + INTEGER, INTENT( IN ) :: JDATE, JTIME + INTEGER, INTENT( IN ) :: TSTEP( : ) + END SUBROUTINE PHOT SUBROUTINE CLDPROC ( CGRID, JDATE, JTIME, TSTEP ) REAL, POINTER :: CGRID( :,:,:,: ) INTEGER :: JDATE, JTIME @@ -160,6 +184,8 @@ END SUBROUTINE AERO CALL VDIFF ( CGRID, JDATE, JTIME, TSTEP ) if (run_rescld) then + !add PHOT before CLDPROC + CALL PHOT ( CGRID, JDATE, JTIME, TSTEP ) CALL CLDPROC ( CGRID, JDATE, JTIME, TSTEP ) end if @@ -169,6 +195,11 @@ END SUBROUTINE AERO CALL AERO ( CGRID, JDATE, JTIME, TSTEP ) end if + !add ELMO here + !ALways let INIT_TIME=.TRUE. here to output each small time step + CALL ELMO_DRIVER( CGRID, JDATE, JTIME, TSTEP, INIT_TIME=.TRUE.) + CALL WRITE_ELMO( JDATE, JTIME, TSTEP, INIT_TIME=.TRUE.) + end subroutine cmaq_advance subroutine cmaq_import(tracers, prl, phii, temp, start_index, rc) @@ -438,6 +469,9 @@ subroutine cmaq_emis_init(rc) integer :: localrc, stat integer :: item integer :: ltable, n, spc + integer :: IRULE + integer, save :: N_RULE + Character( 16 ) :: pmem_units !units for PM emissions for all species integer, allocatable :: umap(:) real(AQM_KIND_R4) :: ucnv type(aqm_internal_emis_type), pointer :: em @@ -476,30 +510,44 @@ subroutine cmaq_emis_init(rc) ! -- add internal units to emissions reference table ltable = size(em % table, dim=1) - ! -- define mapping of CMAQ aerosol and related emission species - call map_pmemis() ! -- set destination units for PM emissions for all species pmem_units = "G/S" ! -- set internal units for all species - ! -- (a) gas species - do n = 1, n_gc_emis - spc = index1( gc_emis( n ), ltable, em % table(:,1) ) - if (spc > 0) em % table(spc,2) = "MOL/S" - end do - ! -- (b) non reactive - do n = 1, n_nr_emis - spc = index1( nr_emis( n ), ltable, em % table(:,1) ) - if (spc > 0) em % table(spc,2) = "MOL/S" + ! --- use DESID_EMVAR_TABLE from DESID_VARS.F + ! Find Total Number of Rules + N_RULE = 0 + DO IRULE = 1,SIZE( DESID_RULES_NML ) + IF( DESID_RULES_NML( IRULE )%SPEC .EQ. '' ) EXIT + N_RULE = IRULE + END DO + do n = 1, DESID_N_EMVAR_TABLE + spc = index1(DESID_EMVAR_TABLE( n )%NAME, ltable, em % table(:,1) ) + if (spc > 0) then + do IRULE = 1,N_RULE + CALL UPCASE( DESID_RULES_NML( IRULE )%EMVAR ) + if (DESID_EMVAR_TABLE( n )%NAME .EQ. DESID_RULES_NML( IRULE)%EMVAR ) then + if (DESID_RULES_NML( IRULE )%BASIS .EQ. 'UNIT') then + CALL UPCASE( DESID_RULES_NML( IRULE )%PHASE ) + if (DESID_RULES_NML( IRULE )%PHASE .EQ. 'GAS') then + em % table(spc,2) = "MOL/S" + else + em % table(spc,2) = pmem_units + endif + else if (DESID_RULES_NML( IRULE )%BASIS .EQ. 'MASS') then + em % table(spc,2) = pmem_units + else !BASIS can be set 'MOLE', but not in the default namelist + em % table(spc,2) = "MOL/S" + end if + endif + end do + + endif end do + spc = index1( "NH3_FERT", ltable, em % table(:,1) ) - if (spc > 0) em % table(spc,2) = "MOL/S" - ! -- (c) aerosols - do n = 1, n_emis_pm - spc = index1( pmem_map_name( n ), ltable, em % table(:,1) ) - if (spc > 0) em % table(spc,2) = pmem_units - end do + if (spc > 0) em % table(spc,2) = "MOL/S" ! -- perform unit conversion for input species, if needed ! -- (a) map input species to internal species @@ -520,44 +568,13 @@ subroutine cmaq_emis_init(rc) end do ! -- (b) perform unit conversion for input species - ! --- 1. gas species - do n = 1, size(em % species) - if (umap(n) > 0) then - spc = index1( em % species(n), n_gc_emis, gc_emis ) - if (spc > 0) then - ucnv = aqm_units_conv( em % units(n), em % table(umap(n),2), gc_molwt(gc_emis_map(spc)), em % dens_flag(n) ) - if (aqm_rc_test(ucnv == 0._AQM_KIND_R4, & - msg=trim(em % species(n))//": invalid input units ("//trim(em % units(n))//")", & - file=__FILE__, line=__LINE__, rc=rc)) return - em % factors(n) = ucnv * em % factors(n) - umap(n) = 0 - end if - end if - end do - ! --- 2. non reactive - do n = 1, size(em % species) - if (umap(n) > 0) then - if ( trim(em % species(n)) == "NH3_FERT" ) then - spc = index1( "NH3", n_nr_emis, nr_emis ) - else - spc = index1( em % species(n), n_nr_emis, nr_emis ) - end if - if (spc > 0) then - ucnv = aqm_units_conv( em % units(n), em % table(umap(n),2), nr_molwt(nr_emis_map(spc)), em % dens_flag(n) ) - if (aqm_rc_test(ucnv == 0._AQM_KIND_R4, & - msg=trim(em % species(n))//": invalid input units ("//trim(em % units(n))//")", & - file=__FILE__, line=__LINE__, rc=rc)) return - em % factors(n) = ucnv * em % factors(n) - umap(n) = 0 - end if - end if - end do - ! --- 3. aerosols - do n = 1, size(em % species) + ! --- use DESID_EMVAR_TABLE from DESID_VARS.F; + do n = 1, size(em % species) if (umap(n) > 0) then - spc = index1( em % species(n), n_emis_pm, pmem_map_name ) + spc = index1(em % species(n), DESID_N_EMVAR_TABLE, DESID_EMVAR_TABLE( : )%NAME ) if (spc > 0) then - ucnv = aqm_units_conv( em % units(n), em % table(umap(n),2), aerospc_mw(pmem_map(spc)), em % dens_flag(n) ) + ucnv = aqm_units_conv( em % units(n), em % table(umap(n),2), DESID_EMVAR_TABLE( spc )%MW, em % dens_flag(n) ) + if (aqm_rc_test(ucnv == 0._AQM_KIND_R4, & msg=trim(em % species(n))//": invalid input units ("//trim(em % units(n))//")", & file=__FILE__, line=__LINE__, rc=rc)) return @@ -567,6 +584,7 @@ subroutine cmaq_emis_init(rc) end if end do + ! -- (c) free up memory deallocate(umap, stat=stat) if (aqm_rc_test(stat /= 0, & @@ -824,20 +842,20 @@ subroutine cmaq_prod_pm25( pm25, cgrid, frac, idx, nlays_in) integer :: i, ibeg, iend, imod, mode, spc integer :: c, r, l - ! -- local parameters + ! -- local parameters (updated species for CB6r5_aero7) character(len=*), parameter :: pm25_species(*) = & - (/ "ASO4I ", "ANO3I ", "ANH4I ", "ANAI ", "ACLI ", "AECI ", "AOTHRI ", & ! I-mode (Atken) - "ALVPO1I", "ASVPO1I", "ASVPO2I", "ALVOO1I", "ALVOO2I", "ASVOO1I", "ASVOO2I", & + (/ "ASO4I ", "ANO3I ", "ANH4I ", "ANAI ", "ACLI ", "AECI ", "AOTHRI ", "APOCI ", & ! I-mode (Atken) + "ALVPO1I", "ASVPO1I", "ASVPO2I", "ALVOO1I", "ALVOO2I", "ASVOO1I", "ASVOO2I", "APNCOMI", & "ASO4J ", "ANO3J ", "ANH4J ", "ANAJ ", "ACLJ ", "AECJ ", "AOTHRJ ", & ! J-mode (accum) "ALVPO1J", "ASVPO1J", "ASVPO2J", "ASVPO3J", "AIVPO1J", & - "AXYL1J ", "AXYL2J ", "AXYL3J ", "ATOL1J ", "ATOL2J ", "ATOL3J ", "ABNZ1J ", "ABNZ2J ", & - "ABNZ3J ", "AISO1J ", "AISO2J ", "AISO3J ", "ATRP1J ", "ATRP2J ", "ASQTJ ", "AALK1J ", & - "AALK2J ", "APAH1J ", "APAH2J ", "APAH3J ", "AORGCJ ", "AOLGBJ ", "AOLGAJ ", & + "AMTNO3J", "AMTHYDJ", "APOCJ ", "APNCOMJ", "AAVB1J ", "AAVB2J ", "AAVB3J ", "AAVB4J ", & + "AMT1J ", "AISO1J ", "AISO2J ", "AISO3J ", "AMT2J ", "AMT3J ", "ASQTJ ", "AMT4J ", & + "AMT5J ", "AMT6J ", "AORGCJ ", "AOLGBJ ", "AOLGAJ ", & "ALVOO1J", "ALVOO2J", "ASVOO1J", "ASVOO2J", "ASVOO3J", "APCSOJ ", & "AFEJ ", "ASIJ ", "ATIJ ", "ACAJ ", "AMGJ ", "AMNJ ", "AALJ ", "AKJ ", & "ASOIL ", "ACORS ", "ASEACAT", "ACLK ", "ASO4K ", "ANO3K ", "ANH4K " /) ! K-mode (coarse) - integer, parameter :: nspc(3) = (/ 14, 49, 7 /) + integer, parameter :: nspc(3) = (/ 16, 47, 7 /) ! -- begin pm25 = 0. diff --git a/src/drv/cmaq_model_mod.F90 b/src/drv/cmaq_model_mod.F90 index 305e7de..24fb0c5 100644 --- a/src/drv/cmaq_model_mod.F90 +++ b/src/drv/cmaq_model_mod.F90 @@ -4,7 +4,8 @@ module cmaq_model_mod use aqm_types_mod use aqm_model_mod use cmaq_mod - + use RUNTIME_VARS !(AQM) + implicit none private @@ -40,6 +41,9 @@ subroutine cmaq_model_init(rc) ! -- initialize CMAQ ! -- NOTE: CMAQ can only run on 1DE/PET domain decomposition (DE 0) + ! Initialize all runscript environmental variables (AQM) + CALL INIT_ENV_VARS( 0, 0 ) + ! -- initialize species from namelists on DE 0 call cmaq_species_read(numSpecies, rc=localrc) if (aqm_rc_check(localrc, msg="Failed to initialize CMAQ species", & @@ -52,6 +56,11 @@ subroutine cmaq_model_init(rc) call aqm_model_domain_get(nt=nt, rc=localrc) if (aqm_rc_check(localrc, msg="Failed to retrieve model domain on local DE", & file=__FILE__, line=__LINE__, rc=rc)) return + + !add log AQM + write( logdev,* ) ' NT number of tracer is: ', nt + write( logdev,* ) ' p_aqm_beg/ndiag is:', config % species %p_aqm_beg,'/',config % species % ndiag + if (aqm_rc_test((config % species % p_aqm_beg + numSpecies - 1 > nt), & msg="Coupling tracer fields cannot hold all the required species", & file=__FILE__, line=__LINE__, rc=rc)) return @@ -117,10 +126,10 @@ subroutine cmaq_model_advance(jdate, jtime, tstep, rc) ! -- import advected species mixing ratios if (config % init_conc .and. first_step) then call cmaq_conc_init(jdate, jtime, tstep, rc=localrc) - if (aqm_rc_check(localrc, msg="Failed to initialize concentrations", & - file=__FILE__, line=__LINE__, rc=rc)) return - first_step = .false. - if (config % verbose) call cmaq_conc_log(trim(config % name) // ": init") + if (aqm_rc_check(localrc, msg="Failed to initialize concentrations", & + file=__FILE__, line=__LINE__, rc=rc)) return + first_step = .false. + if (config % verbose) call cmaq_conc_log(trim(config % name) // ": init") else call cmaq_import(stateIn % tr, stateIn % prl, stateIn % phii, stateIn % temp, config % species % p_aqm_beg) if (config % verbose) call cmaq_conc_log(trim(config % name) // ": import") diff --git a/src/io/ioapi/IODECL3.EXT b/src/io/ioapi/IODECL3.EXT new file mode 100644 index 0000000..377c767 --- /dev/null +++ b/src/io/ioapi/IODECL3.EXT @@ -0,0 +1,319 @@ + +!......................................................................... +! Version "@(#)$Header$" +! EDSS/Models-3 I/O API. Copyright (C) 1992-2002 MCNC +! Distributed under the GNU LESSER GENERAL PUBLIC LICENSE version 2.1 +! See file "LGPL.txt" for conditions of use. +!.................................................................... +! INCLUDE FILE IODECL3.EXT +! +! +! DO NOT EDIT !! +! +! The EDSS/Models-3 I/O API depends in an essential manner +! upon the contents of this INCLUDE file. ANY CHANGES are +! likely to result in very obscure, difficult-to-diagnose +! bugs caused by an inconsistency between standard "libioapi.a" +! object-libraries and whatever code is compiled with the +! resulting modified INCLUDE-file. +! +! By making any changes to this INCLUDE file, the user +! explicitly agrees that in the case any assistance is +! required of MCNC or of the I/O API author, Carlie J. Coats, Jr. +! as a result of such changes, THE USER AND/OR HIS PROJECT OR +! CONTRACT AGREES TO REIMBURSE MCNC AND/OR THE I/O API AUTHOR, +! CARLIE J. COATS, JR., AT A RATE TRIPLE THE NORMAL CONTRACT +! RATE FOR THE SERVICES REQUIRED. +! +! CONTAINS: declarations and usage comments for the Models-3 (M3) +! Interprocess Communication Applications Programming +! Interface (API) +! +! DEPENDENT UPON: consistency with the API itself. +! +! RELATED FILES: PARM3.EXT, FDESC3.EXT +! +! REVISION HISTORY: +! prototype 3/1992 by Carlie J. Coats, Jr., MCNC Environmental +! Programs +! +! Modified 2/2002 by CJC: updated dates, license, compatibility +! with both free and fixed Fortran 9x source forms +! +!.................................................................... + + LOGICAL CHECK3 ! is JDATE:JTIME available for FNAME? + LOGICAL CLOSE3 ! close FNAME + LOGICAL DESC3 ! Puts M3 file descriptions into FDESC3.EXT + LOGICAL FILCHK3 ! check file type and dimensions + INTEGER INIT3 ! Initializes M3 API and returns unit for log + LOGICAL SHUT3 ! Shuts down API + LOGICAL OPEN3 ! opens an M3 file + LOGICAL READ3 ! read M3 file for variable,layer,timestep + LOGICAL WRITE3 ! write timestep to M3 file + LOGICAL XTRACT3 ! extract window from timestep in a M3 file + LOGICAL INTERP3 ! do time interpolation from a M3 file + LOGICAL DDTVAR3 ! do time derivative from M3 file + + LOGICAL INTERPX ! time interpolation from a window + ! extraction from an M3 gridded file +!! LOGICAL PINTERPB ! parallel time interpolation from an + ! M3 boundary file + + LOGICAL INQATT3 ! inquire attributes in M3 file + LOGICAL RDATT3 ! read numeric attributes by name from M3 file + LOGICAL WRATT3 ! add new numeric attributes " + LOGICAL RDATTC ! read CHAR attributes " + LOGICAL WRATTC ! add new CHAR attributes " + + LOGICAL SYNC3 ! flushes file to disk, etc. + + EXTERNAL CHECK3 , CLOSE3, DESC3 , FILCHK3, INIT3 , + & SHUT3 , OPEN3 , READ3 , WRITE3 , XTRACT3, + & INTERP3, DDTVAR3, INQATT3, RDATT3 , WRATT3 , + & RDATTC , WRATTC, SYNC3, INTERPX ! , PINTERPB + +!....................................................................... +!.................. API FUNCTION USAGE AND EXAMPLES .................. +!....... +!....... In the examples below, names (FILENAME, PROGNAME, VARNAME) +!....... should be CHARACTER*16, STATUS and RDFLAG are LOGICAL, dates +!....... are INTEGER, coding the Julian date as YYYYDDD, times are +!....... INTEGER, coding the time as HHMMSS, and LOGDEV is the FORTRAN +!....... INTEGER unit number for the program's log file; and layer, +!....... row, and column specifications use INTEGER FORTRAN array +!....... index conventions (in particular, they are based at 1, not +!....... based at 0, as in C). +!....... Parameter values for "ALL...", for grid and file type IDs, +!....... and for API dimensioning values are given in PARMS3.EXT; +!....... file descriptions are passed via commons BDESC3 and CDESC3 +!....... in file FDESC3.EXT. +!....... +!....... CHECK3(): check whether timestep JDATE:JTIME is available +!....... for variable VNAME in file FILENAME. +!....... FORTRAN usage is: +!....... +!....... STATUS = CHECK3 ( FILENAME, VNAME, JDATE, JTIME ) +!....... IF ( .NOT. STATUS ) THEN +!....... ... (data-record not available in file FNAME) +!....... END IF +!....... +!....... CLOSE3(): check whether timestep JDATE:JTIME is available +!....... for variable VNAME in file FILENAME. +!....... FORTRAN usage is: +!....... +!....... STATUS = CLOSE3 ( FILENAME ) +!....... IF ( .NOT. STATUS ) THEN +!....... ... could not flush file to disk successfully, +!....... or else file not currently open. +!....... END IF +!....... +!....... DESC3(): return description of file FILENAME to the user +!....... in commons BDESC3 and CDESC3, file FDESC3.EXT. +!....... FORTRAN usage is: +!....... +!....... STATUS = DESC3 ( FILENAME ) +!....... IF ( .NOT. STATUS ) THEN +!....... ... (file not yet opened) +!....... END IF +!....... ... +!....... (Now common FDESC3 (file FDESC3.EXT) contains the descriptive +!....... information for this file.) +!....... +!....... FILCHK3(): check whether file type and dimensions for file +!....... FILENAME match the type and dimensions supplied by the user. +!....... FORTRAN usage is: +!....... +!....... STATUS = FILCHK3 ( FILENAME, FTYPE, NCOLS, NROWS, NLAYS, NTHIK ) +!....... IF ( .NOT. STATUS ) THEN +!....... ... (file type and dimensions do not match +!....... the supplied FTYPE, NCOLS, NROWS, NLAYS, NTHIK) +!....... END IF +!....... ... +!....... +!....... INIT3(): set up the M3 API, open the program's log file, and +!....... return the unit FORTRAN number for log file. May be called +!....... multiple times (in which case, it always returns the log-file's +!....... unit number). Note that block data INITBLK3.FOR must also be +!....... linked in. +!....... FORTRAN usage is: +!....... +!....... LOGDEV = INIT3 ( ) +!....... IF ( LOGDEV .LT. 0 ) THEN +!....... ... (can't proceed: probably can't open the log. +!....... Stop the program) +!....... END IF +!....... +!....... OPEN3(): open file FILENAME from program PROGNAME, with +!....... requested read-write/old-new status. For files opened for WRITE, +!....... record program-name and other history info in their headers. +!....... May be called multiple times for the same file (in which case, +!....... it returns true unless the request is for READ-WRITE status +!....... for a file already opened READ-ONLY). Legal statuses are: +!....... FSREAD3: "old read-only" +!....... FSRDWR3: "old read-write" +!....... FSNEW3: "new (read-write)" +!....... FSUNKN3: "unknown (read_write)" +!....... FORTRAN usage is: +!....... +!....... STATUS = OPEN3 ( FILENAME, FSTATUS, PROGNAME ) +!....... IF ( .NOT. STATUS ) THEN +!....... ... (process the error) +!....... END IF +!....... +!....... READ3(): read data from FILENAME for timestep JDATE:JTIME, +!....... variable VNAME, layer LAY, into location ARRAY. +!....... If VNAME==ALLVARS3=='ALL ', reads all variables; +!....... if LAY==ALLAYS3==-1, reads all layers. +!....... Offers random access to the data by filename, date&time, variable, +!....... and layer. For DICTIONARY files, logical name for file being +!....... requested maps into the VNAME argument. For time-independent +!....... files (including DICTIONARY files), JDATE and JTIME are ignored. +!....... FORTRAN usage is: +!....... +!....... STATUS = READ3 ( FILENAME, VNAME, LAY, JDATE, JTIME, ARRAY ) +!....... IF ( .NOT. STATUS ) THEN +!....... ... (read failed -- process this error.) +!....... END IF +!....... +!....... SHUT3(): Flushes and closes down all M3 files currently open. +!....... Must be called before program termination; if it returns FALSE +!....... the run must be considered suspect. +!....... FORTRAN usage is: +!....... +!....... STATUS = SHUT3 ( ) +!....... IF ( .NOT. STATUS ) THEN +!....... ... (Flush of files to disk probably didn't work; +!....... look at netCDF error messages) +!....... END IF +!....... +!....... WRITE3(): write data from ARRAY to file FILENAME for timestep +!....... JDATE:JTIME. For GRIDDED, BUONDARY, and CUSTOM files, VNAME +!....... must be a variable found in the file, or else ALLVARS3=='ALL' +!....... to write all variables from ARRAY. For other file types, +!....... VNAME _must_ be ALLVARS3. +!....... FORTRAN usage is: +!....... +!....... STATUS = WRITE3 ( FILENAME, VNAME, JDATE, JTIME, ARRAY ) +!....... IF ( .NOT. STATUS ) THEN +!....... ... (write failed -- process this error.) +!....... END IF +!....... +!....... XTRACT3(): read/extract gridded data into location ARRAY +!....... from FILENAME for time step JDATE:JTIME, variable VNAME +!....... and the data window defined by +!....... LOLAY <= layer <= HILAY, +!....... LOROW <= row <= HIROW, +!....... LOCOL <= column <= HICOL +!....... FORTRAN usage is: +!....... +!....... STATUS = XTRACT3 ( FILENAME, VNAME, +!....... & LOLAY, HILAY, +!....... & LOROW, HIROW, +!....... & LOCOL, HICOL, +!....... & JDATE, JTIME, ARRAY ) +!....... IF ( .NOT. STATUS ) THEN +!....... ... (extract failed -- process this error.) +!....... END IF +!....... +!....... INTERP3(): read/interpolate gridded, boundary, or custom data +!....... into location ARRAY from FILENAME for time JDATE:JTIME, variable +!....... VNAME, and all layers. Note use of ASIZE = transaction size = +!....... size of ARRAY, for error-checking. +!....... FORTRAN usage is: +!....... +!....... STATUS = INTERPX ( FILENAME, VNAME, CALLER, JDATE, JTIME, +!....... & ASIZE, ARRAY ) +!....... IF ( .NOT. STATUS ) THEN +!....... ... (interpolate failed -- process this error.) +!....... END IF +!....... +!....... INTERPX(): read/interpolate/window gridded, boundary, or custom +!....... data into location ARRAY from FILENAME for time JDATE:JTIME, +!....... variable VNAME, and all layers. +!....... FORTRAN usage is: +!....... +!....... STATUS = INTERPX ( FILENAME, VNAME, CALLER, +!....... & COL0, COL1, ROW0, ROW1, LAY0, LAY1, +!....... & JDATE, JTIME, ARRAY ) +!....... IF ( .NOT. STATUS ) THEN +!....... ... (windowed interpolate failed -- process this error.) +!....... END IF +!....... +!....... DDTVAR3(): read and calculate mean time derivative (per second) +!....... for gridded, boundary, or custom data. Put result into location +!....... ARRAY from FILENAME for time JDATE:JTIME, variable VNAME, and all +!....... layers. Note use of ASIZE = transaction size = size of ARRAY, +!....... for error-checking. Note d/dt( time-independent )==0.0 +!....... FORTRAN usage is: +!....... +!....... STATUS = DDTVAR3 ( FILENAME, VNAME, JDATE, JTIME, +!....... & ASIZE, ARRAY ) +!....... IF ( .NOT. STATUS ) THEN +!....... ... (operation failed -- process this error.) +!....... END IF +!....... +!....... INQATT(): inquire how many attributes there are for a +!....... particular file and variable (or for the file globally, +!....... if the variable-name ALLVAR3 is used)), and what the +!....... names, types, and array-dimensions of these attributes are. +!....... FORTRAN usage is: +!....... +!....... STATUS = INQATT3( FNAME, VNAME, MXATTS, +!....... & NATTS, ANAMES, ATYPES, ASIZES ) +!....... IF ( .NOT. STATUS ) THEN +!....... ... (operation failed -- process this error.) +!....... END IF +!....... +!....... RDATT3(): Reads an INTEGER, REAL, or DOUBLE attribute by name +!....... for a specified file and variable into a user-specified array. +!....... If variable name is ALLVAR3, reads the file-global attribute. +!....... FORTRAN usage is: +!....... +!....... STATUS = RDATT3( FNAME, VNAME, ANAME, ATYPE, AMAX, +!....... & ASIZE, AVAL ) +!....... IF ( .NOT. STATUS ) THEN +!....... ... (operation failed -- process this error.) +!....... END IF +!....... +!....... WRATT3(): Writes an INTEGER, REAL, or DOUBLE attribute by name +!....... for a specified file and variable. If variable name is ALLVAR3, +!....... reads the file-global attribute. +!....... +!....... STATUS = WRATT3( FNAME, VNAME, +!....... & ANAME, ATYPE, AMAX, AVAL ) +!....... IF ( .NOT. STATUS ) THEN +!....... ... (operation failed -- process this error.) +!....... END IF +!....... +!....... RDATTC(): Reads a CHARACTER string attribute by name +!....... for a specified file and variable into a user-specified array. +!....... If variable name is ALLVAR3, reads the file-global attribute. +!....... FORTRAN usage is: +!....... +!....... STATUS = RDATTC( FNAME, VNAME, ANAME, CVAL ) +!....... IF ( .NOT. STATUS ) THEN +!....... ... (operation failed -- process this error.) +!....... END IF +!....... +!....... WRATT3(): Writes a CHARACTER string attribute by name +!....... for a specified file and variable. If variable name is ALLVAR3, +!....... reads the file-global attribute. +!....... +!....... STATUS = WRATTC( FNAME, VNAME, ANAME, CVAL ) +!....... IF ( .NOT. STATUS ) THEN +!....... ... (operation failed -- process this error.) +!....... END IF +!....... +!....... SYNC3(): Synchronize FILENAME with disk (flush output; +!....... re-read header and invalidate data-buffers for input. +!....... FORTRAN usage is: +!....... +!....... STATUS = SYNC3 ( FILENAME ) +!....... IF ( .NOT. STATUS ) THEN +!....... ... (file not yet opened, or disk-synch failed) +!....... END IF +!....... ... +!....... +!................ end IODECL3.EXT .................................... + diff --git a/src/io/ioapi/daymon.F b/src/io/ioapi/daymon.F new file mode 100644 index 0000000..0cc905f --- /dev/null +++ b/src/io/ioapi/daymon.F @@ -0,0 +1,102 @@ + + SUBROUTINE DAYMON( JDATE, MNTH, MDAY ) + +C*********************************************************************** +C Version "$Id: daymon.F 219 2015-08-17 18:05:54Z coats $" +C EDSS/Models-3 I/O API. +C Copyright (C) 1992-2002 MCNC and Carlie J. Coats, Jr., and +C (C) 2003-2013 Baron Advanced Meteorological Systems +C Distributed under the GNU LESSER GENERAL PUBLIC LICENSE version 2.1 +C See file "LGPL.txt" for conditions of use. +C......................................................................... +C function body starts at line 49 +C +C FUNCTION: +C +C This routine determines the month and day of the month +C for the Julian date YYYYDDD that is input +C +C REVISION HISTORY: +C +C 3/1995 Adapted for Models-3/EDSS from ROM GREG.FOR by CJC +C +C 2/2002 Unification by CJC with global-climate DAYMON, which +C uses a 360-day "year" +C +C Version 1/2007 by CJC: handle negative JDATEs correctly +C +C Modified 03/2010 by CJC: F9x changes for I/O API v3.1 +C +C Version 5/2013 by CJC: handle standard-year cases +C*********************************************************************** + + + IMPLICIT NONE + +C........... ARGUMENTS and their descriptions: + + INTEGER, INTENT(IN ) :: JDATE ! Julian date, format YYYYDDD = 1000*Year + Day + INTEGER, INTENT( OUT) :: MNTH ! month (1...12) + INTEGER, INTENT( OUT) :: MDAY ! day-of-month (1...28,29,30,31) + + +C........... SCRATCH LOCAL VARIABLES: + + INTEGER IBIAS, IDATE, YEAR, DAY, L, J + + +C*********************************************************************** +C begin body of subroutine DAYMON + + IF ( JDATE .GT. -1000 ) THEN + IDATE = JDATE + IBIAS = 0 + ELSE + YEAR = -JDATE + YEAR = YEAR / 1000 + 1 + IBIAS = 2800000 * YEAR + IDATE = JDATE + IBIAS + END IF + +#ifdef IO_360 + DAY = MOD( IDATE, 1000 ) - 1 + MNTH = DAY / 30 + 1 + MDAY = MOD( DAY , 30 ) + 1 + RETURN +#endif + +#ifdef IO_365 + YEAR = JDATE / 1000 + DAY = MOD( IDATE, 1000 ) + J = MOD( DAY + 305, 365 ) + J = MOD( J, 153 ) / 61 + ( J / 153 ) * 2 + J + + MNTH = MOD( J / 31 + 2, 12 ) + 1 + MDAY = MOD( J, 31 ) + 1 + RETURN +#endif + + YEAR = JDATE / 1000 + DAY = MOD( IDATE, 1000 ) + IF ( YEAR .LE. 2 ) THEN !! "standard-year data + L = 365 + ELSE IF ( MOD( YEAR, 400 ) .EQ. 0 ) THEN + L = 366 + ELSE IF ( MOD( YEAR, 100 ) .EQ. 0 ) THEN + L = 365 + ELSE IF ( MOD( YEAR, 4 ) .EQ. 0 ) THEN + L = 366 + ELSE + L = 365 + END IF + + J = MOD( DAY + 305, L ) + J = MOD( J, 153 ) / 61 + ( J / 153 ) * 2 + J + + MNTH = MOD( J / 31 + 2, 12 ) + 1 + MDAY = MOD( J, 31 ) + 1 + + RETURN + + END SUBROUTINE DAYMON + diff --git a/src/io/ioapi/m3err.F b/src/io/ioapi/m3err.F new file mode 100644 index 0000000..3d653d0 --- /dev/null +++ b/src/io/ioapi/m3err.F @@ -0,0 +1,59 @@ + + SUBROUTINE M3ERR ( CALLER, JDATE, JTIME, MSGTXT, FATAL ) + +C*********************************************************************** +C Version "$Id: m3err.F 219 2015-08-17 18:05:54Z coats $" +C EDSS/Models-3 I/O API. +C Copyright (C) 1992-2002 MCNC and Carlie J. Coats, Jr., +C (C) 2003-2010 by Baron Advanced Meteorological Systems. +C Distributed under the GNU LESSER GENERAL PUBLIC LICENSE version 2.1 +C See file "LGPL.txt" for conditions of use. +C......................................................................... +C +C DEPRECATED!! +C Use M3EXIT(), instead. +C +C subroutine body starts at line 51 +C +C FUNCTION: Generate simple error messages for Models-3 core; +C terminate program execution via exit( 2 ) iff FATAL +C +C PRECONDITIONS REQUIRED: +C JDATE:JTIME represented as YYYYDDD:HHMMSS +C +C SUBROUTINES AND FUNCTIONS CALLED: DT2STR, INIT3, SHUT3 +C +C REVISION HISTORY: +C prototype 5/92 by CJC +C Revised 8/96 to close currently-open POSIX-OK Fortran units. +C Modified 1/97 by CJC to trim trailing blanks from MSGTXT +C Modified 10/98 by CJC: rewritten in terms of m3exit(), m3warn() +C*********************************************************************** + + IMPLICIT NONE + +C........... INCLUDES: + + INCLUDE 'IODECL3.EXT' + + +C........... ARGUMENTS and their descriptions: + + CHARACTER*(*), INTENT(IN ) :: CALLER ! name of the caller + INTEGER , INTENT(IN ) :: JDATE, JTIME ! model date&time for the error + CHARACTER*(*), INTENT(IN ) :: MSGTXT ! error message + LOGICAL , INTENT(IN ) :: FATAL ! terminate program iff TRUE + + +C*********************************************************************** +C begin body of subroutine M3ERR + + IF ( FATAL ) THEN + CALL M3EXIT( CALLER, JDATE, JTIME, MSGTXT, 2 ) + ELSE ! not endflag + CALL M3WARN( CALLER, JDATE, JTIME, MSGTXT ) + END IF + RETURN + + END SUBROUTINE M3ERR + diff --git a/src/io/ioapi/m3utilio.F90 b/src/io/ioapi/m3utilio.F90 index 398a0eb..5cfe18d 100644 --- a/src/io/ioapi/m3utilio.F90 +++ b/src/io/ioapi/m3utilio.F90 @@ -46,6 +46,14 @@ LOGICAL FUNCTION CURRSTEP ( JDATE, JTIME, & END FUNCTION CURRSTEP END INTERFACE + INTERFACE + SUBROUTINE DAYMON( JDATE, MNTH, MDAY ) + INTEGER, INTENT(IN ) :: JDATE ! Julian date, format YYYYDDD = 1000*Year + Day + INTEGER, INTENT( OUT) :: MNTH ! month (1...12) + INTEGER, INTENT( OUT) :: MDAY ! day-of-month (1...28,29,30,31) + END SUBROUTINE DAYMON + END INTERFACE + INTERFACE ! get file-description for FNAME LOGICAL FUNCTION DESC3( FNAME ) CHARACTER*(*), INTENT(IN ) :: FNAME ! file name @@ -58,13 +66,36 @@ CHARACTER*10 FUNCTION HHMMSS ( JTIME ) END FUNCTION HHMMSS END INTERFACE - INTERFACE - INTEGER FUNCTION INDEX1( NAME, N, NLIST ) +! INTERFACE +! INTEGER FUNCTION INDEX1( NAME, N, NLIST ) +! CHARACTER*(*), INTENT(IN ) :: NAME ! Character string being searched for +! INTEGER , INTENT(IN ) :: N ! Length of array to be searched +! CHARACTER*(*), INTENT(IN ) :: NLIST(*) ! array to be searched +! END FUNCTION INDEX1 +! END INTERFACE + + INTERFACE INDEXKEY + + INTEGER FUNCTION INDEX1( NAME, N, NLIST ) CHARACTER*(*), INTENT(IN ) :: NAME ! Character string being searched for INTEGER , INTENT(IN ) :: N ! Length of array to be searched CHARACTER*(*), INTENT(IN ) :: NLIST(*) ! array to be searched - END FUNCTION INDEX1 - END INTERFACE + END FUNCTION INDEX1 + + INTEGER FUNCTION INDEXINT1( IKEY, N, NLIST ) + INTEGER, INTENT(IN ) :: IKEY ! integer being searched for + INTEGER, INTENT(IN ) :: N ! Length of array to be searched + INTEGER, INTENT(IN ) :: NLIST(*) ! array to be searched + END FUNCTION INDEXINT1 + + INTEGER FUNCTION INDEXL1( LKEY, N, NLIST ) + INTEGER*8, INTENT(IN ) :: LKEY ! integer being searched for + INTEGER, INTENT(IN ) :: N ! Length of array to be searched + INTEGER*8, INTENT(IN ) :: NLIST(*) ! array to be searched + END FUNCTION INDEXL1 + + END INTERFACE !! indexkey + INTERFACE INTEGER FUNCTION JUNIT() @@ -114,6 +145,15 @@ SUBROUTINE M3MSG2( MESSAGE ) END SUBROUTINE M3MSG2 END INTERFACE + INTERFACE + SUBROUTINE M3EXIT( CALLER, JDATE, JTIME, MSGTXT, ISTAT ) + CHARACTER*(*), INTENT(IN ) :: CALLER ! name of the caller + INTEGER , INTENT(IN ) :: JDATE, JTIME ! model date&time for the error + CHARACTER*(*), INTENT(IN ) :: MSGTXT ! error message + INTEGER , INTENT(IN ) :: ISTAT ! exit status for program + END SUBROUTINE M3EXIT + END INTERFACE + INTERFACE READ3 MODULE PROCEDURE READ3_INTEGER MODULE PROCEDURE READ3_REAL @@ -172,7 +212,12 @@ LOGICAL FUNCTION OPEN3( FNAME, FSTATUS, PGNAME ) CHARACTER(LEN=*), INTENT(IN) :: FNAME INTEGER, INTENT(IN) :: FSTATUS CHARACTER(LEN=*), INTENT(IN) :: PGNAME + include SUBST_FILES_ID + OPEN3 = .TRUE. + IF (trim(fname) == trim(LUFRAC_CRO)) THEN + OPEN3 = .FALSE. + END IF END FUNCTION OPEN3 LOGICAL FUNCTION CLOSE3( FNAME ) diff --git a/src/model/CMAQ b/src/model/CMAQ index be5d28f..642e813 160000 --- a/src/model/CMAQ +++ b/src/model/CMAQ @@ -1 +1 @@ -Subproject commit be5d28fd1b60522e6fc98aefeead20e6aac3530b +Subproject commit 642e81395472d5887b54f601b60ee607ed39bf09 diff --git a/src/model/Makefile.am b/src/model/Makefile.am index cff3967..00d4ae9 100644 --- a/src/model/Makefile.am +++ b/src/model/Makefile.am @@ -168,7 +168,6 @@ libCCTM_a_SOURCES += \ $(PHOT)/CSQY_DATA.F \ $(PHOT)/OMI_1979_to_2015.dat \ $(PHOT)/opphot.F \ - $(PHOT)/phot.F \ $(PHOT)/PHOT_MET_DATA.F \ $(PHOT)/PHOT_MOD.F \ $(PHOT)/PHOTOLYSIS_ALBEDO.F \ @@ -219,7 +218,6 @@ libCCTM_a_SOURCES += \ $(UTIL)/bmatvec.F \ $(UTIL)/findex.f \ $(UTIL)/get_envlist.f \ - $(UTIL)/setup_logdev.F \ $(UTIL)/subhdomain.F \ $(UTIL)/UTILIO_DEFN.F @@ -250,11 +248,11 @@ libCCTM_a_SOURCES += \ ${localCCTM}/PT3D_DEFN.F \ ${localCCTM}/PT3D_FIRE_DEFN.F \ ${localCCTM}/PT3D_STKS_DEFN.F \ + $(localCCTM)/phot.F \ ${localCCTM}/ASX_DATA_MOD.F \ + $(localCCTM)/centralized_io_util_module.F \ ${localCCTM}/DUST_EMIS.F \ ${localCCTM}/AERO_PHOTDATA.F - - libCCTM_a_CPPFLAGS = -DSUBST_FILES_ID=\"FILES_CTM.EXT\" libCCTM_a_CPPFLAGS += -DSUBST_CONST=\"CONST.EXT\" libCCTM_a_CPPFLAGS += -DSUBST_EMISPRM=\"EMISPRM.EXT\" @@ -432,6 +430,10 @@ $(libEMIS)BIOG_EMIS.$(OBJEXT) : \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libEMIS)cropcal.$(OBJEXT) : \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) +$(libEMIS)DUST_EMIS.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ + $(libAERO)AERO_DATA.$(OBJEXT) $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) \ + $(libGRID)GRID_CONF.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ + $(libEMIS)LUS_DEFN.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libEMIS)EMIS_DEFN.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ $(libAERO)AERO_DATA.$(OBJEXT) $(libAERO)AERO_EMIS.$(OBJEXT) \ $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BEIS_DEFN.$(OBJEXT) \ diff --git a/src/model/Makefile.in b/src/model/Makefile.in index 078af39..a787fbd 100644 --- a/src/model/Makefile.in +++ b/src/model/Makefile.in @@ -186,7 +186,6 @@ am_libCCTM_a_OBJECTS = $(AERO)/libCCTM_a-AERO_DATA.$(OBJEXT) \ $(PHOT)/libCCTM_a-complex_number_module.$(OBJEXT) \ $(PHOT)/libCCTM_a-CSQY_DATA.$(OBJEXT) \ $(PHOT)/libCCTM_a-opphot.$(OBJEXT) \ - $(PHOT)/libCCTM_a-phot.$(OBJEXT) \ $(PHOT)/libCCTM_a-PHOT_MET_DATA.$(OBJEXT) \ $(PHOT)/libCCTM_a-PHOT_MOD.$(OBJEXT) \ $(PHOT)/libCCTM_a-PHOTOLYSIS_ALBEDO.$(OBJEXT) \ @@ -238,7 +237,9 @@ am_libCCTM_a_OBJECTS = $(AERO)/libCCTM_a-AERO_DATA.$(OBJEXT) \ ${localCCTM}/libCCTM_a-PT3D_DEFN.$(OBJEXT) \ ${localCCTM}/libCCTM_a-PT3D_FIRE_DEFN.$(OBJEXT) \ ${localCCTM}/libCCTM_a-PT3D_STKS_DEFN.$(OBJEXT) \ + $(localCCTM)/libCCTM_a-phot.$(OBJEXT) \ ${localCCTM}/libCCTM_a-ASX_DATA_MOD.$(OBJEXT) \ + $(localCCTM)/libCCTM_a-centralized_io_util_module.$(OBJEXT) \ ${localCCTM}/libCCTM_a-DUST_EMIS.$(OBJEXT) \ ${localCCTM}/libCCTM_a-AERO_PHOTDATA.$(OBJEXT) libCCTM_a_OBJECTS = $(am_libCCTM_a_OBJECTS) @@ -516,6 +517,7 @@ libCCTM_a_SOURCES = $(AERO)/AERO_DATA.F $(AERO)/aero_depv.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)/phot.F $(localCCTM)/centralized_io_util_module.F \ ${localCCTM}/AERO_PHOTDATA.F # local version of CCTM source files @@ -886,8 +888,6 @@ $(PHOT)/libCCTM_a-CSQY_DATA.$(OBJEXT): $(PHOT)/$(am__dirstamp) \ $(PHOT)/$(DEPDIR)/$(am__dirstamp) $(PHOT)/libCCTM_a-opphot.$(OBJEXT): $(PHOT)/$(am__dirstamp) \ $(PHOT)/$(DEPDIR)/$(am__dirstamp) -$(PHOT)/libCCTM_a-phot.$(OBJEXT): $(PHOT)/$(am__dirstamp) \ - $(PHOT)/$(DEPDIR)/$(am__dirstamp) $(PHOT)/libCCTM_a-PHOT_MET_DATA.$(OBJEXT): $(PHOT)/$(am__dirstamp) \ $(PHOT)/$(DEPDIR)/$(am__dirstamp) $(PHOT)/libCCTM_a-PHOT_MOD.$(OBJEXT): $(PHOT)/$(am__dirstamp) \ @@ -1024,6 +1024,9 @@ ${localCCTM}/libCCTM_a-PT3D_DATA_MOD.$(OBJEXT): \ ${localCCTM}/$(am__dirstamp) \ ${localCCTM}/$(DEPDIR)/$(am__dirstamp) ${localCCTM}/libCCTM_a-PT3D_DEFN.$(OBJEXT): \ + $(localCCTM)/$(am__dirstamp) \ + $(localCCTM)/$(DEPDIR)/$(am__dirstamp) +$(localCCTM)/libCCTM_a-phot.$(OBJEXT): \ ${localCCTM}/$(am__dirstamp) \ ${localCCTM}/$(DEPDIR)/$(am__dirstamp) ${localCCTM}/libCCTM_a-PT3D_FIRE_DEFN.$(OBJEXT): \ @@ -1033,6 +1036,9 @@ ${localCCTM}/libCCTM_a-PT3D_STKS_DEFN.$(OBJEXT): \ ${localCCTM}/$(am__dirstamp) \ ${localCCTM}/$(DEPDIR)/$(am__dirstamp) ${localCCTM}/libCCTM_a-ASX_DATA_MOD.$(OBJEXT): \ + $(localCCTM)/$(am__dirstamp) \ + $(localCCTM)/$(DEPDIR)/$(am__dirstamp) +$(localCCTM)/libCCTM_a-centralized_io_util_module.$(OBJEXT): \ ${localCCTM}/$(am__dirstamp) \ ${localCCTM}/$(DEPDIR)/$(am__dirstamp) ${localCCTM}/libCCTM_a-DUST_EMIS.$(OBJEXT): \ @@ -1532,11 +1538,17 @@ $(PHOT)/libCCTM_a-opphot.o: $(PHOT)/opphot.F $(PHOT)/libCCTM_a-opphot.obj: $(PHOT)/opphot.F $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(PHOT)/libCCTM_a-opphot.obj `if test -f '$(PHOT)/opphot.F'; then $(CYGPATH_W) '$(PHOT)/opphot.F'; else $(CYGPATH_W) '$(srcdir)/$(PHOT)/opphot.F'; fi` -$(PHOT)/libCCTM_a-phot.o: $(PHOT)/phot.F - $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(PHOT)/libCCTM_a-phot.o `test -f '$(PHOT)/phot.F' || echo '$(srcdir)/'`$(PHOT)/phot.F +$(localCCTM)/libCCTM_a-phot.o: $(localCCTM)/phot.F + $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(localCCTM)/libCCTM_a-phot.o `test -f '$(localCCTM)/phot.F' || echo '$(srcdir)/'`$(localCCTM)/phot.F + +$(localCCTM)/libCCTM_a-phot.obj: $(localCCTM)/phot.F + $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(localCCTM)/libCCTM_a-phot.obj `if test -f '$(localCCTM)/phot.F'; then $(CYGPATH_W) '$(localCCTM)/phot.F'; else $(CYGPATH_W) '$(srcdir)/$(localCCTM)/phot.F'; fi` + +$(localCCTM)/libCCTM_a-centralized_io_util_module.o: $(localCCTM)/centralized_io_util_module.F + $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(localCCTM)/libCCTM_a-centralized_io_util_module.o `test -f '$(localCCTM)/centralized_io_util_module.F' || echo '$(srcdir)/'`$(localCCTM)/centralized_io_util_module.F -$(PHOT)/libCCTM_a-phot.obj: $(PHOT)/phot.F - $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(PHOT)/libCCTM_a-phot.obj `if test -f '$(PHOT)/phot.F'; then $(CYGPATH_W) '$(PHOT)/phot.F'; else $(CYGPATH_W) '$(srcdir)/$(PHOT)/phot.F'; fi` +$(localCCTM)/libCCTM_a-centralized_io_util_module.obj: $(localCCTM)/centralized_io_util_module.F + $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(localCCTM)/libCCTM_a-centralized_io_util_module.obj `if test -f '$(localCCTM)/centralized_io_util_module.F'; then $(CYGPATH_W) '$(localCCTM)/centralized_io_util_module.F'; else $(CYGPATH_W) '$(srcdir)/$(localCCTM)/centralized_io_util_module.F'; fi` $(PHOT)/libCCTM_a-PHOT_MET_DATA.o: $(PHOT)/PHOT_MET_DATA.F $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(PHOT)/libCCTM_a-PHOT_MET_DATA.o `test -f '$(PHOT)/PHOT_MET_DATA.F' || echo '$(srcdir)/'`$(PHOT)/PHOT_MET_DATA.F @@ -1622,6 +1634,12 @@ $(VDIFF)/libCCTM_a-aero_sedv.o: $(VDIFF)/aero_sedv.F $(VDIFF)/libCCTM_a-aero_sedv.obj: $(VDIFF)/aero_sedv.F $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(VDIFF)/libCCTM_a-aero_sedv.obj `if test -f '$(VDIFF)/aero_sedv.F'; then $(CYGPATH_W) '$(VDIFF)/aero_sedv.F'; else $(CYGPATH_W) '$(srcdir)/$(VDIFF)/aero_sedv.F'; fi` +$(localCCTM)/libCCTM_a-ASX_DATA_MOD.o: $(localCCTM)/ASX_DATA_MOD.F + $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(localCCTM)/libCCTM_a-ASX_DATA_MOD.o `test -f '$(localCCTM)/ASX_DATA_MOD.F' || echo '$(srcdir)/'`$(localCCTM)/ASX_DATA_MOD.F + +$(localCCTM)/libCCTM_a-ASX_DATA_MOD.obj: $(localCCTM)/ASX_DATA_MOD.F + $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(localCCTM)/libCCTM_a-ASX_DATA_MOD.obj `if test -f '$(localCCTM)/ASX_DATA_MOD.F'; then $(CYGPATH_W) '$(localCCTM)/ASX_DATA_MOD.F'; else $(CYGPATH_W) '$(srcdir)/$(localCCTM)/ASX_DATA_MOD.F'; fi` + $(VDIFF)/libCCTM_a-conv_cgrid.o: $(VDIFF)/conv_cgrid.F $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(VDIFF)/libCCTM_a-conv_cgrid.o `test -f '$(VDIFF)/conv_cgrid.F' || echo '$(srcdir)/'`$(VDIFF)/conv_cgrid.F diff --git a/src/model/src/AERO_PHOTDATA.F b/src/model/src/AERO_PHOTDATA.F index ba1de04..41c708d 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. ) @@ -1335,7 +1396,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 T1G5, T2G5 REAL(8) T1P1, T2P1 C***the following are for calculating the Penndorff Coefficients @@ -1818,7 +1879,7 @@ 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 C***the following are for calculating the Penndorff Coefficients @@ -1922,8 +1983,8 @@ SUBROUTINE FAST_OPTICS( NR, NI, LAMBDA, DGN, SIGMA_G, BETA_EXT, BETA_SCAT, G ) XLNSIG = LOG( SIGMA_G ) ALPHV = DBLE(SCALE * PI * DGN * EXP( 3.0 * XLNSIG * XLNSIG ) / LAMBDA) - ALPHV2 = DBLE( ALPHV * ALPHV ) - ALPHV3 = DBLE( ALPHV * ALPHV * ALPHV ) + ALPHV2 = DBLE(ALPHV * ALPHV) + ALPHV3 = DBLE(ALPHV * ALPHV * ALPHV) XLNSIG2 = XLNSIG * XLNSIG A = 0.5 / XLNSIG2 @@ -2035,8 +2096,8 @@ SUBROUTINE FAST_OPTICS( NR, NI, LAMBDA, DGN, SIGMA_G, BETA_EXT, BETA_SCAT, G ) 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 )) + PENN2 = DBLE(THREE_PI_TWO * T2P1) 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 old mode 100755 new mode 100644 index 16b3095..0a03e63 --- 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,28 +129,42 @@ 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) + +!> Inline Canopy Processes + Real, Allocatable :: FCH ( :,: ) ! Forest Canopy Height (m) + Real, Allocatable :: FRT ( :,: ) ! Forest Fraction + Real, Allocatable :: CLU ( :,: ) ! Clumping Index + Real, Allocatable :: POPU ( :,: ) ! Population Density (people/10km2) + Real, Allocatable :: LAIE ( :,: ) ! ECCC BELD3 Derived LAI (m2/m2) + Real, Allocatable :: C1R ( :,: ) ! cumulative LAI fraction hc to 0.75 * hc + Real, Allocatable :: C2R ( :,: ) ! cumulative LAI fraction hc to 0.50 * hc + 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 Real, Allocatable :: DRAG ( :,: ) ! Drag Partion Real, Allocatable :: UTHR ( :,: ) ! Dry Threshold Friction Velocity + + Real, Allocatable :: COSZEN ( :,: ) ! Cosine of the zenith angle + Real, Allocatable :: CFRAC ( :,: ) ! cloud fraction !> U and V wind components on the cross grid points Real, Allocatable :: UWIND ( :,:,: ) ! [m/s] 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 :: PRES ( :,:,: ) ! pressure [Pa] Real, Allocatable :: PRESF ( :,:,: ) ! full layer pressure [Pa] 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 @@ -160,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 @@ -234,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 @@ -257,150 +248,299 @@ 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, allocatable, private :: BUFF1D( : ) ! 1D temp var number of layers + Real, allocatable, private :: BUFF2D( :,: ) ! 2D temp var + Real, allocatable, private :: BUFF3D( :,:,: ) ! 3D temp var - Real, Pointer, Private :: BUFF1D( : ) ! 1D temp var number of layers - Real, Pointer, Private :: BUFF2D( :,: ) ! 2D temp var - Real, Pointer, Private :: BUFF3D( :,:,: ) ! 3D temp var +! Canopy option control + 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 - CHARACTER( 18 ), SAVE :: CTM_WBDUST_FENGSHA = 'CTM_WBDUST_FENGSHA' ! env var for in-line - LOGICAL, PUBLIC, SAVE :: FENGSHA ! flag for fengsha option - + 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; @@ -411,25 +551,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' @@ -438,15 +572,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 @@ -469,7 +599,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 ), @@ -498,9 +628,11 @@ 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%NACL_EMIS( NCOLS,NROWS ), & Met_Data%UWINDA ( NCOLS,NROWS,NLAYS ), & Met_Data%VWINDA ( NCOLS,NROWS,NLAYS ), + & Met_Data%COSZEN ( NCOLS,NROWS ), + & Met_Data%CFRAC ( NCOLS,NROWS ), & Met_Data%UWIND ( NCOLS+1,NROWS+1,NLAYS ), & Met_Data%VWIND ( NCOLS+1,NROWS+1,NLAYS ), & Met_Data%KZMIN ( NCOLS,NROWS,NLAYS ), @@ -510,6 +642,7 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) & 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 ), @@ -534,116 +667,101 @@ 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 + 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 layer 2 soil temperature' + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + End If - If ( ABFLUX .Or. HGBIDI .Or. MOSAIC ) Then + If ( ABFLUX .or. BIOGEMIS_MEGAN ) Then ALLOCATE( Met_Data%SOIM2 ( NCOLS,NROWS ), - & Met_Data%SOIT2 ( NCOLS,NROWS ), & STAT = ALLOCSTAT ) If ( ALLOCSTAT .Ne. 0 ) Then - XMSG = 'Failure allocating mosaic met vars' + XMSG = 'Failure allocating layer 2 soil moisture' Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) End If + END IF + + If ( ABFLUX .or. HGBIDI ) Then - ALLOCATE( Grid_Data%WSAT ( NCOLS,NROWS ), - & Grid_Data%WWLT ( NCOLS,NROWS ), - & Grid_Data%BSLP ( NCOLS,NROWS ), + ALLOCATE( Grid_Data%BSLP ( NCOLS,NROWS ), & Grid_Data%WRES ( NCOLS,NROWS ), - & Grid_Data%WFC ( NCOLS,NROWS ), - & Grid_Data%LUFRAC ( NCOLS,NROWS,n_lufrac ), & STAT = ALLOCSTAT ) If ( ALLOCSTAT .Ne. 0 ) Then - XMSG = 'Failure allocating mosaic grid vars' + XMSG = 'Failure allocating Soil grid vars' 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 - 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 ), +!> ccccccccccccccccccccc canopy shade option!ccccccccccccccccccccc + CANOPY_SHADE = ENVYN( 'CTM_CANOPY_SHADE', + & 'Flag for in-line canopy shading', + & .FALSE., IOSX ) + +! IF ( CANOPY_SHADE ) THEN +! XMSG = 'Using in-line canopy shading option' +! CALL M3MSG2( XMSG ) +! END IF + If ( CANOPY_SHADE ) Then + ALLOCATE( Met_Data%FCH ( NCOLS,NROWS ), + & Met_Data%FRT ( NCOLS,NROWS ), + & Met_Data%CLU ( NCOLS,NROWS ), + & Met_Data%POPU ( NCOLS,NROWS ), + & Met_Data%LAIE ( NCOLS,NROWS ), + & Met_Data%C1R ( NCOLS,NROWS ), + & Met_Data%C2R ( NCOLS,NROWS ), + & Met_Data%C3R ( NCOLS,NROWS ), + & Met_Data%C4R ( NCOLS,NROWS ), & STAT = ALLOCSTAT ) If ( ALLOCSTAT .Ne. 0 ) Then - XMSG = 'Failure allocating chemistry dependent mosaic vars' + XMSG = 'Failure allocating Canopy Shade variables' 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 - End If + End If !> ccccccccccccccccccccc Fengsha option!ccccccccccccccccccccc 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 ), - & Met_Data%DRAG ( NCOLS,NROWS ), + & Met_Data%DRAG ( NCOLS,NROWS ), & Met_Data%UTHR ( NCOLS,NROWS ), & STAT = ALLOCSTAT ) If ( ALLOCSTAT .Ne. 0 ) Then @@ -654,47 +772,19 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) !> 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 - - 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 @@ -702,189 +792,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. @@ -892,7 +858,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; @@ -917,14 +883,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] @@ -938,9 +900,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 @@ -953,361 +912,157 @@ 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) - 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 ('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 + call interpolate_var ('TA', jdate, jtime, Met_Data%TA) - 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 + call interpolate_var ('QV', jdate, jtime, Met_Data%QV) - 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 ('QC', jdate, jtime, Met_Data%QC) - 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 ('UWINDA', jdate, jtime, Met_Data%UWINDA) - 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 ('VWINDA', jdate, jtime, Met_Data%VWINDA) 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 -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 + call interpolate_var ('ZRUF', jdate, jtime, Met_Data%Z0) - 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 +C Canopy vars + If ( CANOPY_SHADE ) Then + call interpolate_var ('FCH', jdate, jtime, Met_Data%FCH) - 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 + call interpolate_var ('FRT', jdate, jtime, Met_Data%FRT) - 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 + call interpolate_var ('CLU', jdate, jtime, Met_Data%CLU) - 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 ('POPU', jdate, jtime, Met_Data%POPU) - 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 - End If + call interpolate_var ('LAIE', jdate, jtime, Met_Data%LAIE) - 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 ) + 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 !(canopy option) +C FENGSHA vars + If (FENGSHA ) 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 +C Soil vars + call interpolate_var ('SOIM1', jdate, jtime, Met_Data%SOIM1) + + If ( ABFLUX .or. BIOGEMIS_MEGAN) Then + call interpolate_var ('SOIM2', jdate, jtime, Met_Data%SOIM2) End If - 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 ) + call interpolate_var ('SOIT1', jdate, jtime, Met_Data%SOIT1) + + 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 @@ -1315,13 +1070,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 @@ -1331,73 +1080,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 ) @@ -1419,14 +1144,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 ) ) @@ -1460,8 +1183,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 @@ -1487,6 +1210,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 a01d069..0a6d6fe 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 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 ) @@ -274,76 +274,37 @@ end subroutine tfbelow end if 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 ) - - if ( status .ne. 0 ) then - xmsg = '*** Failure allocating WMAX or TFB' - call m3warn( pname, jdate, jtime, xmsg ) - success = .false.; return - end if - + !allocate( tfb( ncols,nrows ), stat = status ) !tfa and tfb + !were removed in most recent note. + + 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 - - else + if ( .not. lus_init( jdate, jtime ) ) then + xmsg = 'Failure initializing land use module' + call m3exit( pname, jdate, jtime, xmsg, xstat2 ) + end if + + else 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 +312,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 +331,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 +416,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 @@ -519,9 +450,10 @@ end subroutine tfbelow if ( status .ne. 0 ) then xmsg = '*** Failure allocating DIAGNM_SWAP' 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 !dust scheme 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 @@ -752,12 +637,13 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt ) real, parameter :: betab_mb = betab * mb ! = 45.0 character( 24 ) :: ctm_wbdust_fengsha_alpha = 'CTM_WBDUST_FENGSHA_ALPHA' ! env var to - ! retrieve FENGSHA scaling factor + ! 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 +651,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 +661,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] @@ -799,22 +684,6 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt ) 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 +699,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 +713,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 +734,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 +748,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 @@ -964,9 +763,9 @@ end subroutine tfabove if ( firstime ) then firstime = .false. if ( fengsha ) then - dust_alpha = 0.05 ! default + dust_alpha = 0.05 ! default dust_alpha = envreal( ctm_wbdust_fengsha_alpha, - & 'Emission global scaling factor for FENGSHA dust scheme', + & 'Emission global scaling factor for FENGSHA dust scheme', & dust_alpha, status ) if ( status .ne. 0 ) then xmsg = '*** Failure retrieving FENGSHA scaling factor' @@ -974,27 +773,24 @@ end subroutine tfabove end if write(xmsg,'("Using FENGSHA alpha = ",g12.5)') dust_alpha call m3msg2 ( xmsg ) - else - 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 ) - 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 + else !this is default case + 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 ) + 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 fengsha end if -C---Calculate transport factor above the canopy - call tfabove ( tfa ) - C---Select dust scheme 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 @@ -1012,22 +808,22 @@ end subroutine tfabove & * Met_Data%clayf( c,r ) 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] + soimt( c,r ) = Met_Data%soim1( c,r ) ! <-[m**3/m**3] & * 1000.0 / ( 2650.0 * ( 0.511 + 0.126 - & * Met_Data%sandf( c,r ) ) ) + & * Met_Data%sandf(c,r ) ) ) C---Soil moisture effect on U*t - if ( soimt( c,r ) .le. 0.01 * wm ) then ! wm in [%] + if ( soimt( c,r ) .le. 0.01 * wm ) then ! wm in[%] fmoit( c,r ) = 1.0 else - fmoit( c,r ) = sqrt( 1.0 + 1.21 * ( 100.0 * soimt( c,r ) - wm ) ** 0.68 ) + fmoit( c,r ) = sqrt( 1.0 + 1.21 * ( 100.0 *soimt( c,r ) - wm ) ** 0.68 ) end if C Calculate Vertical to Horizontal Mass Flux Ratio C -- This is based on MB95 if ( Met_Data%clayf(c,r) < 0.2) then v2h = 10. ** (13.4 * Met_Data%clayf( c,r ) - 6.0) - else + else v2h = 4.0e-4 endif C Horizontal Flux @@ -1037,20 +833,20 @@ end subroutine tfabove & Met_Data%uthr( c,r ), & 1.0, ! ssm = 1 & Met_Data%dens1( c,r ) ) - - 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) - - end if ! if rain & land & snow & drag - - end do ! c - end do ! r - - else ! default dust scheme - + + 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) + + end if ! if rain & land & snow & drag + + end do ! c + end do ! r + + else ! default dust scheme + C---Get Julian day number in year jday = float( mod( jdate,1000 ) ) @@ -1083,7 +879,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 +891,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 +919,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 +965,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 +993,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 +1044,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 +1088,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 +1115,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 +1129,52 @@ end subroutine tfabove & out of total cells:', & dryhit, (c-1)*(r-1) #endif + end if !dust scheme - 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 ) - - do v = 1, ndust_spc - dustoutm( v,1,c,r ) = 0.0 - end do + edust( 1 ) = fracmj * dust_em( c,r ) + edust( 2 ) = fracmk * dust_em( c,r ) - 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 +1210,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 +1257,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 +1265,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 +1285,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 +1319,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,32 +1375,33 @@ function dust_hflux( ndp, dp, soiltxt, fmoit, fruf, ustr, sd_ep, dens ) end function dust_hflux - function dust_hflux_fengsha( ustar, fmoit, drag, uthr, ssm, dens ) + function dust_hflux_fengsha( ustar, fmoit, drag, uthr,ssm, dens ) & result( hflux ) implicit none include SUBST_CONST ! for grav - real, intent( in ) :: ustar, fmoit, drag, uthr, ssm, dens + real, intent( in ) :: ustar, fmoit, drag, uthr, ssm,dens real hflux real rustar 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 - + 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/PT3D_DEFN.F b/src/model/src/PT3D_DEFN.F index 0a7163d..39ed225 100644 --- a/src/model/src/PT3D_DEFN.F +++ b/src/model/src/PT3D_DEFN.F @@ -1,6 +1,6 @@ MODULE PT3D_DEFN - USE PT3D_DATA_MOD + !USE PT3D_DATA_MOD USE PT3D_FIRE_DEFN USE PT3D_STKS_DEFN @@ -8,31 +8,34 @@ MODULE PT3D_DEFN PRIVATE - PUBLIC PT3DEMIS, NPTGRPS, VDEMIS_PT, VDEMIS_PT_FIRE, PMEMIS_PT, - & PT3D_INIT, GET_PT3D_EMIS + PUBLIC PT3D_INIT, GET_PT3D_EMIS !, VDEMIS_PT + + CHARACTER( 16 ), ALLOCATABLE, SAVE :: STKENAME( : ) CONTAINS - FUNCTION PT3D_INIT ( N_SPC_EMIS, EMLAYS, JDATE, JTIME, TSTEP ) + FUNCTION PT3D_INIT ( JDATE, JTIME, TSTEP ) & RESULT ( SUCCESS ) USE GRID_CONF ! horizontal & vertical domain specifications - USE PTMAP - USE STK_EMIS, ONLY : STKSPC ! hourly point source emissions + USE STK_EMIS + USE DESID_VARS USE UTILIO_DEFN + USE PTBILIN, ONLY: NPTGRPS + USE RUNTIME_VARS IMPLICIT NONE - INTEGER, INTENT( IN ) :: N_SPC_EMIS ! total no. of model emissions species - INTEGER, INTENT( IN ) :: EMLAYS ! number of emissions layers +C INTEGER, INTENT( IN ) :: N_SPC_EMIS ! total no. of model emissions species +C INTEGER, INTENT( IN ) :: EMLAYS ! number of emissions layers INTEGER, INTENT( IN ) :: JDATE ! Julian date (YYYYDDD) INTEGER, INTENT( IN ) :: JTIME ! time (HHMMSS) INTEGER, INTENT( IN ) :: TSTEP ! output time step ! -- local variables INTEGER :: IOS - INTEGER :: N, S, V - INTEGER, ALLOCATABLE :: MAP( : ) + INTEGER :: N, ISRM, V +C INTEGER, ALLOCATABLE :: MAP( : ) CHARACTER( 240 ) :: XMSG = ' ' CHARACTER( 16 ) :: PNAME = 'PT3D_INIT ' ! procedure name @@ -44,78 +47,59 @@ FUNCTION PT3D_INIT ( N_SPC_EMIS, EMLAYS, JDATE, JTIME, TSTEP ) ! -- In-line 3D point source emissions? - PT3DEMIS = ENVYN( CTM_PT3DEMIS, - & 'Flag for in-line 3d point source emissions', - & .FALSE., IOS ) - IF ( PT3DEMIS ) THEN + IF ( NPTGRPS .GT. 0 ) THEN XMSG = 'Using in-line 3d point source emissions option' CALL M3MSG2( XMSG ) ELSE RETURN END IF - ! -- merge PM maps from fire and point-source emissions - IF ( .NOT. PTMAP_INIT( ) ) THEN - XMSG = 'Could not merge point source mappings' - CALL M3WARN ( PNAME, JDATE, JTIME, XMSG ) - SUCCESS = .FALSE.; RETURN - END IF +C Initialize stack emissions data + ALLOCATE ( STKENAME( NPTGRPS ), STAT = IOS ) ! stk emis files array + CALL CHECKMEM( IOS, 'STKENAME', PNAME ) + STKENAME = ' ' ! array - ! -- initialize emission types + ! Retrive Point Source Filenames from Emissions Filename Vector + DO N = 1, NPTGRPS + ISRM = MAP_PTtoISRM( N ) + STKENAME( N ) = DESID_STREAM_NAME( ISRM ) + END DO - IF ( .NOT. PT3D_FIRE_INIT ( N_SPC_EMIS, EMLAYS, JDATE, JTIME ) ) THEN - XMSG = 'Could not initialize fire emissions' + ! Initialize Point Source Emissions + IF ( .NOT. STK_EMIS_INIT( STKENAME, JDATE, JTIME ) ) THEN + XMSG = 'Could not initialize stack parameters' CALL M3WARN ( PNAME, JDATE, JTIME, XMSG ) SUCCESS = .FALSE.; RETURN END IF - IF ( .NOT. PT3D_STKS_INIT ( ) ) THEN - XMSG = 'Could not initialize point-source emissions' - CALL M3WARN ( PNAME, JDATE, JTIME, XMSG ) - SUCCESS = .FALSE.; RETURN - END IF - - ! -- allocate emission arrays - - ALLOCATE ( VDEMIS_PT( NCOLS, NROWS, EMLAYS, N_SPC_PTEM ), STAT = IOS ) - CALL CHECKMEM( IOS, 'VDEMIS_PT', PNAME ) - VDEMIS_PT = 0.0 ! array assignment - - ALLOCATE ( VDEMIS_PT_FIRE( NCOLS, NROWS, EMLAYS, N_SPC_PTEM ), STAT = IOS ) - CALL CHECKMEM( IOS, 'VDEMIS_PT_FIRE', PNAME ) - VDEMIS_PT_FIRE = 0.0 ! array assignment - - ALLOCATE ( PMEMIS_PT( NCOLS, NROWS, EMLAYS, N_SPC_PTPM ), STAT = IOS ) - CALL CHECKMEM( IOS, 'PMEMIS_PT', PNAME ) - PMEMIS_PT = 0.0 ! array - - ! -- get number of different file groups (sectors) - - NPTGRPS = 0 - - ! -- create point source internal array - - ALLOCATE( STKSPC( NPTGRPS ), STAT = IOS ) - CALL CHECKMEM( IOS, 'STKSPC', PNAME ) END FUNCTION PT3D_INIT - SUBROUTINE GET_PT3D_EMIS ( JDATE, JTIME, TSTEP ) + SUBROUTINE GET_PT3D_EMIS ( JDATE, JTIME, TSTEP,EMVAR_PT, ISRM, + & VDEMIS_PT, PTLAYS,L_DESID_DIAG) INTEGER, INTENT( IN ) :: JDATE, JTIME INTEGER, INTENT( IN ) :: TSTEP( 3 ) - -C ... initialize emission arrays ... - - VDEMIS_PT = 0.0 ! array assignment - VDEMIS_PT_FIRE = 0.0 ! array assignment - PMEMIS_PT = 0.0 ! array assignment - - CALL GET_PT3D_FIRE_EMIS ( JDATE, JTIME ) - CALL GET_PT3D_STKS_EMIS ( JDATE, JTIME ) + CHARACTER(16), INTENT( IN ) :: EMVAR_PT( : ) + INTEGER, INTENT( IN ) :: ISRM + + INTEGER, INTENT( OUT) :: PTLAYS + REAL, INTENT(INOUT) :: VDEMIS_PT( :,:,:,: ) + +! Local variables: + LOGICAL :: L_DESID_DIAG ! not really used + + + IF (ISRM == 2) !For Fire + & CALL GET_PT3D_FIRE_EMIS ( JDATE, JTIME, EMVAR_PT, ISRM, + & VDEMIS_PT, PTLAYS ) + + IF (ISRM == 3) !For point-source + & CALL GET_PT3D_STKS_EMIS ( JDATE, JTIME, EMVAR_PT, ISRM, + & VDEMIS_PT, PTLAYS ) END SUBROUTINE GET_PT3D_EMIS diff --git a/src/model/src/PT3D_FIRE_DEFN.F b/src/model/src/PT3D_FIRE_DEFN.F index 65fb0e6..8306838 100644 --- a/src/model/src/PT3D_FIRE_DEFN.F +++ b/src/model/src/PT3D_FIRE_DEFN.F @@ -1,23 +1,13 @@ MODULE PT3D_FIRE_DEFN - USE PT3D_DATA_MOD + ! USE PT3D_DATA_MOD IMPLICIT NONE - REAL, ALLOCATABLE :: VFRAC( :,:,: ) ! vertical fraction - REAL, ALLOCATABLE :: BUFFER( : ) ! emission buffer - -C Species names from input file used for point source non-PM emissions mapping - INTEGER, ALLOCATABLE :: PTEM_FIRE_MAP( : ) - INTEGER, ALLOCATABLE :: PTPM_FIRE_MAP( : ) C Emission layers for sources within domain INTEGER :: EMLYRS ! no. of emis layers - INTEGER :: PM_EMLYRS ! no. of emis layers for PM -C Emission counters - INTEGER :: N_GSPC_FIRE_EMIS ! number of gas species in diagnostic file - INTEGER :: N_SPC_FIRE_PTPM CHARACTER( 240 ) :: XMSG = ' ' @@ -29,100 +19,18 @@ MODULE PT3D_FIRE_DEFN PRIVATE - PUBLIC PT3D_FIRE_INIT, GET_PT3D_FIRE_EMIS + PUBLIC GET_PT3D_FIRE_EMIS CONTAINS C======================================================================= - FUNCTION PT3D_FIRE_INIT ( N_SPC_EMIS, EMLAYS, JDATE, JTIME ) - & RESULT ( SUCCESS ) - - USE AQM_EMIS_MOD - USE GRID_CONF ! horizontal & vertical domain specifications - USE CGRID_SPCS ! CGRID mechanism species - USE PTMAP ! defines pt src species mapping to VDEMIS* arrays - USE UTILIO_DEFN - - IMPLICIT NONE - -C Includes: -C None - -C Arguments: - INTEGER, INTENT( IN ) :: N_SPC_EMIS ! total no. of model emissions species - INTEGER, INTENT( IN ) :: EMLAYS ! number of emissions layers - INTEGER, INTENT( IN ) :: JDATE ! Julian date (YYYYDDD) - INTEGER, INTENT( IN ) :: JTIME ! time (HHMMSS) - - LOGICAL SUCCESS - -C Parameters: - -C Local Variables: - CHARACTER( 16 ) :: PNAME = 'PT3D_INIT ' ! procedure name - CHARACTER( 16 ) :: VNAME ! variable name buffer - CHARACTER( 16 ), SAVE, ALLOCATABLE :: STKGNAME( : ) ! stack groups file name - - INTEGER IOS ! i/o and allocate memory status - - - INTEGER IDX - INTEGER N, NSPC, NSPC1, NSPC2, NSPC3 - INTEGER S, S_OFFSET, V - - INTEGER, ALLOCATABLE :: MAP( : ) - INTEGER, ALLOCATABLE :: SPC_PTEM_FIRE_FAC( : ) - INTEGER, ALLOCATABLE :: SPC_PTEM_FIRE_MAP( : ) - - TYPE( AQM_INTERNAL_EMIS_TYPE ), POINTER :: EM - -C----------------------------------------------------------------------- - - SUCCESS = .TRUE. - -C check if emissions are being provided - - EM => AQM_EMIS_GET( ETYPE ) - IF ( .NOT.ASSOCIATED( EM ) ) RETURN - -C set number of emissions layers depending on whether plumerise is on - - CALL AQM_EMIS_DESC( ETYPE, NLAYS=EMLYRS ) - PM_EMLYRS = EMLYRS - -C get point source emission mapping - - IF (.NOT.PTMAP_TYPE_INIT( EM, - & N_GSPC_FIRE_EMIS, N_SPC_FIRE_PTPM, - & PTEM_FIRE_MAP, PTPM_FIRE_MAP, - & SPC_PTEM_FIRE_FAC, SPC_PTEM_FIRE_MAP, - & "FIRE" ) ) THEN - XMSG = 'Could not get point source mappings' - CALL M3WARN ( PNAME, JDATE, JTIME, XMSG ) - SUCCESS = .FALSE.; RETURN - END IF - - DEALLOCATE( SPC_PTEM_FIRE_FAC, SPC_PTEM_FIRE_MAP ) - ALLOCATE ( VFRAC( NCOLS,NROWS,EMLYRS ), STAT = IOS ) - CALL CHECKMEM( IOS, 'VFRAC', PNAME ) - VFRAC = 1.0 ! array - - ALLOCATE ( BUFFER( NCOLS * NROWS ), STAT = IOS ) - CALL CHECKMEM( IOS, 'BUFFER', PNAME ) - BUFFER = 0.0 ! array - - SUCCESS = .TRUE.; RETURN - - END FUNCTION PT3D_FIRE_INIT - -C======================================================================= - - SUBROUTINE GET_PT3D_FIRE_EMIS ( JDATE, JTIME ) + SUBROUTINE GET_PT3D_FIRE_EMIS ( JDATE, JTIME, EMVAR_PT, ISRM, + & VDEMIS_PT, PTLAYS ) ! Revision History. -! Aug 12, 15 D. Wong: added code to handle parallel I/O implementation +! Oct 20, 23 Wei Li: change to use DESID mapping C----------------------------------------------------------------------- @@ -134,19 +42,22 @@ SUBROUTINE GET_PT3D_FIRE_EMIS ( JDATE, JTIME ) USE RXNS_DATA, ONLY : MECHNAME !Get Chemical Mechanism Name USE GRID_CONF ! horizontal & vertical domain specifications USE CGRID_SPCS ! CGRID mechanism species - USE AERO_DATA, ONLY : PMEM_MAP_NAME - USE PTMAP ! defines pt src species mapping to VDEMIS* arrays + USE DESID_VARS, ONLY : DESID_N_ISTR USE UTILIO_DEFN + USE RUNTIME_VARS, only: LOGDEV IMPLICIT NONE C Arguments: INTEGER, INTENT( IN ) :: JDATE, JTIME - + CHARACTER(16), INTENT( IN ) :: EMVAR_PT( : ) + INTEGER, INTENT( IN ) :: ISRM + INTEGER, INTENT( OUT) :: PTLAYS + REAL, INTENT(INOUT) :: VDEMIS_PT( :,:,:,: ) C Parameters: C External functions: - INTEGER, EXTERNAL :: SETUP_LOGDEV +C INTEGER, EXTERNAL :: SETUP_LOGDEV C Local variables: CHARACTER( 16 ) :: PNAME = 'GET_PT3D_EMIS ' ! procedure name @@ -154,33 +65,47 @@ SUBROUTINE GET_PT3D_FIRE_EMIS ( JDATE, JTIME ) INTEGER IOS ! i/o and allocate memory status INTEGER L, S, V ! counters - INTEGER C, R, K, M, N + INTEGER C, R, K, M, N, NSPC INTEGER LOCALRC + REAL, ALLOCATABLE :: VFRAC( :,:,: ) ! vertical fraction + REAL, ALLOCATABLE :: BUFFER( : ) ! emission buffe + LOGICAL :: IS_NOT_NVPOA, SAVE_POC LOGICAL, SAVE :: FIRSTIME = .TRUE. - INTEGER, SAVE :: LOGDEV +C INTEGER, SAVE :: LOGDEV TYPE( AQM_INTERNAL_EMIS_TYPE ), POINTER :: EM C----------------------------------------------------------------------- - IF ( FIRSTIME ) THEN - FIRSTIME = .FALSE. - LOGDEV = SETUP_LOGDEV() - END IF +C IF ( FIRSTIME ) THEN +C FIRSTIME = .FALSE. +C LOGDEV = SETUP_LOGDEV() +C END IF + NULLIFY(EM) EM => AQM_EMIS_GET( ETYPE ) IF ( .NOT.ASSOCIATED( EM ) ) RETURN - + !number of species in this emission file + NSPC = SIZE( EM % TABLE, DIM=1 ) + CALL AQM_EMIS_DESC( ETYPE, NLAYS=EMLYRS ) + PTLAYS = EMLYRS C For each time step, compute the layer fractions... WRITE( XMSG,'(A, I7.6)' ) - & 'Calculating emissions point source layer fractions for', JTIME + & 'Calculating emissions point source layer fractions for',JTIME WRITE( LOGDEV,* ) ' ' CALL M3MSG2( XMSG ) + ALLOCATE ( VFRAC( NCOLS,NROWS,EMLYRS ), STAT = IOS ) + CALL CHECKMEM( IOS, 'VFRAC', PNAME ) + + ALLOCATE ( BUFFER( NCOLS * NROWS ), STAT = IOS ) + CALL CHECKMEM( IOS, 'BUFFER', PNAME ) + BUFFER = 0.0 ! array + C ... initialize vertical fraction arrays ... C ... fire emissions are added to surface only by default ... @@ -221,11 +146,12 @@ SUBROUTINE GET_PT3D_FIRE_EMIS ( JDATE, JTIME ) IS_NOT_NVPOA = ( INDEX( MECHNAME, 'NVPOA' ) .EQ. 0 ) - DO S = 1, N_GSPC_FIRE_EMIS - M = PTEM_FIRE_MAP( S ) + DO S = 1, DESID_N_ISTR + VNAME = EMVAR_PT( S ) + IF ( VNAME .EQ. '' ) CYCLE + M = INDEX1( VNAME, NSPC, EM % TABLE( :, 1 ) ) + IF ( M .GT. 0 ) THEN - N = PTEM_MAP( S ) -c IF ( N .GT. 0 ) THEN BUFFER = 0.0 CALL AQM_EMIS_READ( ETYPE, EM % TABLE( M, 1 ), & BUFFER, RC=LOCALRC ) @@ -234,58 +160,39 @@ SUBROUTINE GET_PT3D_FIRE_EMIS ( JDATE, JTIME ) & // TRIM( ETYPE ) // " emissions", & FILE=__FILE__, LINE=__LINE__)) RETURN C Read Non-Carbon Organic Matter too if POC is Requested - SAVE_POC = .FALSE. - IF ( IS_NOT_NVPOA .AND. EM % TABLE( M, 1 ) .EQ. 'POC' ) THEN - CALL AQM_EMIS_READ( ETYPE, 'PNCOM', BUFFER, RC=LOCALRC ) - IF ( AQM_RC_CHECK( LOCALRC, - & MSG="Failure while reading PNCOM" // - & " from " // TRIM( ETYPE ) // " emissions", - & FILE=__FILE__, LINE=__LINE__)) RETURN - SAVE_POC = IS_NOT_NVPOA - END IF - DO L = 1, EMLYRS +C SAVE_POC = .FALSE. +C IF ( IS_NOT_NVPOA .AND. EM % TABLE( M, 1 ) .EQ. 'POC' ) THEN +C CALL AQM_EMIS_READ( ETYPE, 'PNCOM', BUFFER, RC=LOCALRC ) +C IF ( AQM_RC_CHECK( LOCALRC, +C & MSG="Failure while reading PNCOM" // +C & " from " // TRIM( ETYPE ) // " emissions", +C & FILE=__FILE__, LINE=__LINE__)) RETURN +C SAVE_POC = IS_NOT_NVPOA +C END IF + DO L = 1, PTLAYS K = 0 - DO R = 1, MY_NROWS - DO C = 1, MY_NCOLS + DO R = 1, NROWS + DO C = 1, NCOLS K = K + 1 - VDEMIS_PT( C,R,L,N ) = VFRAC( C,R,L ) * BUFFER( K ) + VDEMIS_PT(S,L,C,R) = VFRAC( C,R,L ) * BUFFER( K ) END DO END DO END DO - IF ( SAVE_POC ) THEN - DO L = 1, EMLYRS - K = 0 - DO R = 1, MY_NROWS - DO C = 1, MY_NCOLS - K = K + 1 - VDEMIS_PT_FIRE( C,R,L,N ) = VDEMIS_PT( C,R,L,N ) - END DO - END DO - END DO - END IF + ! IF ( SAVE_POC ) THEN !comment out this for now + ! DO L = 1, PTLAYS + ! K = 0 + ! DO R = 1, NROWS + ! DO C = 1, NCOLS + ! K = K + 1 + ! VDEMIS_PT(S,L,C,R) = VDEMIS_PT(S,L,C,R) + VDEMIS_PT( S,L,C,R ) + ! END DO + ! END DO + ! END DO + ! END IF END IF END DO - -C ... aerosol species ... - - DO S = 1, N_SPC_FIRE_PTPM - N = PTPM_FIRE_MAP( S ) - V = PTPM_MAP( N ) - BUFFER = 0.0 - CALL AQM_EMIS_READ( ETYPE, PMEM_MAP_NAME( V ), BUFFER, RC=LOCALRC ) - IF ( AQM_RC_CHECK( LOCALRC, MSG="Failure while reading " // - & TRIM( PMEM_MAP_NAME( V ) ) // " from " // TRIM( ETYPE ) // " emissions", - & FILE=__FILE__, LINE=__LINE__)) RETURN - DO L = 1, PM_EMLYRS - K = 0 - DO R = 1, MY_NROWS - DO C = 1, MY_NCOLS - K = K + 1 - PMEMIS_PT( C,R,L,N ) = VFRAC( C,R,L ) * BUFFER( K ) - END DO - END DO - END DO - END DO + ! DEALLOCATE temporary variables + DEALLOCATE ( BUFFER, VFRAC ) RETURN diff --git a/src/model/src/PT3D_STKS_DEFN.F b/src/model/src/PT3D_STKS_DEFN.F index 3a0cf2a..beccab0 100644 --- a/src/model/src/PT3D_STKS_DEFN.F +++ b/src/model/src/PT3D_STKS_DEFN.F @@ -1,20 +1,12 @@ MODULE PT3D_STKS_DEFN USE GRID_CONF ! horizontal & vertical domain specifications - USE PTMAP + !USE PT3D_DATA_MOD USE AQM_EMIS_MOD, ONLY : AQM_EMIS_DESC, AQM_EMIS_GET, & AQM_EMIS_READ, AQM_INTERNAL_EMIS_TYPE IMPLICIT NONE - INTEGER :: N_GSPC_STKS_EMIS - INTEGER :: N_SPC_PT3DEM - INTEGER :: N_SPC_STKS_PTPM - - INTEGER, ALLOCATABLE :: SPC_PTEM_STKS_FAC( : ) - INTEGER, ALLOCATABLE :: SPC_PTEM_STKS_MAP( : ) - INTEGER, ALLOCATABLE :: PTEM_STKS_MAP( : ) - INTEGER, ALLOCATABLE :: PTPM_STKS_MAP( : ) REAL :: CNVTP ! intermediate combined conv. factor @@ -23,19 +15,19 @@ MODULE PT3D_STKS_DEFN PRIVATE - PUBLIC :: N_SPC_STKS_PTPM, PTPM_STKS_MAP - PUBLIC :: GET_PT3D_STKS_EMIS, PT3D_STKS_INIT + PUBLIC :: GET_PT3D_STKS_EMIS !, PT3D_STKS_INIT CONTAINS - SUBROUTINE GET_PT3D_STKS_EMIS( JDATE, JTIME ) + SUBROUTINE GET_PT3D_STKS_EMIS( JDATE, JTIME, EMVAR_PT, ISRM, + & VDEMIS_PT, PTLAYS ) USE CGRID_SPCS ! CGRID mechanism species USE UTILIO_DEFN USE AQM_RC_MOD - USE AERO_DATA, ONLY : PMEM_MAP_NAME USE ASX_DATA_MOD, ONLY: MET_DATA, GRID_DATA, CONVPA - USE PT3D_DATA_MOD + USE DESID_VARS, ONLY : DESID_N_ISTR + USE RUNTIME_VARS, only: LOGDEV IMPLICIT NONE @@ -46,19 +38,23 @@ SUBROUTINE GET_PT3D_STKS_EMIS( JDATE, JTIME ) C Arguments: INTEGER, INTENT( IN ) :: JDATE ! Julian date (YYYYDDD) INTEGER, INTENT( IN ) :: JTIME ! time (HHMMSS) + CHARACTER(16), INTENT( IN ) :: EMVAR_PT( : ) + INTEGER, INTENT( IN ) :: ISRM + INTEGER, INTENT( OUT) :: PTLAYS + REAL, INTENT(INOUT) :: VDEMIS_PT( :,:,:,: ) C External Functions: - INTEGER, EXTERNAL :: SETUP_LOGDEV +C INTEGER, EXTERNAL :: SETUP_LOGDEV C Local Variables: - INTEGER :: LOGDEV +C INTEGER :: LOGDEV INTEGER :: C, R, L, M, N, S, V, K, I ! loop induction variables INTEGER :: LBOT ! layer containing plume bottom INTEGER :: LTOP ! layer containing plume top INTEGER :: LPBL ! first L: ZF(L) above mixing layer - ONLY for REPORT INTEGER :: LSTK ! first L: ZF(L) > STKHT INTEGER :: IJ, IS - INTEGER :: NSRC, NP + INTEGER :: NSRC, NP, NSPC INTEGER :: IOS, LOCALRC INTEGER, POINTER :: IP( : ) INTEGER, POINTER :: JP( : ) @@ -92,6 +88,7 @@ SUBROUTINE GET_PT3D_STKS_EMIS( JDATE, JTIME ) REAL, PARAMETER :: USTARMIN = 0.1 ! Min valid value for USTAR CHARACTER( 8 ) :: CINT ! integer to character buffer for Cwarning messages CHARACTER( 16 ) :: PNAME = 'GET_PT3D_EMIS' + CHARACTER( 16 ) :: VNAME ! variable name buffer CHARACTER( 120 ) :: XMSG = ' ' CHARACTER( 10 ), PARAMETER :: BLANK10 = ' ' @@ -165,6 +162,7 @@ END SUBROUTINE PLSPRD C----------------------------------------------------------------------- + NULLIFY(EM) EM => AQM_EMIS_GET( ETYPE ) IF ( .NOT.ASSOCIATED( EM ) ) RETURN @@ -172,14 +170,16 @@ END SUBROUTINE PLSPRD IF ( FIRSTIME ) THEN - LOGDEV = SETUP_LOGDEV() +C LOGDEV = SETUP_LOGDEV() C set number of emissions layers depending on whether plumerise is on CALL AQM_EMIS_DESC( ETYPE, NLAYS=EMLYRS ) - + FIRSTIME = .FALSE. END IF + + PTLAYS = EMLYRS C Allocate Buffer space for Reading Emissions NSRC = SIZE( EM % IJMAP ) @@ -400,13 +400,14 @@ END SUBROUTINE PLSPRD DEALLOCATE ( TFRAC ) - ! -- (1) non-PM emissions - - DO S = 1, N_GSPC_STKS_EMIS - M = PTEM_STKS_MAP( S ) + ! use DESID_N_ISTR instead of PTMAP + NSPC = SIZE( EM % TABLE, DIM=1 ) + DO S = 1, DESID_N_ISTR + VNAME = EMVAR_PT( S ) + IF ( VNAME .EQ. '' ) CYCLE + M = INDEX1( VNAME, NSPC, EM % TABLE( :, 1 ) ) IF ( M .LT. 1 ) CYCLE - N = PTEM_MAP( S ) - +C N = PTEM_MAP( S ) BUFFER = 0.0 CALL AQM_EMIS_READ( ETYPE, EM % TABLE( M, 1 ), BUFFER, RC=LOCALRC) IF ( AQM_RC_CHECK( LOCALRC, @@ -414,46 +415,26 @@ END SUBROUTINE PLSPRD & TRIM( EM % TABLE( M, 1 ) ) // " from " // & TRIM( ETYPE ) // " emissions", & FILE=__FILE__, LINE=__LINE__ ) ) RETURN - IF ( EM % TABLE( M, 1 ) .EQ. 'POC' ) THEN - CALL AQM_EMIS_READ( ETYPE, 'PNCOM', BUFFER, RC=LOCALRC) - IF ( AQM_RC_CHECK( LOCALRC, - & MSG="Failure while reading PNCOM emissions from" // - & TRIM( ETYPE ) // " emissions", - & FILE=__FILE__, LINE=__LINE__ ) ) RETURN - END IF +C IF ( EM % TABLE( M, 1 ) .EQ. 'POC' ) THEN +C CALL AQM_EMIS_READ( ETYPE, 'PNCOM', BUFFER, RC=LOCALRC) +C IF ( AQM_RC_CHECK( LOCALRC, +C & MSG="Failure while reading PNCOM emissions from" // +C & TRIM( ETYPE ) // " emissions", +C & FILE=__FILE__, LINE=__LINE__ ) ) RETURN +C END IF ! -- add emissions - DO L = 1, EMLYRS + DO L = 1, PTLAYS DO IS = 1, NSRC IJ = EM % IJMAP( IS ) C = EM % IP( IJ ) R = EM % JP( IJ ) - VDEMIS_PT( C,R,L,N ) = VDEMIS_PT( C,R,L,N ) + VDEMIS_PT( S,L,C,R ) = VDEMIS_PT( S,L,C,R ) & + VFRAC( IS, L ) * BUFFER( IJ ) END DO END DO END DO - ! -- (2) PM emissions - - DO S = 1, N_SPC_STKS_PTPM - N = PTPM_STKS_MAP( S ) - V = PTPM_MAP( N ) - BUFFER = 0.0 - CALL AQM_EMIS_READ( ETYPE, PMEM_MAP_NAME( V ), BUFFER, RC=LOCALRC ) - IF ( AQM_RC_CHECK( LOCALRC, MSG="Failure while reading " // - & TRIM( PMEM_MAP_NAME( V ) ) // " from " // TRIM( ETYPE ) // " emissions", - & FILE=__FILE__, LINE=__LINE__)) RETURN - DO L = 1, EMLYRS - DO IS = 1, NSRC - IJ = EM % IJMAP( IS ) - C = EM % IP( IJ ) - R = EM % JP( IJ ) - PMEMIS_PT( C,R,L,N ) = PMEMIS_PT( C,R,L,N ) - & + VFRAC( IS, L ) * BUFFER( IJ ) - END DO - END DO - END DO ! -- free up memory @@ -470,32 +451,4 @@ END SUBROUTINE PLSPRD END SUBROUTINE GET_PT3D_STKS_EMIS - FUNCTION PT3D_STKS_INIT( ) RESULT ( SUCCESS ) - - USE AQM_RC_MOD, ONLY: AQM_RC_TEST - - TYPE( AQM_INTERNAL_EMIS_TYPE ), POINTER :: EM - - LOGICAL :: SUCCESS - - SUCCESS = .TRUE. - - EM => AQM_EMIS_GET( ETYPE ) - IF ( .NOT.ASSOCIATED( EM ) ) RETURN - - IF (EM % COUNT == 0) RETURN - - SUCCESS = PTMAP_TYPE_INIT( EM, - & N_GSPC_STKS_EMIS, N_SPC_STKS_PTPM, - & PTEM_STKS_MAP, PTPM_STKS_MAP, - & SPC_PTEM_STKS_FAC, SPC_PTEM_STKS_MAP, - & "STKS" ) - - IF ( AQM_RC_TEST( .NOT. SUCCESS, - & MSG="Failure initializing mapping for" // - & TRIM( ETYPE ) // " emissions", - & FILE=__FILE__, LINE=__LINE__ ) ) RETURN - - END FUNCTION PT3D_STKS_INIT - END MODULE PT3D_STKS_DEFN diff --git a/src/model/src/PTMAP.F b/src/model/src/PTMAP.F deleted file mode 100644 index 8d651a6..0000000 --- a/src/model/src/PTMAP.F +++ /dev/null @@ -1,341 +0,0 @@ - MODULE PTMAP - - IMPLICIT NONE - - INTEGER, SAVE :: N_GSPC_EMIS = 0 ! number of gas species in diagnostic file - -C Species names from input file used for point source non-PM emissions mapping - INTEGER, ALLOCATABLE, SAVE :: PTEM_MAP( : ) - INTEGER, ALLOCATABLE, SAVE :: SPC_PTEM_MAP( : ) - REAL, ALLOCATABLE, SAVE :: SPC_PTEM_FAC( : ) - -C Species names from input file used for point source PM emissions mapping - INTEGER, ALLOCATABLE, SAVE :: PTPM_MAP( : ) - -C Mapping for point source non-PM emissions (maps only GC, NR and TR) - INTEGER, SAVE :: N_SPC_PTEM = 0 ! merged no. of unique species - INTEGER, SAVE :: N_SPC_PTPM = 0 ! merged no. of unique species for PM - - PRIVATE - - PUBLIC :: N_GSPC_EMIS, N_SPC_PTEM, N_SPC_PTPM - PUBLIC :: SPC_PTEM_FAC, SPC_PTEM_MAP - PUBLIC :: PTEM_MAP, PTPM_MAP - - PUBLIC :: PTMAP_INIT - PUBLIC :: PTMAP_TYPE_INIT - - CONTAINS - - FUNCTION PTMAP_INIT ( ) RESULT ( SUCCESS ) - - USE CGRID_SPCS ! CGRID mechanism species - USE AERO_DATA, ONLY : N_EMIS_PM, PMEM_MAP_NAME ! defines aerosol species - USE AQM_EMIS_MOD, ONLY : AQM_EMIS_GET, AQM_EMIS_ISPRESENT, - & AQM_INTERNAL_EMIS_TYPE - USE UTILIO_DEFN - - IMPLICIT NONE - - LOGICAL SUCCESS - - INTEGER I, IDX, IOS, IPT, NPT - INTEGER N, N_GAS_EMIS, NSPC, NSPC1, NSPC2, NSPC3 - INTEGER S, S_OFFSET, V - - INTEGER, ALLOCATABLE :: MAP( : ) - CHARACTER( 16 ), ALLOCATABLE :: EMSPC( : ) - - TYPE PT_EMIS_TYPE - TYPE( AQM_INTERNAL_EMIS_TYPE ), POINTER :: EM - END TYPE PT_EMIS_TYPE - - TYPE( PT_EMIS_TYPE ) :: PT( 2 ) - - CHARACTER( * ), PARAMETER :: PNAME = 'PTMAP_INIT' ! procedure name - - CHARACTER( * ), PARAMETER :: ETYPES( 2 ) = - & (/ 'gbbepx ', 'point-source' /) - -C----------------------------------------------------------------------- - - SUCCESS = .TRUE. - -C check if emissions are being provided - - NPT = SIZE( ETYPES ) - - I = 0 - NSPC = 0 - DO IPT = 1, NPT - IF ( AQM_EMIS_ISPRESENT( ETYPES( IPT ) ) ) THEN - I = I + 1 - PT( I ) % EM => AQM_EMIS_GET( ETYPES( IPT ) ) - NSPC = NSPC + SIZE( PT( I ) % EM % TABLE, DIM=1 ) - END IF - END DO - - IF ( I == 0 ) RETURN - - NPT = I - - ALLOCATE ( EMSPC( NSPC ), STAT = IOS ) - CALL CHECKMEM( IOS, 'EMSPC', PNAME ) - MAP = 0 - - EMSPC = "" - - ! -- merge emission tables and remove duplicates - - I = 0 - DO IPT = 1, NPT - DO N = 1, SIZE( PT( IPT ) % EM % TABLE, DIM=1 ) - IDX = INDEX1( TRIM( PT( IPT ) % EM % TABLE( N, 1 ) ), NSPC, EMSPC ) - IF ( IDX .LE. 0 ) THEN - I = I + 1 - EMSPC( I ) = PT( IPT ) % EM % TABLE( N, 1 ) - END IF - END DO - END DO - - NSPC = I - -C compute emission offsets - - NSPC1 = N_GC_EMIS - NSPC2 = NSPC1 + N_AE_EMIS - NSPC3 = NSPC2 + N_NR_EMIS - -C create auxiliary arrays mapping fire emission species to CMAQ gas and aerosol species - - ALLOCATE( MAP( NSPC ), STAT = IOS ) - CALL CHECKMEM( IOS, 'MAP', PNAME ) - MAP = 0 - -C ... gas species ... - - NSPC1 = N_GC_EMIS - NSPC2 = NSPC1 + N_AE_EMIS - NSPC3 = NSPC2 + N_NR_EMIS - - N_GAS_EMIS = N_GC_EMIS + N_NR_EMIS + N_TR_EMIS - - ALLOCATE( SPC_PTEM_FAC( N_GAS_EMIS ), STAT = IOS ) - CALL CHECKMEM( IOS, 'SPC_PTEM_FAC', PNAME ) - SPC_PTEM_FAC = 1.0 - - ALLOCATE( SPC_PTEM_MAP( N_GAS_EMIS ), STAT = IOS ) - CALL CHECKMEM( IOS, 'SPC_PTEM_MAP', PNAME ) - SPC_PTEM_MAP = -1 - - ALLOCATE( PTEM_MAP( N_GAS_EMIS ), STAT = IOS ) - CALL CHECKMEM( IOS, 'PTEM_MAP', PNAME ) - PTEM_MAP = -1 - - N = 0 - - S_OFFSET = 0 - DO S = 1, N_GC_EMIS - IDX = INDEX1( GC_EMIS( S ), NSPC, EMSPC ) - IF ( IDX .GT. 0 ) THEN - N = N + 1 - PTEM_MAP ( S ) = N - SPC_PTEM_MAP( S ) = S - SPC_PTEM_FAC( S ) = GC_EMIS_FAC( S ) - END IF - END DO - - S_OFFSET = N_GC_EMIS - DO S = 1, N_NR_EMIS - IDX = INDEX1( NR_EMIS( S ), NSPC, EMSPC ) - IF ( IDX .GT. 0 ) THEN - N = N + 1 - V = S + S_OFFSET - PTEM_MAP ( V ) = N - SPC_PTEM_MAP( V ) = S + NSPC2 - SPC_PTEM_FAC( V ) = NR_EMIS_FAC( S ) - END IF - END DO - - S_OFFSET = S_OFFSET + N_NR_EMIS - DO S = 1, N_TR_EMIS - IDX = INDEX1( TR_EMIS( S ), NSPC, EMSPC ) - IF ( IDX .GT. 0 ) THEN - N = N + 1 - V = S + S_OFFSET - PTEM_MAP ( V ) = N - SPC_PTEM_MAP( V ) = S + NSPC3 - SPC_PTEM_FAC( V ) = TR_EMIS_FAC( S ) - END IF - END DO - - N_SPC_PTEM = N - N_GSPC_EMIS = N_GAS_EMIS - -C ... aerosol species ... - - N = 0 - DO S = 1, NSPC - IDX = INDEX1( EMSPC( S ), N_EMIS_PM, PMEM_MAP_NAME ) - IF ( IDX .GT. 0 ) THEN - N = N + 1 - MAP( N ) = IDX - END IF - END DO - - N_SPC_PTPM = N - - ALLOCATE( PTPM_MAP( N_SPC_PTPM ), STAT = IOS ) - CALL CHECKMEM( IOS, 'PTPM_MAP', PNAME ) - PTPM_MAP = MAP( 1:N_SPC_PTPM ) - - DEALLOCATE( EMSPC, MAP ) - - END FUNCTION PTMAP_INIT - - - FUNCTION PTMAP_TYPE_INIT( EM, - & N_GSPC_TYPE_EMIS, N_SPC_TYPE_PTPM, - & PTEM_TYPE_MAP, PTPM_TYPE_MAP, - & SPC_PTEM_TYPE_FAC, SPC_PTEM_TYPE_MAP, - & ELABEL ) - & RESULT ( SUCCESS ) - - - USE CGRID_SPCS ! CGRID mechanism species - USE AERO_DATA, ONLY : N_EMIS_PM, PMEM_MAP_NAME ! defines aerosol species - USE AQM_EMIS_MOD, ONLY : AQM_INTERNAL_EMIS_TYPE - USE UTILIO_DEFN - - IMPLICIT NONE - - ! -- arguments - - TYPE( AQM_INTERNAL_EMIS_TYPE ), POINTER :: EM - INTEGER, INTENT( OUT ) :: N_GSPC_TYPE_EMIS - INTEGER, INTENT( OUT ) :: N_SPC_TYPE_PTPM - INTEGER, ALLOCATABLE, INTENT( OUT ) :: PTEM_TYPE_MAP( : ) - INTEGER, ALLOCATABLE, INTENT( OUT ) :: PTPM_TYPE_MAP( : ) - INTEGER, ALLOCATABLE, INTENT( OUT ) :: SPC_PTEM_TYPE_FAC( : ) - INTEGER, ALLOCATABLE, INTENT( OUT ) :: SPC_PTEM_TYPE_MAP( : ) - CHARACTER( * ), INTENT( IN ) :: ELABEL - - ! -- local variables - - LOGICAL SUCCESS - - INTEGER IOS - - INTEGER IDX - INTEGER N, N_GAS_EMIS, NSPC, NSPC1, NSPC2, NSPC3 - INTEGER S, S_OFFSET, V - - INTEGER, ALLOCATABLE :: MAP( : ) - - CHARACTER( * ), PARAMETER :: PNAME = 'PTEM_TYPE_MAP' ! procedure name - -C----------------------------------------------------------------------- - - SUCCESS = .TRUE. - - N_GSPC_TYPE_EMIS = 0 - N_SPC_TYPE_PTPM = 0 - - IF ( .NOT.ASSOCIATED( EM ) ) RETURN - -C compute emission offsets - - NSPC1 = N_GC_EMIS - NSPC2 = NSPC1 + N_AE_EMIS - NSPC3 = NSPC2 + N_NR_EMIS - -C create auxiliary arrays mapping fire emission species to CMAQ gas and aerosol species - - NSPC = SIZE( EM % TABLE, DIM=1 ) - - ALLOCATE( MAP( NSPC ), STAT = IOS ) - CALL CHECKMEM( IOS, 'MAP: ' // TRIM( ELABEL ), PNAME ) - MAP = 0 - -C ... gas species ... - - NSPC1 = N_GC_EMIS - NSPC2 = NSPC1 + N_AE_EMIS - NSPC3 = NSPC2 + N_NR_EMIS - - N_GAS_EMIS = N_GC_EMIS + N_NR_EMIS + N_TR_EMIS - - ALLOCATE( SPC_PTEM_TYPE_FAC( N_GAS_EMIS ), STAT = IOS ) - CALL CHECKMEM( IOS, 'SPC_PTEM_TYPE_FAC: ' // TRIM( ELABEL ), PNAME ) - SPC_PTEM_TYPE_FAC = 1.0 - - ALLOCATE( SPC_PTEM_TYPE_MAP( N_GAS_EMIS ), STAT = IOS ) - CALL CHECKMEM( IOS, 'SPC_PTEM_TYPE_MAP: ' // TRIM( ELABEL ), PNAME ) - SPC_PTEM_TYPE_MAP = -1 - - ALLOCATE( PTEM_TYPE_MAP( N_GAS_EMIS ), STAT = IOS ) - CALL CHECKMEM( IOS, 'PTEM_TYPE_MAP: ' // TRIM( ELABEL ), PNAME ) - PTEM_TYPE_MAP = -1 - - N = 0 - - S_OFFSET = 0 - DO S = 1, N_GC_EMIS - IDX = INDEX1( GC_EMIS( S ), NSPC, EM % TABLE( 1, 1 ) ) - IF ( IDX .GT. 0 ) THEN - N = N + 1 - PTEM_TYPE_MAP ( S ) = IDX - SPC_PTEM_TYPE_MAP( S ) = S - SPC_PTEM_TYPE_FAC( S ) = GC_EMIS_FAC( S ) - END IF - END DO - - S_OFFSET = N_GC_EMIS - DO S = 1, N_NR_EMIS - IDX = INDEX1( NR_EMIS( S ), NSPC, EM % TABLE( 1, 1 ) ) - IF ( IDX .GT. 0 ) THEN - N = N + 1 - V = S + S_OFFSET - PTEM_TYPE_MAP ( V ) = IDX - SPC_PTEM_TYPE_MAP( V ) = S + NSPC2 - SPC_PTEM_TYPE_FAC( V ) = NR_EMIS_FAC( S ) - END IF - END DO - - S_OFFSET = S_OFFSET + N_NR_EMIS - DO S = 1, N_TR_EMIS - IDX = INDEX1( TR_EMIS( S ), NSPC, EM % TABLE( 1, 1 ) ) - IF ( IDX .GT. 0 ) THEN - N = N + 1 - V = S + S_OFFSET - PTEM_TYPE_MAP ( V ) = IDX - SPC_PTEM_TYPE_MAP( V ) = S + NSPC3 - SPC_PTEM_TYPE_FAC( V ) = TR_EMIS_FAC( S ) - END IF - END DO - - N_GSPC_TYPE_EMIS = N - -C ... aerosol species ... - - N = 0 - DO S = 1, N_SPC_PTPM - V = PTPM_MAP( S ) - IDX = INDEX1( PMEM_MAP_NAME( V ), NSPC, EM % TABLE( 1, 1 ) ) - IF ( IDX .GT. 0 ) THEN - N = N + 1 - MAP( N ) = S - END IF - END DO - - N_SPC_TYPE_PTPM = N - - ALLOCATE( PTPM_TYPE_MAP( N_SPC_TYPE_PTPM ), STAT = IOS ) - CALL CHECKMEM( IOS, 'PTPM_TYPE_MAP: '// TRIM( ELABEL ), PNAME ) - PTPM_TYPE_MAP = MAP( 1:N_SPC_TYPE_PTPM ) - - DEALLOCATE( MAP ) - - END FUNCTION PTMAP_TYPE_INIT - - END MODULE PTMAP diff --git a/src/model/src/RUNTIME_VARS.F b/src/model/src/RUNTIME_VARS.F new file mode 100644 index 0000000..0a4d5b0 --- /dev/null +++ b/src/model/src/RUNTIME_VARS.F @@ -0,0 +1,1203 @@ + +!------------------------------------------------------------------------! +! 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 = -1 ! File Unit for Standard Output (AQM change from 6) + 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. + + !----------------------------------------------------------------------------------- + !>> 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 = 1 !(AQM change from 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() !comment out Otherwise will crash (AQM) + 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 + + ! comment out since we do not have DMS emissions (AQM) + !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 + !Need to comment out for aqm_dev branch (AQM) + !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 0000000..c0605e6 --- /dev/null +++ b/src/model/src/centralized_io_module.F @@ -0,0 +1,7002 @@ +!------------------------------------------------------------------------! +! 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 + use mio_module +#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, !public this function (AQM) + & 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 + 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 + + !called somewhere else (AQM) + !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 + 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 !end v + +#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 + use centralized_io_util_module, only : quicksort + use util_module, only : index1 + use RUNTIME_VARS, only : emis_sym_date + + use mydata_module + + 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, 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 !(AQM) + + !call stack_files_setup !(AQM) + + 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) !(AQM) + + !call retrieve_stack_data (cio_model_sdate, cio_model_stime) !(AQM) +#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 + + !add to log + !write(-1,*)'loc_head and tail:',loc_head,loc_tail,var_loc,loc_tstep,time2sec(loc_tstep) + !write(-1,*)'cio_grid_data_tstamp(1, 2,var_loc):',cio_grid_data_tstamp(1, 2, var_loc) + !write(-1,*)'cio_grid_data_tstamp(2,2,var_loc):',cio_grid_data_tstamp(2, 2, var_loc) + !write(-1,*)'cio_grid_data_tstamp(1, loc_head, var_loc)',cio_grid_data_tstamp(1, loc_head, var_loc) + !write(-1,*)'cio_grid_data_tstamp(2, loc_head,var_loc)',cio_grid_data_tstamp(2, loc_head, var_loc) + !write(-1,*)'cio_grid_data_tstamp(2, loc_tail,var_loc)',cio_grid_data_tstamp(2, loc_tail, var_loc) + + 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 + + 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 new file mode 100644 index 0000000..c37a99e --- /dev/null +++ b/src/model/src/centralized_io_util_module.F @@ -0,0 +1,388 @@ + +!------------------------------------------------------------------------! +! 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 utility functions to support centralized I/O +! implementation + +! Revision History: +! 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 + end interface + + 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) + + character (*), intent(out) :: name(:) + integer, intent(in) :: begin, end + + integer :: i, j + character (50) :: str1, str2 + logical :: done + + str1 = name( (begin + end) / 2 ) + i = begin + j = end + done = .false. + do while (.not. done) + do while (name(i) < str1) + i = i + 1 + end do + do while (str1 < name(j)) + j = j - 1 + end do + if (i .ge. j) then + done = .true. + else + str2 = name(i) + name(i) = name(j) + name(j) = str2 + i = i + 1 + j = j - 1 + end if + end do + if (begin < i-1) call quicksort(name, begin, i-1) + if (j+1 < end) call quicksort(name, j+1, end) + + end subroutine quicksort1d + +! ------------------------------------------------------------------------- + recursive subroutine quicksort2d (name, begin, end) + + character (*), intent(out) :: name(:,:) + integer, intent(in) :: begin, end + + integer :: i, j, dsize + character (50) :: str1, str2(3) + logical :: done + + dsize = size(name,2) + str1 = name( (begin + end) / 2, 1 ) + i = begin + j = end + done = .false. + do while (.not. done) + do while (name(i,1) < str1) + i = i + 1 + end do + do while (str1 < name(j, 1)) + j = j - 1 + end do + if (i .ge. j) then + done = .true. + else + str2(1:dsize) = name(i,:) + name(i,:) = name(j,:) + name(j,:) = str2(1:dsize) + i = i + 1 + j = j - 1 + end if + end do + if (begin < i-1) call quicksort(name, begin, i-1) + if (j+1 < end) call quicksort(name, j+1, end) + + end subroutine quicksort2d + +! ------------------------------------------------------------------------- + function binary_search (name, list, n) result (loc) + + character (*), intent(in) :: name, list(:) + integer, intent(in) :: n + integer :: loc + + logical :: found + integer :: mid_loc, start_loc, end_loc + + start_loc = 1 + end_loc = n + found = .false. + do while ((start_loc .le. end_loc) .and. (.not. found)) + mid_loc = start_loc + (end_loc - start_loc) / 2 + if (name .lt. list(mid_loc)) then + end_loc = mid_loc - 1 + else if (name .gt. list(mid_loc)) then + start_loc = mid_loc + 1 + else + found = .true. + end if + end do + + if (found) then + loc = mid_loc + else + loc = -1 + end if + + end function binary_search + +! ------------------------------------------------------------------------- + function search (name, list, n) result (loc) + + character (*), intent(in) :: name, list(:) + integer, intent(in) :: n + integer :: loc + + logical :: found + integer :: lloc + + lloc = 0 + found = .false. + do while ((lloc .le. n) .and. (.not. found)) + lloc = lloc + 1 + if (name .eq. list(lloc)) then + found = .true. + end if + end do + + if (found) then + loc = lloc + else + loc = -1 + end if + + end function search + +! ------------------------------------------------------------------------- + integer function time_to_sec (time) + + integer, intent(in) :: time + integer :: neg_time + integer :: time_in_sec, hr, min, sec + + if (time .gt. 0) then + hr = time / 10000 + min = mod(time/100, 100) + sec = mod(time, 100) + time_to_sec = hr * 3600 + min * 60 + sec + else + neg_time = abs(time) + hr = neg_time / 10000 + min = mod(neg_time/100, 100) + sec = mod(neg_time, 100) + time_to_sec = -1*(hr * 3600 + min * 60 + sec) + end if + + end function time_to_sec + +! ------------------------------------------------------------------------- + integer function time_diff (time1, time2) + + integer, intent(in) :: time1, time2 + + time_diff = time_to_sec(time1) - time_to_sec(time2) + + end function time_diff + +!-------------------------------------------------------------------------- + integer function next_day (jday) + +! This function determermins the next day for time interpolation + implicit none + + integer, intent(in) :: jday + integer year, day + + day = MOD(jday,1000) + year = INT(jday/1000) + + If( day .LT. 365 ) Then + next_day = jday+1 + Else + If( MOD(year,4) .Eq. 0 .And. MOD(year,100) .Ne. 0 ) Then +! Leap Year + If( day .Eq. 365 ) Then + next_day = jday + 1 + Else + next_day = (INT(jday/1000)+1)*1000+1 + End If + Else If(MOD(year,400) .Eq. 0 ) Then +! also a leap year, e.g. 2000 but not 2100 + If( day .Eq. 365 ) Then + next_day = jday + 1 + Else + next_day = (INT(jday/1000)+1)*1000+1 + End If + Else +! not a leap year + next_day = (INT(jday/1000)+1)*1000+1 + End If + End If + + 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 + +!-------------------------------------------------------------------------- + + function IntegrateTrapezoid(x, y) + !! Calculates the integral of an array y with respect to x using the trapezoid + !! approximation. Note that the mesh spacing of x does not have to be uniform. + real, intent(in) :: x(:) !! Variable x + real, intent(in) :: y(size(x)) !! Function y(x) + real :: IntegrateTrapezoid !! Integral ∫y(x)·dx + ! Integrate using the trapezoidal rule + associate(n => size(x)) + IntegrateTrapezoid = sum((y(1+1:n-0) + y(1+0:n-1))*(x(1+1:n-0) - x(1+0:n-1)))/2 + end associate + end function + +! --------------------------------------------------------------------------- + + function interp_linear1_internal(x,y,xout) result(yout) + !! Interpolates for the y value at the desired x value, + !! given x and y values around the desired point. + + implicit none + + real, intent(IN) :: x(2), y(2), xout + real :: yout + real :: alph + + if ( xout .lt. x(1) .or. xout .gt. x(2) ) then + write(*,*) "interp1: xout < x0 or xout > x1 !" + write(*,*) "xout = ",xout + write(*,*) "x0 = ",x(1) + write(*,*) "x1 = ",x(2) + stop + end if + + alph = (xout - x(1)) / (x(2) - x(1)) + yout = y(1) + alph*(y(2) - y(1)) + + return + + end function interp_linear1_internal + + end module centralized_io_util_module diff --git a/src/model/src/get_env_mod.f90 b/src/model/src/get_env_mod.f90 new file mode 100644 index 0000000..6eca3a7 --- /dev/null +++ b/src/model/src/get_env_mod.f90 @@ -0,0 +1,438 @@ +!------------------------------------------------------------------------! +! 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. ! +!------------------------------------------------------------------------! + + module get_env_module + +! Function: get environment variables + +! Revision History: +! 2010 D.Wong: initial implementation +! 2 Feb 2010 D.Wong: provided an optional outputing device option, +! absorbed get_envlist function + + implicit none + + integer, parameter :: max_str_len = 10000 + + character (max_str_len) :: loc_str + + interface get_env + module procedure get_env_int, & + get_env_float, & + get_env_double, & + get_env_char, & + get_env_logical, & + get_envlist + end interface + + contains + +! -------------------------------------------------------------------------------- + subroutine get_env_int (env_value, env_var, default_env_value, logdev) + + integer, intent(out) :: env_value + character (*), intent(in) :: env_var + integer, intent(in) :: default_env_value + integer, intent(in), optional :: logdev + + integer :: loc_logdev + logical :: default, regular + + call getenv (env_var, loc_str) + + if (present(logdev)) then + loc_logdev = logdev + else + loc_logdev = 6 + end if + + regular = .false. + default = .false. + + !change the if.esle here + if ( trim(env_var) == 'N_EMIS_GR') then + env_value = 1 + regular = .true. + else if ( trim(env_var) == 'N_EMIS_PT') then + env_value = 2 + regular = .true. + else + env_value = default_env_value + default = .true. + end if + + if ( loc_logdev .gt. 0 ) then + if (default) then + write( loc_logdev, '(A16,2x,A,2x,i10, 1x, a9)' ), env_var,'|', env_value, '(default)' + else if (regular) then + write( loc_logdev, '(A16,2x,A,2x,i10)' ), env_var,'|', env_value + end if + end if + + end subroutine get_env_int + +! -------------------------------------------------------------------------------- + subroutine get_env_float (env_value, env_var, default_env_value, logdev) + + real, intent(out) :: env_value + character (*), intent(in) :: env_var + real, intent(in) :: default_env_value + integer, intent(in), optional :: logdev + + integer :: loc_logdev + logical :: default, regular + + call getenv (env_var, loc_str) + + if (present(logdev)) then + loc_logdev = logdev + else + loc_logdev = 6 + end if + + regular = .false. + default = .false. + + if (len(trim(loc_str)) == 0) then + env_value = default_env_value + default = .true. + else + read (loc_str, *) env_value + regular = .true. + end if + + if ( loc_logdev .gt. 0 ) then + if (default) then + write( loc_logdev, '(A16,2x,A,2x,e10.3, 1x, a9)' ), env_var,'|', env_value, '(default)' + else if (regular) then + write( loc_logdev, '(A16,2x,A,2x,e10.3)' ), env_var,'|', env_value + end if + end if + + end subroutine get_env_float + +! -------------------------------------------------------------------------------- + subroutine get_env_double (env_value, env_var, default_env_value, logdev) + + real (8), intent(out) :: env_value + character (*), intent(in) :: env_var + real, intent(in) :: default_env_value + integer, intent(in), optional :: logdev + + integer :: loc_logdev + logical :: default, regular + + call getenv (env_var, loc_str) + + if (present(logdev)) then + loc_logdev = logdev + else + loc_logdev = 6 + end if + + regular = .false. + default = .false. + + if (len(trim(loc_str)) == 0) then + env_value = default_env_value + default = .true. + else + read (loc_str, *) env_value + regular = .true. + end if + + if ( loc_logdev .gt. 0 ) then + if (default) then + write( loc_logdev, '(A16,2x,A,2x,e10.3, 1x, a9)' ), env_var,'|', env_value, '(default)' + else if (regular) then + write( loc_logdev, '(A16,2x,A,2x,e10.3)' ), env_var,'|', env_value + end if + end if + + end subroutine get_env_double + +! -------------------------------------------------------------------------------- + subroutine get_env_char (env_value, env_var, default_env_value, logdev) + + character (*), intent(out) :: env_value + character (*), intent(in) :: env_var + character (*), intent(in) :: default_env_value + integer, intent(in), optional :: logdev + + integer :: loc_logdev, length, STATUS !add STATUS for ENVSTR in aqm_methods + logical :: default, regular + character (50) :: myfmt + + call getenv (env_var, loc_str) + + if (present(logdev)) then + loc_logdev = logdev + else + loc_logdev = 6 + end if + + regular = .false. + default = .false. + + !change the if.esle here + if ( trim(env_var) == 'MISC_CTRL_NML') then + call nameval ('MISC_CTRL', env_value) + regular = .true. + else if ( trim(env_var) == 'DESID_CTRL_NML') then + call nameval ('DESID_CTRL', env_value) + regular = .true. + else if ( trim(env_var) == 'DESID_CHEM_CTRL_NML') then + call nameval ('DESID_CHEM_CTRL', env_value) + regular = .true. + else if ( trim(env_var) == 'gc_matrix_nml') then + call nameval ('gc_matrix_nml', env_value) + regular = .true. + else if ( trim(env_var) == 'ae_matrix_nml') then + call nameval ('ae_matrix_nml', env_value) + regular = .true. + else if ( trim(env_var) == 'nr_matrix_nml') then + call nameval ('nr_matrix_nml', env_value) + regular = .true. + else if ( trim(env_var) == 'tr_matrix_nml') then + call nameval ('tr_matrix_nml', env_value) + regular = .true. + else if ( trim(env_var) == 'GR_EMIS_LAB_001') then + env_value = 'GRIDDED_EMIS' + regular = .true. + else if ( trim(env_var) == 'STK_EMIS_LAB_001') then + env_value = 'PT_FIRES' + regular = .true. + else if ( trim(env_var) == 'STK_EMIS_LAB_002') then + env_value = 'PT_OTHER' + regular = .true. + else if ( trim(env_var) == 'GRID_NAME') then + !add spaces for 'GRID_NAME =STRTEMP(1:16)' in RUNTIME_VAR + env_value = 'Cubed-Sphere ' + regular = .true. + else if ( trim(env_var) == 'BIOG_SPRO') then + CALL ENVSTR('BIOG_SPRO', 'Speciation profile for biogenics', & + default_env_value, env_value, STATUS) + regular = .true. + else + env_value = default_env_value + default = .true. + end if + + if ( loc_logdev .gt. 0 ) then + length = len_trim(env_value) + if (default) then + if (length .eq. 0) then + write( loc_logdev, '(A16, 2x, A, 13x, a9)') env_var, '|', '(default)' + else + write (myfmt, '(a18, i3.3, a9)') '(A16, 2x, A, 2x, A', length, ', 1x, a9)' + write( loc_logdev, myfmt) env_var, '|', env_value, '(default)' + end if + else if (regular) then + write (myfmt, '(a18, i3.3, a1)') '(A16, 2x, A, 2x, A', length, ')' + write( loc_logdev, myfmt) env_var,'|', env_value + end if + end if + + end subroutine get_env_char + +! -------------------------------------------------------------------------------- + subroutine get_env_logical (env_value, env_var, default_env_value, logdev) + + logical, intent(out) :: env_value + character (*), intent(in) :: env_var + logical, intent(in) :: default_env_value + integer, intent(in), optional :: logdev + + integer :: length, status !add status for envyn in aqm_methods + integer :: loc_logdev + logical :: default, regular + LOGICAL, EXTERNAL :: ENVYN !add for envyn + + call getenv (env_var, loc_str) + + if (present(logdev)) then + loc_logdev = logdev + else + loc_logdev = 6 + end if + + length = len(trim(loc_str)) + regular = .false. + default = .false. + + !change the if.esle here + if (trim(env_var) == 'CTM_EMISCHK') then + env_value = .FALSE. + regular = .true. + else if (trim(env_var) == 'CTM_GRAV_SETL') then + env_value = ENVYN('CTM_GRAV_SETL','GRAV_SETL setting', & + default_env_value,STATUS) + regular = .true. + else if (trim(env_var) == 'CTM_WB_DUST') then + env_value = ENVYN('CTM_WB_DUST','In-line dust emissions', & + default_env_value,STATUS) + regular = .true. + else if (length <= 0) then + env_value = default_env_value + default = .true. + else if ((length == 1) .and. ((loc_str(1:1) .eq. 'Y') .or. & + (loc_str(1:1) .eq. 'y') .or. & + (loc_str(1:1) .eq. 'T') .or. & + (loc_str(1:1) .eq. 't'))) then + env_value = .true. + regular = .true. + else if ((length == 1) .and. ((loc_str(1:1) .eq. 'N') .or. & + (loc_str(1:1) .eq. 'n') .or. & + (loc_str(1:1) .eq. 'F') .or. & + (loc_str(1:1) .eq. 'f'))) then + env_value = .false. + regular = .true. + else if ((trim(loc_str) == '.TRUE.') .or. & + (trim(loc_str) == '.true.') .or. & + (trim(loc_str) == '.True.') .or. & + (trim(loc_str) == 'TRUE') .or. & + (trim(loc_str) == 'true') .or. & + (trim(loc_str) == 'True') .or. & + (trim(loc_str) == 'YES') .or. & + (trim(loc_str) == 'yes') .or. & + (trim(loc_str) == 'Yes')) then + env_value = .true. + regular = .true. + else if ((trim(loc_str) == '.FALSE.') .or. & + (trim(loc_str) == '.false.') .or. & + (trim(loc_str) == '.False.') .or. & + (trim(loc_str) == 'FALSE') .or. & + (trim(loc_str) == 'false') .or. & + (trim(loc_str) == 'False') .or. & + (trim(loc_str) == 'NO') .or. & + (trim(loc_str) == 'no') .or. & + (trim(loc_str) == 'No')) then + env_value = .false. + regular = .true. + else + write (loc_logdev, *) ' Note: Variable ', trim(env_var), ' improperly formatted' + env_value = default_env_value + default = .true. + end if + + if ( loc_logdev .gt. 0 ) then + if (default) then + write( loc_logdev, '(A16,2x,A,10x,L, 1x, a9)' ), env_var,'|', env_value, '(default)' + else if (regular) then + write( loc_logdev, '(A16,2x,A,10x,L)' ), env_var,'|', env_value + end if + end if + + end subroutine get_env_logical + +! -------------------------------------------------------------------------------- + subroutine get_envlist ( env_var, nvars, val_list, logdev ) + +! get a list env var (quoted string of items delimited by white space, +! commas or semi-colons) and parse out the items into variables. Two data +! types: character strings and integers (still represented as strings in +! the env var vaules). +! Examples: +! 1) setenv AVG_CONC_VARS "O3 NO NO2" +! 2) setenv AVG_CONC_LAYS "2 5" < start at two, end at 5 +! 3) setenv NPCOLSXNPROWS "4 3" +! 4) setenv BCOL_ECOL "3 8" +! 5) setenv BROW_EROW "2 10" +! 6) setenv BLAY_ELAY "1 5" + +! In example (1), not only parse out the named items "O3", "NO" and "NO2", +! but also obtain the count on the number of items (=3). + +! Revision: 2013/02/11 David Wong: increased the max env var length from 256 to 1000 +! 13 Dec 2013 J.Young: 1000 breaks BUFLEN in IOAPI's envgets.c. Change to 512. +! 17 Jun 2016 J.Young: IOAPI's envgets.c BUFLEN has been increased to 10000. +! 20 Jun 2016 J.Young: Forget IOAPI's envgets.c: use Fortran GETENV + + character( * ), intent ( in ) :: env_var + integer, intent ( out ) :: nvars + character( 16 ), intent ( out ) :: val_list( : ) + integer, intent(in), optional :: logdev + + integer :: max_len + character( 16 ) :: pname = 'GET_ENVLIST' + character( 16*size( val_list ) ) :: e_val + character( 1 ) :: chr + character( 96 ) :: xmsg + + integer :: jp( 16*size( val_list ) ), kp( 16*size( val_list ) ), status + integer ip, v + + integer :: loc_logdev + + if (present(logdev)) then + loc_logdev = logdev + else + loc_logdev = 6 + end if + + max_len = 16 * size( val_list ) + + call get_env( e_val, env_var, ' ', loc_logdev ) + + if ( env_var .eq. " " ) then + xmsg = 'Environment variable ' // env_var // ' not set' + call m3warn( pname, 0, 0, xmsg ) + nvars = 0 + return + end if + + nvars = 1 + + ip = 0 + +101 continue + ip = ip + 1 + if ( ip .gt. max_len ) go to 301 + chr = e_val( ip:ip ) + if ( chr .eq. ' ' .or. ichar ( chr ) .eq. 09 ) go to 101 + jp( nvars ) = ip ! 1st char + +201 continue + ip = ip + 1 + if ( ip .gt. max_len ) then + xmsg = 'Environment variable value too long' + call m3exit( pname, 0, 0, xmsg, 2 ) + end if + chr = e_val( ip:ip ) + if ( chr .ne. ' ' .and. & + chr .ne. ',' .and. & + chr .ne. ';' .or. & + ichar ( chr ) .eq. 09 ) then ! 09 = horizontal tab + go to 201 + else + kp( nvars ) = ip - 1 ! last char in this item + nvars = nvars + 1 + end if + + go to 101 + +301 continue + nvars = nvars - 1 + + do v = 1, nvars + val_list( v ) = e_val( jp( v ):kp( v ) ) + end do + + end subroutine get_envlist + + end module get_env_module diff --git a/src/model/src/o3totcol.f b/src/model/src/o3totcol.f index 9f8c7fc..0e069e9 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,23 @@ 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 - !---------------------------------------------------------------------- if ( firsttime ) then firsttime = .false. - logdev = init3() tmunit = getefile( tmfile, .true., .true., pname ) @@ -113,8 +116,11 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) ! read nlat, nlon 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 +133,17 @@ 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 nrecs = 0 +! read( tmunit, * ) ! skip header record do read( tmunit, *, iostat=ios ) if ( ios .ne. 0 ) exit @@ -151,10 +164,9 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) end if 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 +180,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 +294,43 @@ 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 ) + 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 +338,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 +444,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 +468,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 +497,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 +514,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 new file mode 100644 index 0000000..1504088 --- /dev/null +++ b/src/model/src/phot.F @@ -0,0 +1,1674 @@ + +!------------------------------------------------------------------------! +! 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. ! +!------------------------------------------------------------------------! + +!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: + SUBROUTINE PHOT ( CGRID, JDATE, JTIME, DTSTEP ) + +!----------------------------------------------------------------------- +! +! Function: Calculates the photolysis rate constant to be used by the +! chemical solver. It calculates these rates at each gridcell using +! codes adapted from JPROC. Cloud correction now called within the +! loops over MY-ROW & MY_COLS +! +! Preconditions: HGRD_INIT() called from PAR_INIT, which is called from +! DRIVER +! +! 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_ENVLIST +! +! Revision History. +! Started 10/08/2004 with existing PHOT and JPROC coded by +! Dr. Francis S. Binkowski +! Carolina Environmental Program +! University of North Carolina at Chapel Hill +! email: frank_binkowski@unc.edu +! August 2005, Sarav Arunachalam, CEP, UNC-CH +! - Minor revisions while integrating with CMAQ +! - Error check for NPHOTS added (this version works only for SAPRC-99) +! - Added creation of new file CTM_RJ_1 to write out RJ values +! for O3 and NO2 (both clear sky and cloud effects), and +! ETOT_SFC, TAU_AERO, TAU_TOT and TAUO3_TOP values for 7 wavelengths +! June 2007, David Wong +! -- inline with CMAQ +! - declare RJ as assumed shape array to match with the caller routine +! - allow PE 0 only to open the output file +! - output species: NO2_CLOUD and O3_CLOUD with AMISS value when all cells +! are dark and JTIME_CHK = 0 +! - output species: NO2_CLOUD and O3_CLOUD with AMISS value when CLDATT is +! 0 and JTIME_CHK = 0 +! December 2007, Francis Binkowski +! code has been modified to call the new on-line version that +! has the cloud effects built in. new photolysis routine to +! replace PHOT in CMAQ +! January 2008, Shawn Roselle +! - reformatted for inclusion in CMAQ +! - added additional 3-d photolysis rate diagnostic file +! - moved code for opening the diagnostic files to a separate subroutine +! - moved aerosol pointer evaluation to a FORTRAN module +! - simplified code for writing the diagnostic file +! - changed code to call NEW_OPTICS twice, once for clear sky and +! another time for the cloudy fraction of the grid cell. RJ's are +! computed based on the cloud fraction weighting. +! March 2011, Bill Hutzell +! - enable wavelength dependent arrays to have an allocatable number +! of wavelength bins +! - added data structure and algorithm to compute a surface albedo that +! depends on time and landuse catagory based on work by John Striecher +! (AMAD/USEPA) +! - revised writing to RJ1 file to include surface albedo +! - moved photolysis and opacity data from CSQY module to an ASCII input +! file +! - added routine called LOAD_REF_DATA (inside the PHOT_MOD module) that i +! 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 +! version 5.0 +! March 29, 2011 S.Roselle +! - Replaced I/O API include files with UTILIO_DEFN +! 07 Jul 14 B.Hutzell: replaced mechanism include file(s) with fortran module +! 26 Sep 14 B.Hutzell: 1) moved calculation of surface albedo to its own +! fortran module +! 2) changed loading procedure for loading optical data; +! two files now used +! 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 +! clouds with multi-phases of water +! 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 +! the NEW_OPTICS routine +! 7) Several miscellaneous changes attempting to improve efficiency +! 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 UTILIO_DEFN + USE AERO_DATA ! describes aerosol distribution + USE PHOT_MOD ! photolysis in-line module - inherits CSQY_DATA module + USE AERO_PHOTDATA ! arrays and routines for aerosol dimensions and refractive indices + 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 SEAS_STRAT_O3_MIN ! monthly minimum fraction of ozone column density above Pressure TOP + !Used for canopy shade calculation (Wei Li) + USE ASX_DATA_MOD, ONLY : MET_DATA !uses met data + 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) +#else + USE NOOP_MODULES ! stenex (using NOOP_UTIL_MODULE) +#endif + + IMPLICIT NONE + +!...include files + + INCLUDE SUBST_FILES_ID ! file name parameters + +!...arguments + + 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) + + +!...parameters + + LOGICAL, PARAMETER :: CLDATT = .TRUE. ! include cloud attenuation + + REAL, PARAMETER :: DENS_CONV = ( 1.0E+03 * AVO / MWAIR ) * 1.0E-06 ! convert from kg/m**3 to #/cc + REAL, PARAMETER :: PPM_MCM3 = 1.0E-06 ! convert from ppm to molecules / cc mol_Spec/mol_Air = ppm * 1E-06 + 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 + +!...local variables + + LOGICAL, SAVE :: FIRSTIME = .TRUE. ! Flag for first call to PHOT + + 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 ) :: V_LIST( 2 ) + CHARACTER( 16 ) :: REQUESTED_WAVE + CHARACTER( 16 ), ALLOCATABLE :: WAVE_LIST( : ) + + CHARACTER( 80 ) :: VARDESC ! environment variable description + CHARACTER( 240 ) :: XMSG = ' ' + + 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 + INTEGER IPHOT ! photolysis rate loop index + INTEGER ROW + INTEGER COL + INTEGER LEV + INTEGER SPC + INTEGER IWL + INTEGER L + INTEGER V, N, MODE + + 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 :: 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 + + REAL CURRHR ! current GMT hour + REAL JULIAN_DAY ! time of year [days] + REAL CURRHR_LST ! local standard time at each grid cell + REAL CTOP ! cloud top in single dimension + REAL CBASE ! cloud base in single dimension + REAL ZLEV ! height in single dimension + REAL ZEN ! cosine of zenith angle + REAL SINLAT ! sine of latitude + REAL COSLAT ! cosine of latitude + REAL RSQD ! square of soldist + REAL ZSFC ! surface height (msl) [ m ] + REAL EQT ! equation of time + REAL SOLDIST ! solar distance [ au ] + REAL SINDEC ! sine of the solar declination + REAL COSDEC ! cosine of the solar declination + REAL COSZEN ! working cosine of the solar zenith angle + REAL SINZEN ! working sine of the solar zenith angle + REAL LATCR ! local latitude + REAL LONCR ! local longitude + REAL OWATER_FRAC ! Open water fraction + REAL SNOW_FRAC ! Snow fractional coverage + REAL SEAICE_FRAC ! Sea Ice fraction + REAL RES_SKY_REFLECT ! reflection coefficient based on resolved sky + REAL RES_SKY_TRANS ! diffuse transmission coefficient based on resolved sky + 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 :: SSA ( : ) ! aerosol single scattering albedo, column average + + REAL MSCALE ! combined factor to scale ppm to Molecules / cm**3 + ! and correct for ambient temperaure and pressure + +! FSB new arrays for new on-line cloud version + + REAL, ALLOCATABLE, SAVE :: LWC ( : ) ! cloud liquid water content [ g/m**3 ] + REAL, ALLOCATABLE, SAVE :: RWC ( : ) ! rain water content [ g/m**3 ] + REAL, ALLOCATABLE, SAVE :: IWC ( : ) ! ice liquid water content [ g/m**3 ] + REAL, ALLOCATABLE, SAVE :: SWC ( : ) ! snow content [ g/m**3 ] + REAL, ALLOCATABLE, SAVE :: GWC ( : ) ! graupel content [ g/m**3 ] + REAL, ALLOCATABLE, SAVE :: CLDFRAC( : ) ! fractional cloud cover + REAL, ALLOCATABLE, SAVE :: BLKPRS ( : ) ! Air pressure in [ Pa ] + REAL, ALLOCATABLE, SAVE :: BLKTA ( : ) ! Air temperature [ K ] + REAL, ALLOCATABLE, SAVE :: BLKDENS( : ) ! Air density [ molecules / m**3 ] + REAL, ALLOCATABLE, SAVE :: BLKZH ( : ) ! layer half-height [ m ] + REAL, ALLOCATABLE, SAVE :: BLKO3 ( : ) ! O3 concentration [ molecules/cm**3 ] + REAL, ALLOCATABLE, SAVE :: BLKNO2 ( : ) ! NO2 concentration [ molecules/cm**3 ] + REAL, ALLOCATABLE, SAVE :: BLKZF ( : ) ! layer full-height [ m ] + + 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 (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 ( :, :) ! 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 :: YCAN ( 2 ) ! photolysisattenuation interpolation bounds + REAL ZFL, ZCAN, COUNTCAN, XCANOUT ! local canopy variables + INTEGER, PARAMETER :: MAXCAN = 1000 ! Declare local maximum canopy layers + +!...Variables for diagnostic outputs + + REAL, ALLOCATABLE, SAVE :: N_EXCEED_TROPO3( :,: ) ! Number of adjustments tropospheric ozone optical depth + + 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 :: 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 + 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 + 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 :: 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 (Wei Li) + + INTERFACE + 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) (Wei Li) + + CANOPY_SHADE = ENVYN( 'CTM_CANOPY_SHADE', + & 'Flag for in-line canopy shading', + & .FALSE., IOSX ) + + IF ( CANOPY_SHADE ) THEN + XMSG = 'Using in-line canopy shading option' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + + FIRSTIME = .FALSE. + + TSTEP = TIME2SEC( DTSTEP( 1 ) ) ! output timestep for phot diagnostic files + +!...Set flag to initialize calculating aerosol extinction at 550 nm via Angstrom Exponents + CALCULATE_EXT_550 = .TRUE. !PHOTDIAG + + PECOL_OFFSET = COLSD_PE( 1, MYPE+1 ) - 1 + PEROW_OFFSET = ROWSD_PE( 1, MYPE+1 ) - 1 + + CALL INIT_PHOT_SHARED() + +!...Allocate array needed to calculation aerosol and cloud optical properties + + CALL INIT_AERO_DATA( ) + + CALL INIT_CLOUD_OPTICS( ) + +!...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 ), + & 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 + + +! set cosine values for sun effectively below horizon + COS85 = COS( 85.0 * PI180 ) + +!...Initialize Surface albedo method + + 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( 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( BLKRJ_RES( NLAYS,NPHOTAB ) ) + ALLOCATE( BLKRJ_ACM( NLAYS,NPHOTAB ) ) + + ALLOCATE( TAUO3_TOP( NWL ) ) + ALLOCATE( TAU_RAY ( NWL ) ) + ALLOCATE( SSA ( NWL ) ) + + ALLOCATE( TAU_CLOUD( NLAYS,NWL ) ) + ALLOCATE( TAUC_AERO( NLAYS,NWL ) ) + 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( 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 ) ) + ALLOCATE( TRANSMIS_DIRECT ( NCOLS,NROWS ) ) + ALLOCATE( REFLECT_COEFF ( NCOLS,NROWS ) ) + ALLOCATE( CLR_TRANSMISSION( NCOLS,NROWS ) ) + ALLOCATE( CLR_TRANS_DIRECT( NCOLS,NROWS ) ) + ALLOCATE( CLR_REFLECTION ( NCOLS,NROWS ) ) + ALLOCATE( TAU_AERO_WL ( NCOLS,NROWS,NWL ) ) + ALLOCATE( TAU_CLOUD_WL ( NCOLS,NROWS,NWL ) ) +#ifdef phot_debug + ALLOCATE( SSA_CLOUD_WL( NCOLS,NROWS,NWL ) ) + ALLOCATE( ASY_CLOUD_WL( NCOLS,NROWS,NWL ) ) +#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,'(/)') + + + 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_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 ( AERO_EXT( NCOLS,NROWS,NLAYS_DIAG,N_DIAG_WVL ), STAT = ALLOCSTAT ) + IF ( ALLOCSTAT .NE. 0 ) THEN + XMSG = 'Failure allocating 3D AERO_EXT' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + ALLOCATE ( TOT_EXT( NCOLS,NROWS,NLAYS_DIAG,N_DIAG_WVL ), STAT = ALLOCSTAT ) + IF ( ALLOCSTAT .NE. 0 ) THEN + XMSG = 'Failure allocating 3D TOT_EXT' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + ALLOCATE ( GAS_EXT( NCOLS,NROWS,NLAYS_DIAG,N_DIAG_WVL ), STAT = ALLOCSTAT ) + IF ( ALLOCSTAT .NE. 0 ) THEN + XMSG = 'Failure allocating 3D GAS_EXT' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + 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 + + 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 + + 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 + IF ( IO_PE_INCLUSIVE ) CALL OPPHOT ( ODATE, OTIME, DTSTEP( 1 ) ) +! 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' + LGC_O3 = INDEX1( VARNM, N_GC_SPC, GC_SPC ) + IF ( LGC_O3 .LE. 0 ) THEN + XMSG = 'Could not find ' // VARNM // 'in species table' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT3 ) + END IF + + VARNM = 'NO2' + LGC_NO2 = INDEX1( VARNM, N_GC_SPC, GC_SPC ) + IF ( LGC_NO2 .LE. 0 ) THEN + XMSG = 'Could not find ' // VARNM // 'in species table' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT3 ) + END IF + + + END IF ! firstime + + 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 ) + JD_STRAT_O3MIN = REAL( JDATE, 4) + END IF +!...initialize variables tracking whether stratosphere ozone column satisfies +!...climatological averages. + + O3_TOGGLE_AVE = 0.0 + O3_TOGGLE_MIN = 1.0 + N_TROPO_O3_TOGGLE = 0 + TSTEP_COUNT = TSTEP_COUNT + 1 + + 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, MIDDATE, MIDTIME ) + + RSQD = DIST_TO_SUN * DIST_TO_SUN + + IF ( MAXVAL( COSINE_ZENITH ) .LE. 0.0 ) THEN + DARK = .TRUE. + ELSE + DARK = .FALSE. + END IF + +!...set surface albedos + + 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 +#ifdef parallel_io + IF ( .NOT. IO_PE_INCLUSIVE ) THEN + IF ( .NOT. OPEN3( CTM_RJ_1, FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open ' // TRIM(CTM_RJ_1) + CALL M3EXIT( PNAME, ODATE, OTIME, XMSG, XSTAT1 ) + END IF + IF ( .NOT. OPEN3( CTM_RJ_2, FSREAD3, PNAME ) ) THEN + 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 + 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 + 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 + + IF ( JTIME_CHK .AND. PHOTDIAG ) THEN + + TAUO3_TOP_WL = 0.0 + TAU_AERO_WL = 0.0 + TAU_CLOUD_WL = 0.0 +#ifdef phot_debug + SSA_CLOUD_WL = 0.0 + ASY_CLOUD_WL = 0.0 +#endif + TAU_TOT_WL = 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 + + 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 + + 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, 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 + 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 + SSA_CLOUD_WL( COL,ROW, : ) = 0.0 + ASY_CLOUD_WL( 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 + + 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 + + END IF + +!...initialize BLKRJ using F90 array operations. + + BLKRJ_RES = 0.0 + BLKRJ_ACM = 0.0 + +!...Set height of lowest level to zero + + BLKZF( 1 ) = 0.0 + + ZSFC = HT( COL,ROW ) ! surface height [m] + SINZEN = SQRT( 1.0 - COSZEN * COSZEN ) ! sine of zenith angle + +!...get total ozone column based on OMI observations + 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 + ROW_CLOUD = PHOT_ROW + END IF + +!...loop over vertical layers ambient air conditions and gas concentration + DO L = 1, NLAYS +!...Fetch the grid cell ambient data at each layer. + + BLKTA ( L ) = TA ( COL,ROW,L ) ! temperature [K] + BLKPRS ( L ) = PRES ( COL,ROW,L ) / STDATMPA ! [atmospheres] + BLKDENS( L ) = DENS ( COL,ROW,L ) * DENS_CONV ! [molecules / cm**3] + BLKZH ( L ) = ZM ( COL,ROW,L ) ! mid layer height [m] + BLKZF ( L+1 ) = ZFULL( COL,ROW,L ) ! full layer height [m] + +!...set scale factor for [ppm] -> [molecule / cm**3] +!... To go from ppm to molecule/cc: +!... molecule/cc = ppm * 1.0E-06 * DENS (given in molecule/cc) + + MSCALE = BLKDENS( L ) * PPM_MCM3 + +!...fetch ozone and no2 and convert to [ molecules / cm **3 ] +!... and adjust the volume for ambient temperature and pressure. + + BLKO3 ( L ) = CGRID( COL,ROW,L,LGC_O3 ) * MSCALE + BLKNO2( L ) = CGRID( COL,ROW,L,LGC_NO2 ) * MSCALE + ZLEV = BLKZF( L ) + END DO ! loop on layers ambient conditions and gases + + 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. + CLDFRAC( L ) = CFRAC_3D( COL,ROW,L ) +!... set hydrometeor concentrations for resolved cloud + 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 ) + LWC( L ) = MSCALE * QC( COL,ROW,L ) + RWC( L ) = MSCALE * QR( COL,ROW,L ) + ELSE + CLOUDS ( L ) = .FALSE. + CLOUD_LAYERING( L ) = .FALSE. + CLDFRAC( L ) = 0.0 + IWC( L ) = 0.0 + GWC( 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_ICE_OPTICS( NLAYS, BLKTA, IWC ) + CALL GET_AGGREGATE_OPTICS( NLAYS, RWC, SWC, GWC ) + ELSE + CLOUDS = .FALSE. + CLOUD_LAYERING = .FALSE. + CLDFRAC = 0.0 +! hydrometeor concentrations + LWC = 0.0 + IWC = 0.0 + RWC = 0.0 + SWC = 0.0 + 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, DENS, CGRID ) +! ELSE +! CALL AERO_OPTICS_INTERNAL( COL,ROW, NLAYS, CGRID ) +! END IF + +! set surface albedo + + DO IWL = 1, NWL + ALB( IWL ) = SURFACE_ALBEDO( IWL, COL,ROW ) + END DO +!...calculate resolved-sky photolysis rates at all layers: + + NEW_PROFILE = .TRUE. + ONLY_SOLVE_RAD = .FALSE. + + CALL NEW_OPTICS ( JDATE, JTIME, NLAYS, + & BLKTA, BLKPRS, BLKDENS, BLKZH, BLKZF, + & BLKO3, BLKNO2, + & ZSFC, COSZEN, SINZEN, RSQD, + & NEW_PROFILE, CLOUDS, CLDFRAC, + & BLKRJ_RES, TAUC_AERO, TAU_TOT, TAUO3_TOP, + & 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 + & + TROPO_O3_EXCEED( COL,ROW ) + END IF + + 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 + + + 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 DO + + + DO L = 1, N_DIAG_WVL + IWL = DIAG_WVL( L ) + 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_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_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 ) + 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 + IF ( ACM_CLOUDS( COL,ROW ) .GT. 0.0 ) THEN +! save resolved sky reflection and transmission coefficients for possible latter use + RES_SKY_REFLECT = REFLECTION + RES_SKY_TRANS = TRANSMISSION + RES_SKY_TRANSD = TRANS_DIRECT +!...find the highest layer of the sub-grid (convective) cloud + DO LEV = NLAYS, 1, -1 + IF ( ACM_CFRAC( LEV, COL,ROW ) .GT. 0.0 ) EXIT + END DO +!...replace the lower layers with sub-grid cloud properties + DO L = 1, LEV + SWC( L ) = 0.0 + IF ( ACM_CFRAC( L,COL,ROW ) .GT. 0.0 ) THEN + CLOUDS ( L ) = .TRUE. + CLDFRAC( L ) = 1.0 + MSCALE = 1.0E+3 * DENS ( COL,ROW, L ) + LWC( L ) = MSCALE * ACM_QC( L,COL,ROW ) + IWC( L ) = MSCALE * ACM_QI( L,COL,ROW ) + RWC( L ) = MSCALE * ACM_QR( L,COL,ROW ) + GWC( L ) = MSCALE * ACM_QG( L,COL,ROW ) + ELSE + CLOUDS( L ) = .FALSE. + CLDFRAC( L ) = 0.0 + LWC( L ) = 0.0 + IWC( L ) = 0.0 + RWC( L ) = 0.0 + GWC( L ) = 0.0 + END IF + CLOUD_LAYERING( L ) = .FALSE. + END DO + +! 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 ) + +!...calculate the acm-cloud photolysis rates for all layers: + NEW_PROFILE = .FALSE. + CALL NEW_OPTICS ( JDATE, JTIME, NLAYS, + & BLKTA, BLKPRS, BLKDENS, BLKZH, BLKZF, + & BLKO3, BLKNO2, + & ZSFC, COSZEN, SINZEN, RSQD, + & NEW_PROFILE, CLOUDS, CLDFRAC, + & BLKRJ_ACM, TAUC_AERO, TAU_TOT, TAUO3_TOP, + & TAU_RAY, SSA, TAU_CLOUD, TOTAL_O3_COLUMN ) + +!...load diagnostic file arrays +!...compute a cloud-fraction weighted average of ETOT_SFC and TAU_TOT +!... 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 .AND. PHOTDIAG ) THEN + + TRANSMIS_DIRECT( COL,ROW ) = MSCALE * TRANSMIS_DIRECT( COL,ROW ) + & + ACM_CLOUDS( COL,ROW ) * TRANS_DIRECT + TRANSMIS_DIFFUSE( COL,ROW ) = MSCALE * TRANSMIS_DIFFUSE( COL,ROW ) + & + ACM_CLOUDS( COL,ROW ) * TRANSMISSION + REFLECT_COEFF( COL,ROW ) = MSCALE * REFLECT_COEFF( COL,ROW ) + & + ACM_CLOUDS( COL,ROW ) * REFLECTION + 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 ) + & + ACM_CLOUDS( COL,ROW ) * TAU_CLOUD( 1,IWL ) +#ifdef phot_debug + SSA_CLOUD_WL( COL,ROW,IWL ) = MSCALE * SSA_CLOUD_WL( COL,ROW,IWL ) + & + ACM_CLOUDS( COL,ROW ) * AVE_SSA_CLD ( IWL ) + ASY_CLOUD_WL( COL,ROW,IWL ) = MSCALE * ASY_CLOUD_WL( COL,ROW,IWL ) + & + ACM_CLOUDS( COL,ROW ) * AVE_ASYMM_CLD( IWL ) +#endif + 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_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) +!Makar, P., Staebler, R., Akingunola, A. et al. The effects of forest canopy shading and turbulence on boundary layer ozone. +!Nat Commun 8, 15243 (2017). https://doi.org/10.1038/ncomms15243 + + IF ( CANOPY_SHADE ) THEN ! compute canopy shade reduction factor (RJ_CORR) +! WRITE(*,*) 'LAIE = ', Met_Data%LAIE( COL,ROW ) , +! & 'FCH = ', Met_Data%FCH( COL,ROW ), +! & 'FRT = ', Met_Data%FRT( COL,ROW), +! & 'POPU = ', Met_Data%POPU( COL,ROW), +! & 'CLU = ', Met_Data%CLU( COL,ROW) + + !conditions for grid cells that do NOT have + !a continuous forest canopy + IF ( Met_Data%LAIE( COL,ROW ) .LT. 0.1 + & .OR. Met_Data%FCH( COL,ROW ) .LT. 0.5 ) THEN +! & .OR. Met_Data%FCH( COL,ROW ) .LT. 10.0 +! & .OR. MAX(0.0, 1.0 - Met_Data%FRT( COL,ROW)) .GT. 0.5 +! & .OR. Met_Data%POPU( COL,ROW ) .GT.10000.0 +! & .OR. EXP(-0.5*Met_Data%LAIE( COL,ROW)*Met_Data%CLU( COL,ROW )) .GT. 0.45 +! & .AND. Met_Data%FCH(COL,ROW ) .LT. 18.0 ) THEN + RJ( COL,ROW, 1, : ) = RJ( COL,ROW, 1, :) + ELSE ! There is a contiguous forest canopy,apply correctoin + !RJ_CORR effectly represents the beam attenuation and reduces photolysis. + !Nilson, T. A theoretical analysis of the frequency of gaps in plant stands. Agric. + !Meterol. 8, 25⚌~Z~L~@~S38 (1971). + +!Calculate attenuation at different set cumulative LAI fractions downward through canopy (C1R, C2R, C3R, C4R data from ECCC) + RJ_CORR_C1R( COL,ROW ) = MAX(1.0E-10, EXP(-1.0*(0.5*(Met_Data%LAIE( COL,ROW ) + & *Met_Data%C1R( COL,ROW ))*Met_Data%CLU( COL,ROW ))/MAX(0.05, COSZEN))) + RJ_CORR_C2R( COL,ROW ) = MAX(1.0E-10, EXP(-1.0*(0.5*(Met_Data%LAIE( COL,ROW ) + & *Met_Data%C2R( COL,ROW ))*Met_Data%CLU( COL,ROW ))/MAX(0.05, COSZEN))) + RJ_CORR_C3R( COL,ROW ) = MAX(1.0E-10, EXP(-1.0*(0.5*(Met_Data%LAIE( COL,ROW ) + & *Met_Data%C3R( COL,ROW ))*Met_Data%CLU( COL,ROW ))/MAX(0.05, COSZEN))) + RJ_CORR_C4R( COL,ROW ) = MAX(1.0E-10, EXP(-1.0*(0.5*(Met_Data%LAIE( COL,ROW ) + & *Met_Data%C4R( COL,ROW ))*Met_Data%CLU( COL,ROW ))/MAX(0.05, COSZEN))) + RJ_CORR_BOT( COL,ROW ) = MAX(1.0E-10, EXP(-1.0*(0.5*Met_Data%LAIE( COL,ROW ) + & *Met_Data%CLU( COL,ROW ))/MAX(0.05, COSZEN))) + +!Interpolate to get attenuation profile below canopy + ZFL = Met_Data%ZF( COL,ROW,1 ) + ZCAN = ZFL ! Initialize canopy top (m) = Bottom of First model layer above canopy +! ZCAN = Met_Data%FCH( COL,ROW ) ! Initialize canopy top (m) = Top of canopy + COUNTCAN = 0 ! Initialize canopy layers + DO WHILE (ZCAN.GE.0.5) !canopy threshold >= 0.5 m + IF ( ZCAN .GT. Met_Data%FCH( COL,ROW ) ) THEN + COUNTCAN = COUNTCAN + 1 + ZCANX(COUNTCAN) = ZCAN + RJ_CORRX (COUNTCAN) = 1.0 + ELSE IF ( ZCAN .LE. Met_Data%FCH( COL,ROW ) .AND. + & ZCAN .GT. Met_Data%FCH( COL,ROW )*0.75 ) THEN + COUNTCAN = COUNTCAN + 1 + XCAN(2) = Met_Data%FCH( COL,ROW ) + YCAN(2) = 1.0 + XCAN(1) = Met_Data%FCH( COL,ROW )*0.75 + YCAN(1) = RJ_CORR_C1R( COL,ROW ) + XCANOUT = ZCAN + ZCANX(COUNTCAN) = ZCAN + RJ_CORRX (COUNTCAN) = interp_linear1_internal(XCAN,YCAN,XCANOUT) + ELSE IF ( ZCAN .LE. Met_Data%FCH( COL,ROW )*0.75 .AND. + & ZCAN .GT. Met_Data%FCH( COL,ROW )*0.50 ) THEN + COUNTCAN = COUNTCAN + 1 + XCAN(2) = Met_Data%FCH( COL,ROW )*0.75 + YCAN(2) = RJ_CORR_C1R( COL,ROW ) + XCAN(1) = Met_Data%FCH( COL,ROW )*0.50 + YCAN(1) = RJ_CORR_C2R( COL,ROW ) + XCANOUT = ZCAN + ZCANX(COUNTCAN) = ZCAN + RJ_CORRX (COUNTCAN) = interp_linear1_internal(XCAN,YCAN,XCANOUT) + ELSE IF ( ZCAN .LE. Met_Data%FCH( COL,ROW )*0.50 .AND. + & ZCAN .GT. Met_Data%FCH( COL,ROW )*0.35 ) THEN + COUNTCAN = COUNTCAN + 1 + XCAN(2) = Met_Data%FCH( COL,ROW )*0.50 + YCAN(2) = RJ_CORR_C2R( COL,ROW ) + XCAN(1) = Met_Data%FCH( COL,ROW )*0.35 + YCAN(1) = RJ_CORR_C3R( COL,ROW ) + XCANOUT = ZCAN + ZCANX(COUNTCAN) = ZCAN + RJ_CORRX (COUNTCAN) = interp_linear1_internal(XCAN,YCAN,XCANOUT) + ELSE IF ( ZCAN .LE. Met_Data%FCH( COL,ROW )*0.35 .AND. + & ZCAN .GT. Met_Data%FCH( COL,ROW )*0.20 ) THEN + COUNTCAN = COUNTCAN + 1 + XCAN(2) = Met_Data%FCH( COL,ROW )*0.35 + YCAN(2) = RJ_CORR_C3R( COL,ROW ) + XCAN(1) = Met_Data%FCH( COL,ROW )*0.20 + YCAN(1) = RJ_CORR_C4R( COL,ROW ) + XCANOUT = ZCAN + ZCANX(COUNTCAN) = ZCAN + RJ_CORRX (COUNTCAN) = interp_linear1_internal(XCAN,YCAN,XCANOUT) + ELSE IF ( ZCAN .LE. Met_Data%FCH( COL,ROW )*0.20 ) THEN + COUNTCAN = COUNTCAN + 1 + XCAN(2) = Met_Data%FCH( COL,ROW )*0.20 + YCAN(2) = RJ_CORR_C4R( COL,ROW ) + XCAN(1) = 0.5 + YCAN(1) = RJ_CORR_BOT( COL,ROW ) + XCANOUT = ZCAN + ZCANX(COUNTCAN) = ZCAN + RJ_CORRX (COUNTCAN) = interp_linear1_internal(XCAN,YCAN,XCANOUT) + END IF + ZCAN = ZCAN-0.5 !step down in-canopy resolution of 0.5 m +! WRITE(*,*) 'Met_Data%FCH = ', Met_Data%FCH( COL,ROW ), +! & 'ZCANX (COUNTCAN) = ', ZCANX (COUNTCAN), +! & 'RJ_CORRX (COUNTCAN) = ', RJ_CORRX (COUNTCAN) + END DO !end loop on canopy layers + +!Integrate to get best attenuation value to use within canopy + RJ_CORR( COL,ROW ) = IntegrateTrapezoid(ZCANX(COUNTCAN:1:-1),RJ_CORRX(COUNTCAN:1:-1)) / + & ZFL +! WRITE(*,*) 'RJ_CORRX = ', RJ_CORRX(COUNTCAN:1:-1), +! & 'ZCANX = ', ZCANX(COUNTCAN:1:-1), +! & 'RJ_CORR (int) = ', RJ_CORR( COL,ROW ) +!Apply attenuation factors above and below canopy + RJ( COL,ROW, 1, : ) = RJ( COL,ROW, 1, : )*RJ_CORR( COL,ROW ) +!Apply attenuation value within canopy and take average above and within canopy values +! 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 + + + 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, + & BLKTA, BLKPRS, BLKDENS, BLKZH, BLKZF, + & BLKO3, BLKNO2, + & ZSFC, COSZEN, SINZEN, RSQD, + & NEW_PROFILE, CLOUDS, CLDFRAC, + & BLKRJ_RES, TAUC_AERO, TAU_TOT, TAUO3_TOP, + & TAU_RAY, SSA, TAU_CLOUD, TOTAL_O3_COLUMN) + CLR_REFLECTION ( COL,ROW ) = REFLECTION + CLR_TRANSMISSION( COL,ROW ) = TRANSMISSION + CLR_TRANS_DIRECT( COL,ROW ) = TRANS_DIRECT + ELSE ! only subgrid clouds exist + CLR_REFLECTION ( COL,ROW ) = RES_SKY_REFLECT + CLR_TRANSMISSION( COL,ROW ) = RES_SKY_TRANS + CLR_TRANS_DIRECT( COL,ROW ) = RES_SKY_TRANSD + END IF + ELSE ! no cloud in vertical column + CLR_REFLECTION ( COL,ROW ) = REFLECTION + CLR_TRANSMISSION( COL,ROW ) = TRANSMISSION + CLR_TRANS_DIRECT( COL,ROW ) = TRANS_DIRECT + END IF + END IF + + END DO LOOP_COLS + 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 + O3_TOGGLE_AVE = O3_TOGGLE_AVE / REAL( N_TROPO_O3_TOGGLE ) + WRITE( LOGDEV, 9500 )'PHOT: Exceedance of tropospheric ozone column ', + & 'or below top of model domains based on stratospheric column minimum ', + & 'at date and time; ', JDATE, JTIME, N_TROPO_O3_TOGGLE, (1.0/O3_TOGGLE_AVE - 1.0), + & (1.0/O3_TOGGLE_MIN - 1.0) + END IF + +!...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, + & COSINE_ZENITH ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + VARNM = 'OZONE_COLUMN' + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, TOTAL_OC ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + 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 + 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 + + 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' + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, TRANSMIS_DIFFUSE ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + VARNM = 'TRANS_DIRECT' + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, TRANSMIS_DIRECT ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + VARNM = 'REFLECTION' + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, REFLECT_COEFF ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + VARNM = 'CLR_TRANS_DIF' + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, CLR_TRANSMISSION ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + VARNM = 'CLR_TRANS_DIR' + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, CLR_TRANS_DIRECT ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + VARNM = 'CLR_REFLECTION' + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, CLR_REFLECTION ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + VARNM = 'TROPO_O3_EXCEED' + TROPO_O3_EXCEED = TROPO_O3_EXCEED / REAL( MAX(1, TSTEP_COUNT) ) + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, TROPO_O3_EXCEED ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + TROPO_O3_EXCEED = 0.0 ! reset sum and counter + TSTEP_COUNT = 0 + + VARNM = 'N_EXCEED_TROPO3' + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, N_EXCEED_TROPO3 ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + N_EXCEED_TROPO3 = 0.0 ! reset counter + + VARNM = 'JNO2' + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, RJ( :,:,1, LNO2 ) ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + VARNM = 'JO3O1D' + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, RJ( :,:,1,LO3O1D ) ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + VARNM = 'RESOLVED_CFRAC' + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, CFRAC_2D ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + VARNM = 'RESOLVED_WBAR' + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, AVE_HYDROMETEORS ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + IF ( USE_ACM_CLOUD ) THEN + VARNM = 'SUBGRID_CFRAC' + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, ACM_CLOUDS ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + VARNM = 'SUBGRID_WBAR' + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, ACM_AVE_H2O ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + END IF + + DO IWL = 1, NWL + + VARNM = 'ETOT_SFC_W' // WLTXT( IWL ) + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, + & OTIME, ETOT_SFC_WL( :,:,IWL ) ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, ODATE, OTIME, XMSG, XSTAT1 ) + END IF + + VARNM = 'AOD_W' // WLTXT( IWL ) + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, + & OTIME, TAU_AERO_WL( :,:,IWL ) ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + VARNM = 'TAU_CLOUD_W' // WLTXT( IWL ) + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, + & OTIME, TAU_CLOUD_WL( :,:,IWL ) ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + +#ifdef phot_debug + VARNM = 'SSA_CLOUD_W' // WLTXT( IWL ) + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, + & OTIME, SSA_CLOUD_WL( :,:,IWL ) ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + VARNM = 'ASY_CLOUD_W' // WLTXT( IWL ) + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, + & OTIME, ASY_CLOUD_WL( :,:,IWL ) ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF +#endif + + VARNM = 'TAU_TOT_W' // WLTXT( IWL ) + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, + & OTIME, TAU_TOT_WL( :,:,IWL ) ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + VARNM = 'TAUO3_TOP_W' // WLTXT( IWL ) + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, + & OTIME, TAUO3_TOP_WL( :,:,IWL ) ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + VARNM = 'ALBEDO_W' // WLTXT( IWL ) + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, + & SURFACE_ALBEDO( IWL,:,: ) ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + 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 )' ) + & '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, 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' + 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 L = 1, N_DIAG_WVL + IWL = DIAG_WVL( L ) + + VARNM = 'ACTINIC_FX_W' // WLTXT( IWL ) + 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 + + VARNM = 'AERO_SSA_W' // WLTXT( IWL ) + 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_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 = '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 = '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 )' ) + & 'Radiative and Optical Data written to', CTM_RJ_3, + & 'for date and time', ODATE, OTIME + + 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 /) + +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/model/src/rbdriver.F b/src/model/src/rbdriver.F new file mode 100644 index 0000000..d982542 --- /dev/null +++ b/src/model/src/rbdriver.F @@ -0,0 +1,778 @@ + +!------------------------------------------------------------------------! +! 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. ! +!------------------------------------------------------------------------! + + SUBROUTINE CHEM( CONC, JDATE, JTIME, TSTEP ) + +C********************************************************************** +C +C Function: To control gas phase chemistry calculations performed by +C the vectorized Rosenbrock solver +C +C Preconditions: None +C +C Key Subroutines/Functions Called: RBINIT +C RBSPARSE +C CALCKS +C RBSOLVER +C FIND_DEGRADED +C INIT_DEGRADE +C FINAL_DEGRADE +C +C Revision History: Prototype created by Jerry Gipson, August, 2004 +C Based on the solver described by Sandu et al +C ( Atm. Env., Vol. 31, No. 20, 1997 ) and included +C in the Kinetic PreProcessor ( see for example +C Sandu et al., At, Env., Vol. 37, 5097-5114, +C 2003). This code also incorporates efficiency +C concepts originally developed by M. Jacobson +C for SMVGEAR (Atm. Env., Vol 28, No 2, 1994). +C Adapted from Subroutine CHEM in CMAQ SMVGEAR +C +C 31 Jan 05 J.Young: dyn alloc - establish both horizontal +C & vertical domain specifications in one module (GRID_CONF) +C 29 Jul 05 WTH: Added IF blocks that call degrade +C routines if MECHNAME contains 'TX' +C substring. +C 28 Jun 10 J.Young: convert for Namelist redesign +C 29 Mar 11 S.Roselle: Replaced I/O API include files +C with UTILIO_DEFN +C 31 Aug 11 B.Hutzell revised method that determines calling +C degrade routine +C 29 Sep 11 D.Wong: incorporated twoway model implementation +C 18 Jan 13 B.Hutzell: 1) added using heteorogeneous rate constants +C by using function in AEROSOL_CHEMISTRY module, +C 15 Jul 14 B.Hutzell: 1) replaced mechanism include files with +C RXNS_DATA module, 2) replaced call to CALCLK with CALC_RCONST in +C RXNS_FUNCTION module, 3) enabled reactions between all species +C types by using unit conversion factors and 4) revised usage for +C INIT_DEGRADE and FINAL_DEGRADE routines +C 02 Dec 14 B.Hutzell 1) added terrestrial data to conduct surface +C dependent reactions and 2) modified the call CALC_RCONST routine +C 16 Sep 16 J.Young: update for inline procan (IRR) +C 21 Mar 22 G . Sarwar: updated simple halogen chemistry +C********************************************************************** + + USE RXNS_DATA + USE RXNS_FUNCTION + USE GRID_CONF ! horizontal & vertical domain specifications + USE RBDATA ! ROS3 solver data + USE CGRID_SPCS ! CGRID mechanism species + USE UTILIO_DEFN + USE PHOT_MOD, Only: INIT_PHOT_SHARED, RJ ! photolysis rate, in-line module + USE AEROSOL_CHEMISTRY +! USE DEGRADE_SETUP_TOX, ONLY : NCELLS, N_REACT, RXTANT_MAP, + USE DEGRADE_ROUTINES, ONLY : NCELLS, N_REACT, RXTANT_MAP, + & ICELL_WRITE, WRITE_CELL, WRITE_BLOCK, + & FIND_DEGRADED, INIT_DEGRADE_BLK, FINAL_DEGRADE_BLK + USE PA_DEFN, Only: LIRR ! Process Anaylsis control and data variable + USE PA_IRR_CLT + USE CENTRALIZED_IO_MODULE, ONLY : INTERPOLATE_VAR, OCEAN, SZONE +#ifdef sens + USE DDM3D_CHEM + Use DDM3D_DEFN, Only: DATENUM, STARTDATE, IPT, IDATE, HIGH, NP, NPMAX, CKTIME +#endif + + IMPLICIT NONE + +C..Includes: + + INCLUDE SUBST_FILES_ID ! CMAQ files + INCLUDE SUBST_CONST ! CMAQ constants + +C..Arguments: + + REAL, POINTER :: CONC( :,:,:,: ) ! Concentrations + + INTEGER JDATE ! Current date (YYYYDDD) + INTEGER JTIME ! Current time (HHMMSS) + INTEGER TSTEP( 3 ) ! Time step vector (HHMMSS) + +C..Parameters: + + INTEGER, PARAMETER :: IZERO = 0 ! Integer zero + + REAL, PARAMETER :: CONCMIN = 1.0E-30 ! Minimum conc + REAL, PARAMETER :: CONCOFM = 1.0E+06 ! conc. of M = 1E+06 ppm + REAL, PARAMETER :: PA2ATM = 1.0 / STDATMPA ! Pascal to atm conv fac + REAL, PARAMETER :: MAOMV = MWAIR / MWWAT ! Mol Wt of air over Mol Wt of water + REAL, PARAMETER :: QV_TO_PPM = CONCOFM * MAOMV ! factor to convert water wapor into ppm +C..External Functions: + +C..Local Variables: + + LOGICAL, SAVE :: LFIRST = .TRUE. ! Flag for first call to this subroutine + LOGICAL, SAVE :: FIRSTCALL = .TRUE. ! Another Flag for first call + LOGICAL, SAVE :: LIRRBLK ! Flag for IRR to be done for block + + INTEGER, SAVE :: NOXYZ ! Total number of grid cells + + REAL, SAVE :: AIRFC ! Factor to convert gms air to ppm + + REAL( 8 ) :: CHEMSTEP ! Chem integration interval (min) + REAL( 8 ) :: VALLOW ! Value holder for sort routine + + CHARACTER( 16 ) :: PNAME = 'RBDRIVER' ! Procedure name + CHARACTER( 16 ) :: VNAME ! Name of I/O API data variable + CHARACTER( 144 ) :: MSG ! Message text + + INTEGER C, R, L, S ! Loop indices + INTEGER ALLOCSTAT ! Allocate status code + INTEGER OFFSET ! Starting cell number of a block + INTEGER NCSP ! Mech no: 1=gas/day 2=gas/night + INTEGER BLK ! Loop index for block of cells + INTEGER CELLNUM ! Cell number + INTEGER COL ! Column index + INTEGER IPAR ! Pointer for cell sort routine + INTEGER IRVAL ! Pointer for cell sort routine + INTEGER IRXN ! Reaction number + INTEGER ISP ! Species index + INTEGER ISPOLD ! Species number in original order + INTEGER ISPNEW ! Species number in new sorted order + INTEGER ITMSTEP ! Chemistry integration interval (sec) + INTEGER JPAR ! Pointer for cell sort routine + INTEGER JREORD ! Index holder for sort routine + INTEGER LEV ! Layer index + INTEGER LVAL ! Pointer for cell sort routine + INTEGER MIDDATE ! Date at time step midpoint + INTEGER MIDTIME ! Time at time step midpoint + INTEGER NCELL ! Index for number of cells + INTEGER NIRRCLS ! No. of cells in block for IRR + INTEGER NPH ! Index for number of phot. rxns in PHOT + INTEGER NRX ! Index for number of reactions + INTEGER ROW ! Row index + INTEGER SPC ! Species loop index + INTEGER VAR ! Variable number on I/O API file + + INTEGER NUMB_CELLS + + INTEGER, ALLOCATABLE, SAVE :: IRRCELL( : ) ! Cell No. of an IRR cell + + REAL, ALLOCATABLE, SAVE :: SEAICE ( :, : ) ! fractional seaice cover, [-] + +! REAL, ALLOCATABLE, SAVE :: DENSA_J( :, :, : ) ! Cell density (Kg/m**3) + REAL, ALLOCATABLE, SAVE :: DENS ( :, :, : ) ! Cell density (Kg/m**3) + REAL, ALLOCATABLE, SAVE :: PRES ( :, :, : ) ! Cell pressure (Pa) + REAL, ALLOCATABLE, SAVE :: QV ( :, :, : ) ! Cell water vapor (Kg/Kg air) + REAL, ALLOCATABLE, SAVE :: TA ( :, :, : ) ! Cell temperature (K) + + REAL, ALLOCATABLE, SAVE :: SEAWATER_ZONE ( :,: ) ! fractional area of OPEN+SURF + + + REAL( 8 ), ALLOCATABLE, SAVE :: BLKHET( :, : ) +#ifdef rbstats + + CHARACTER( 16 ), SAVE :: CTM_RBSTATS_1 = 'CTM_RBSTATS_1' + CHARACTER( 16 ), ALLOCATABLE, SAVE :: VSTATS( : ) ! + + INTEGER, SAVE :: WSTEP = 0 + INTEGER, ALLOCATABLE, SAVE :: STAT_SUM( :,:,:,: ) + INTEGER EDATE, ETIME + + REAL ALLOCATABLE, SAVE :: STATOUT( :, :, : ) + +#endif + + INTERFACE + SUBROUTINE RBSOLVER ( JDATE, JTIME, CHEMSTEP, NCSP, + & LIRRFLAG, NIRRCLS, IRRCELL ) + INTEGER, INTENT( IN ) :: JDATE, JTIME + REAL( 8 ), INTENT( IN ) :: CHEMSTEP + INTEGER, INTENT( IN ) :: NCSP + LOGICAL, INTENT( IN ) :: LIRRFLAG + INTEGER, INTENT( INOUT ) :: NIRRCLS + INTEGER, INTENT( IN ) :: IRRCELL( : ) + END SUBROUTINE RBSOLVER + SUBROUTINE HETCHEM_UPDATE_AERO( CGRID ) + REAL, POINTER :: CGRID( :,:,:,: ) ! species concentration in cell + END SUBROUTINE HETCHEM_UPDATE_AERO + END INTERFACE + +C********************************************************************** + + +#ifdef isam + MSG = 'ERROR: Rosenbrock Chemistry Solver does not perform source apportionment.' + WRITE(LOGDEV,'(A)')TRIM( MSG ) + MSG = 'Must use the EBI solver for the chemical mechanism' + CALL M3EXIT( PNAME, JDATE, JTIME, MSG, XSTAT1 ) +#endif + + + IF ( NUMB_MECH_SPC .EQ. 0 ) THEN + CALL M3MESG( '*** WARNING: Gas-Chemistry processing bypassed!' ) + RETURN + END IF + +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c On first call, call routines to set-up for Gear solver and +c set-up to do emissions here if that option is invoked +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + IF ( LFIRST ) THEN + LFIRST = .FALSE. + ROS3_LOG = LOGDEV +! GASLOG = LOGDEV + + IF ( .NOT. CELLVAR_ALLOC() ) THEN + MSG = 'Failure allocating variables dependent on horizontal extents' + CALL M3EXIT( PNAME, JDATE, JTIME, MSG, XSTAT1 ) + END IF + + CALL RBINIT + CALL RBSPARSE( ) + CALL RESET_SPECIES_POINTERS( IOLD2NEW ) + + NOXYZ = NCOLS * NROWS * NLAYS + +C...Initialize and report data + + WRITE( LOGDEV, 92020 ) NOXYZ, BLKSIZE, NBLKS, BLKLEN( 1 ), BLKLEN( NBLKS ) + + WRITE( LOGDEV, 92040 ) GLBL_RTOL, GLBL_ATOL + +C.. Get fractional seawater coverage from the OCEAN file. + ALLOCATE( SEAWATER_ZONE( NCOLS, NROWS ) ) + + DO ROW = 1, NROWS + DO COL = 1, NCOLS + SEAWATER_ZONE( COL,ROW ) = OCEAN( COL,ROW ) + SZONE( COL,ROW ) + END DO + END DO + + STARTCOLCO = COLSX_PE( 1, MYPE + 1 ) + ENDCOLCO = COLSX_PE( 2, MYPE + 1 ) + STARTROWCO = ROWSX_PE( 1, MYPE + 1 ) + ENDROWCO = ROWSX_PE( 2, MYPE + 1 ) + + ALLOCATE( DENS( NCOLS, NROWS, NLAYS ), PRES( NCOLS, NROWS, NLAYS ), + & QV ( NCOLS, NROWS, NLAYS ), TA ( NCOLS, NROWS, NLAYS ), + & SEAICE( NCOLS, NROWS ) ) + + ALLOCATE( IRRCELL( BLKSIZE ) ) + IRRCELL = 0 + +c..Open file for solver stats if requested +#ifdef rbstats + ALLOCATE( VSTATS( 3 ) ) + VSTATS( 1 ) = 'N_STRT_FAILS' + VSTATS( 2 ) = 'N_FAILS' + VSTATS( 3 ) = 'N_STEPS' + + IF ( MYPE .EQ. 0 ) THEN + + IF ( .NOT. OPEN3( CTM_CONC_1, FSREAD3, PNAME ) ) THEN + MSG = 'Could not open ' // CTM_CONC_1 // ' file for readonly' + CALL M3EXIT( PNAME, JDATE, JTIME, MSG, XSTAT2 ) + END IF + + IF ( .NOT. DESC3( CTM_CONC_1 ) ) THEN + MSG = 'Could not get description of concentration file ' + & // CTM_CONC_1 + CALL M3EXIT( PNAME, JDATE, JTIME, MSG, XSTAT2 ) + END IF + + EDATE = JDATE + ETIME = JTIME + CALL NEXTIME( EDATE, ETIME, TSTEP( 1 ) ) + + SDATE3D = EDATE + STIME3D = ETIME + NVARS3D = 3 + NCOLS3D = GL_NCOLS + NROWS3D = GL_NROWS + NLAYS3D = NLAYS + VNAME3D( 1 ) = 'N_STRT_FAILS' + VNAME3D( 2 ) = 'N_FAILS' + VNAME3D( 3 ) = 'N_STEPS' + VDESC3D( 1 ) = 'Number of fails at start' + VDESC3D( 2 ) = 'Number of step fails' + VDESC3D( 3 ) = 'Number of steps' + UNITS3D( 1 ) = '' + UNITS3D( 2 ) = '' + UNITS3D( 3 ) = '' + VTYPE3D( 1 ) = M3REAL + VTYPE3D( 2 ) = M3REAL + VTYPE3D( 3 ) = M3REAL + IF ( .NOT. OPEN3( CTM_RBSTATS_1, FSNEW3, PNAME ) ) THEN + MSG = 'Could not create '// TRIM( CTM_RBSTATS_1 ) // ' file' + CALL M3EXIT( PNAME, SDATE3D, STIME3D, MSG, XSTAT2 ) + END IF + + END IF + + ALLOCATE( STAT_SUM( NCOLS, NROWS, NLAYS, 3 ) ) + ALLOCATE( STATOUT( NCOLS, NROWS, NLAYS ) ) + + + STAT_SUM = 0 + +#endif + +C..Initialize shared photolysis data + CALL INIT_PHOT_SHARED() + + ALLOCATE( BLKHET( BLKSIZE, NHETERO ) ) + +C Determine whether DEGRADE rountines are needed. + + CALL FIND_DEGRADED( JDATE, JTIME, CALL_DEG ) + IF( CALL_DEG ) THEN + WRITE( LOGDEV, * ) 'DEGRADE ROUTINES USED' + WRITE( LOGDEV, * ) 'Mechanism contains degraded species' +#ifdef verbose_gas + ALLOCATE( WRITE_CELL( BLKSIZE ) ) + ELSE + WRITE( LOGDEV, * ) 'DEGRADE ROUTINES not USED' + WRITE( LOGDEV, * ) 'Mechanism contains NO degraded species' +#endif + ENDIF + +C set up degradation array + + + ALLOCATE( Y_DEGRADE( BLKSIZE, NSPCSD ) ) + +#ifdef sens + CALL INIT_DDM3D_CHEM() + +C For higher order sensitivities + IF ( HIGH ) THEN + DO IRXN = 1, NRXNS + IF( NREACT( IRXN ) .LE. 1 ) THEN + ORDER1( IRXN ) = .TRUE. + ELSE + ORDER1( IRXN ) = .FALSE. + END IF + END DO + END IF +#endif + END IF ! First call + +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +C Start of integration driver after first call +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + NIRRCLS = 0 + +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +C Set date and time to center of time step, get necessary physical +C data, and get photolysis rates +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + MIDDATE = JDATE + MIDTIME = JTIME + ITMSTEP = TIME2SEC( TSTEP( 2 ) ) + CHEMSTEP = REAL( ITMSTEP, 8 ) / 60.0D0 + CALL NEXTIME( MIDDATE, MIDTIME, SEC2TIME( ITMSTEP / 2 ) ) + +C.. Get fractional seaice coverage from the METCRO2D file. + + CALL INTERPOLATE_VAR ('SEAICE', MIDDATE, MIDTIME, SEAICE) + +C.. Get ambient temperature in K + + CALL INTERPOLATE_VAR ('TA', MIDDATE, MIDTIME, TA) + +C.. Get specific humidity in Kg H2O / Kg air + CALL INTERPOLATE_VAR ('QV', MIDDATE, MIDTIME, QV) + +! Get ambient MASS DENSITY in Kg/m^3 + CALL INTERPOLATE_VAR ('DENS', MIDDATE, MIDTIME, DENS) + +C.. Get pressure in Pascals + CALL INTERPOLATE_VAR ('PRES', MIDDATE, MIDTIME, PRES) + +C.. Get Heterogeneous Rates using Aerosol Surface Area. Also Store +C a snapshot of the aerosol surface area so that it can be +C appropriately updated after the solver finds a solution. + + CALL HETCHEM_RATES( TA, PRES, QV, CONC, DENS ) + +#ifdef sens +C Set the date and hour counters used in sensitivity calls + DATENUM = 1 + JDATE - STARTDATE + +C For reaction rate sensitivities + DO NP = 1, NPMAX + IF ( IPT( NP ) .EQ. 5 ) THEN + CALL CKTIME( JDATE,JTIME,NP,RXNFLAG(NP) ) ! Rxnflag set to true if ipt=5 and time, date within bounds + IF ( IDATE( NP, DATENUM ) .NE. 1 ) RXNFLAG( NP ) = .FALSE. + ELSE + RXNFLAG( NP ) = .FALSE. + END IF + END DO +#endif + +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c Set flag for reordering of cells and put cells in sequential +c order initially +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + LORDERING = .TRUE. + IF ( .NOT. LREORDER .OR. NBLKS .EQ. 1 ) LORDERING = .FALSE. + DO NCELL = 1, NOXYZ + NORDCELL( NCELL ) = NCELL + END DO + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +C Top of loop over blocks. This loop will be done once if +C no reordering, twice if reordering is required +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +100 CONTINUE + + ERRMX2 = 0.0D0 + + DO 500 BLK = 1, NBLKS + BLKID = BLK + NUMCELLS = BLKLEN( BLK ) + OFFSET = BLKCNO( BLK ) + IF ( .NOT. LORDERING .AND. LIRR ) THEN + LIRRBLK = .FALSE. + CALL PA_IRR_CKBLK ( NUMCELLS, LIRRBLK, OFFSET, + & CCOL, CROW, CLEV, NORDCELL, NIRRCLS, + & IRRCELL ) + END IF +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +C Put the grid cell physical data in the block arrays, converting +C pressure to atmospheres, water vapor to ppm, emissions to ppm/min, +C assigning seawater values +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + DO NCELL = 1, NUMCELLS + CELLNUM = NORDCELL( OFFSET + NCELL ) + COL = CCOL( CELLNUM ) + ROW = CROW( CELLNUM ) + LEV = CLEV( CELLNUM ) + BLKTEMP( NCELL ) = REAL( TA( COL,ROW,LEV ), 8 ) + BLKDENS( NCELL ) = REAL( DENS( COL,ROW,LEV ), 8 ) + BLKSVOL( NCELL ) = 1.0 / DENS( COL,ROW,LEV ) + BLKPRES( NCELL ) = REAL( PA2ATM * PRES( COL, ROW, LEV ), 8 ) + BLKCH2O( NCELL ) = REAL( MAX( QV_TO_PPM * QV( COL,ROW,LEV ), 0.0 ), 8) + BLKSEAWATER (NCELL) = MAX ( 0.0, ( SEAWATER_ZONE( COL,ROW ) - SEAICE (COL,ROW) ) ) + END DO + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +C Put the grid cell concentrations in the block arrays +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + DO ISP = 1, ISCHANG( NCS ) + SPC = CGRID_INDEX( ISP ) +! SPC = ISP + ISPNEW = IOLD2NEW( ISP,NCS ) + DO NCELL = 1, NUMCELLS + CELLNUM = NORDCELL( OFFSET + NCELL ) + COL = CCOL( CELLNUM ) + ROW = CROW( CELLNUM ) + LEV = CLEV( CELLNUM ) + IF( CONVERT_CONC( ISP ) )THEN + Y( NCELL,ISPNEW ) = REAL( MAX( FORWARD_CONV( ISP ) * BLKSVOL( NCELL ) + & * CONC( COL,ROW,LEV,SPC ), CONCMIN), 8 ) + ELSE + Y( NCELL,ISPNEW ) = REAL( MAX( CONC( COL,ROW,LEV,SPC ), CONCMIN), 8 ) + END IF + END DO + END DO + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +C Get photolytic, heteorogeneous and thermal rate constants & call solver +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + LSUNLIGHT = .FALSE. + + DO NCELL = 1, NUMCELLS + CELLNUM = NORDCELL( OFFSET + NCELL ) + COL = CCOL( CELLNUM ) ! wrong order + ROW = CROW( CELLNUM ) + LEV = CLEV( CELLNUM ) + DO NPH = 1, NHETERO + BLKHET( NCELL, NPH ) = KHETERO( NPH, COL, ROW, LEV ) + END DO + DO NPH = 1, NPHOTAB + RJBLK( NCELL,NPH ) = REAL( RJ( COL,ROW,LEV,NPH ), 8 ) + IF ( RJBLK( NCELL, NPH ) .GT. 0.0D0 ) LSUNLIGHT = .TRUE. + END DO + END DO + + CALL CALC_RCONST( BLKTEMP, BLKPRES, BLKCH2O, RJBLK, BLKHET, LSUNLIGHT, BLKSEAWATER, RKI, NUMCELLS ) + + IF ( LSUNLIGHT ) THEN + NCSP = NCS + ELSE + NCSP = NCS + 1 + END IF + +C update cell concentrations for degradation routines + + IF ( CALL_DEG ) THEN + + Y_DEGRADE = 0.0 + DO ISP = 1, NSPCSD + DO NCELL = 1, NUMCELLS + CELLNUM = NORDCELL( OFFSET + NCELL ) + COL = CCOL( CELLNUM ) + ROW = CROW( CELLNUM ) + LEV = CLEV( CELLNUM ) + Y_DEGRADE( NCELL,ISP ) = REAL(MAX( CONC( COL,ROW,LEV,ISP ), CONCMIN), 8 ) + END DO + END DO + +! Use FPP flag to check results from species degrade routines +#ifdef verbose_gas + WRITE_BLOCK = .FALSE. + ICELL_WRITE = 1 + DO NCELL = 1, NUMCELLS + CELLNUM = NORDCELL( OFFSET + NCELL ) + COL = CCOL( CELLNUM ) + ROW = CROW( CELLNUM ) + LEV = CLEV( CELLNUM ) + IF( LEV .EQ. 1 .AND. ROW .EQ. 1 .AND. COL .EQ. 1 )THEN + WRITE_BLOCK = .TRUE. + ICELL_WRITE = NCELL + WRITE_CELL( NCELL ) = .TRUE. + ELSE + WRITE_CELL( NCELL ) = .FALSE. + END IF + END DO +#endif + +C..initialize degradation routines + NCELLS = NUMCELLS + CALL INIT_DEGRADE_BLK( Y_DEGRADE, BLKTEMP, BLKDENS, BLKPRES, BLKCH2O, RJBLK, + & JDATE, JTIME ) + + END IF + +#ifdef rbstats + + NSTEPS = 0 + NFAILS = 0 + N_BAD_STARTS = 0 + +#endif + + CALL RBSOLVER( JDATE, JTIME, CHEMSTEP, NCSP, + & LIRRBLK, NIRRCLS, IRRCELL ) + +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +C If not ordering cells, save performance statistics and +C store updated concentrations. +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + IF ( .NOT. LORDERING ) THEN + +C..Update concentrations + DO ISP = 1, ISCHANG( NCS ) + ISPOLD = INEW2OLD( ISP,NCS ) + SPC = CGRID_INDEX( ISPOLD ) + DO NCELL = 1, NUMCELLS + CELLNUM = NORDCELL( OFFSET + NCELL ) + COL = CCOL( CELLNUM ) + ROW = CROW( CELLNUM ) + LEV = CLEV( CELLNUM ) + IF( CONVERT_CONC( ISPOLD ) )THEN + CONC( COL,ROW,LEV,SPC ) = REAL( REVERSE_CONV( ISPOLD ) + & * BLKDENS( NCELL ) * Y( NCELL,ISP ), 4) + ELSE + CONC( COL,ROW,LEV,SPC ) = REAL( Y( NCELL,ISP ), 4) + END IF + END DO + END DO + + + + + IF ( CALL_DEG ) THEN +C Update CGRID based on the degradation routines + CALL FINAL_DEGRADE_BLK( Y_DEGRADE ) + UPDATE_DEGRADED: DO ISP = 1, N_REACT + S = RXTANT_MAP( ISP ) + IF( S .LE. 0 )CYCLE UPDATE_DEGRADED + DO SPC = 1, NUMB_MECH_SPC + IF( S .EQ. CGRID_INDEX( SPC ) )CYCLE UPDATE_DEGRADED + END DO + DO NCELL = 1, NUMCELLS + CELLNUM = NORDCELL( OFFSET + NCELL ) + COL = CCOL( CELLNUM ) + ROW = CROW( CELLNUM ) + LEV = CLEV( CELLNUM ) + CONC( COL,ROW,LEV,S ) = REAL( Y_DEGRADE( NCELL,S ), 4) + END DO + END DO UPDATE_DEGRADED + END IF !WTH + +#ifdef sens + + NUMB_CELLS = NUMCELLS + + DO NCELL = 1, NUMB_CELLS + DO IRXN = 1, NRXNS + SRK( IRXN ) = RKI( NCELL,IRXN ) + IF ( HIGH ) THEN + IF ( NREACT( IRXN ) .LE. 1 ) THEN + SRK2( IRXN ) = 0.0 + ELSE IF ( NREACT( IRXN ) .EQ. 2 ) THEN + SRK2( IRXN ) = REAL( RKI( NCELL,IRXN ), 4 ) + ELSE IF ( NREACT( IRXN ) .EQ. 3 ) THEN + SRK2( IRXN ) = REAL( RKI( NCELL,IRXN ),4 ) + ELSE + SRK2( IRXN ) = 0.0 + END IF + END IF + END DO + + DO ISP = 1,NUMB_MECH_SPC +! ISPOLD = INEW2OLD( ISP,NCS ) +! YCDDM( ISPOLD ) = YAVE(NCELL,ISP) + YCDDM( ISP ) = YAVE(NCELL,ISP) + END DO + CELLNUM = NORDCELL( OFFSET + NCELL ) + COL = CCOL( CELLNUM ) + ROW = CROW( CELLNUM ) + LEV = CLEV( CELLNUM ) + +! CALL SOLVE_DDM3D_CHEM( COL,ROW,LEV,CHEMSTEP ) + CALL SOLVE_DDM3D_CHEM( COL,ROW,LEV,CHEMSTEP,IOLD2NEW,INEW2OLD ) + END DO + NUMCELLS = NUMB_CELLS +#endif + +#ifdef rbstats + + DO NCELL = 1, NUMCELLS + CELLNUM = NORDCELL( OFFSET + NCELL ) + COL = CCOL( CELLNUM ) + ROW = CROW( CELLNUM ) + LEV = CLEV( CELLNUM ) + STAT_SUM( COL,ROW,LEV,1 ) = STAT_SUM( COL,ROW,LEV,1 ) + & + N_BAD_STARTS + STAT_SUM( COL,ROW,LEV,2 ) = STAT_SUM( COL,ROW,LEV,2 ) + & + NFAILS + STAT_SUM( COL,ROW,LEV,3 ) = STAT_SUM( COL,ROW,LEV,3 ) + & + NSTEPS + END DO + +#endif + + IF ( LIRRBLK ) CALL PA_IRR_BLKENDC ( OFFSET, CCOL, CROW, CLEV, + & NORDCELL, NIRRCLS, IRRCELL ) + + END IF + +500 CONTINUE + +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +C End of block loop; reorder cells if necessary and go back do the +C block loop again. Taken from Jacobson 1994. +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + IF ( LORDERING ) THEN + LORDERING = .FALSE. + LVAL = NOXYZ / 2 + 1 + IRVAL = NOXYZ +600 CONTINUE + IF ( LVAL .GT. 1 ) THEN + LVAL = LVAL - 1 + VALLOW = ERRMX2( LVAL ) + JREORD = NORDCELL( LVAL ) + ELSE + VALLOW = ERRMX2( IRVAL ) + JREORD = NORDCELL( IRVAL ) + ERRMX2( IRVAL ) = ERRMX2( 1 ) + NORDCELL( IRVAL ) = NORDCELL( 1 ) + IRVAL = IRVAL - 1 + IF ( IRVAL.EQ.1 ) THEN + ERRMX2( IRVAL ) = VALLOW + NORDCELL( IRVAL ) = JREORD + GO TO 100 + END IF + END IF + IPAR = LVAL + JPAR = LVAL + LVAL +650 CONTINUE + IF ( JPAR .LE. IRVAL ) THEN + IF ( JPAR .LT. IRVAL ) THEN + IF ( ERRMX2( JPAR ) .LT. ERRMX2( JPAR + 1 ) ) JPAR = JPAR + 1 + END IF + IF ( VALLOW .LT. ERRMX2( JPAR )) THEN + ERRMX2( IPAR ) = ERRMX2( JPAR ) + NORDCELL( IPAR ) = NORDCELL( JPAR ) + IPAR = JPAR + JPAR = JPAR + JPAR + ELSE + JPAR = IRVAL + 1 + END IF + GO TO 650 + END IF + ERRMX2( IPAR ) = VALLOW + NORDCELL( IPAR ) = JREORD + GO TO 600 + END IF + + !Update Aerosol Surface Area + CALL HETCHEM_UPDATE_AERO( CONC ) + +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +C Output performance statistics if required and return +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +#ifdef rbstats + + WSTEP = WSTEP + TIME2SEC( TSTEP( 2 ) ) + EDATE = JDATE + ETIME = JTIME + CALL NEXTIME( EDATE, ETIME, TSTEP( 2 ) ) + IF ( WSTEP .GE. TIME2SEC( TSTEP( 1 ) ) ) THEN + + WSTEP = 0 + + DO S = 1, 3 + DO R = 1, NROWS + DO C = 1, NCOLS + DO L = 1, NLAYS + STATOUT( C, R, L ) = INT( STAT_SUM( C,R,L,S ) + & + 0.00001 ) + END DO + END DO + END DO + + IF ( .NOT. WRITE3( CTM_RBSTATS_1, VSTATS( S ), + & EDATE, ETIME, STATOUT ) ) THEN + XMSG = 'Could not write ' // CTM_RBSTATS_1 // ' file' + CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + END DO + + STAT_SUM = 0.0 + + END IF + +#endif + + + IF( FIRSTCALL )FIRSTCALL = .FALSE. + + RETURN + +C*********************** FORMAT STATEMENTS **************************** +92020 FORMAT( / 10X, 'Chemistry Solver Blocking Parameters ... ', + & / 10X, 'Domain Size (number of cells): ', I10 + & / 10X, 'Dimensioning Block Size (number of cells): ', I10 + & / 10X, 'Number of Blocks: ', I10 + & / 10X, 'Size of General Blocks: ', I10 + & / 10X, 'Size of Last Block: ', I10 ) +92040 FORMAT( / 10X, 'Rosenbrock Chemistry Solver Error Control ', + & 'Parameters ...', + & / 10X, 'RTOL : ', 1PE12.3, + & / 10X, 'ATOL : ', 1PE12.3, ' ppm' ) + + END + diff --git a/src/model/src/vdiffacmx.F b/src/model/src/vdiffacmx.F index 06954c4..3ec8114 100644 --- a/src/model/src/vdiffacmx.F +++ b/src/model/src/vdiffacmx.F @@ -16,13 +16,8 @@ ! subject to their copyright restrictions. ! !------------------------------------------------------------------------! - -C RCS file, release, date & time of last delta, author, state, [and locker] -C $Header: /project/yoj/arc/CCTM/src/vdiff/acm2/vdiffacm2.F,v 1.13 2012/01/19 14:37:47 yoj Exp $ - C::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -! SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, ICMP, CNGRD, DDEPJ, DDEPJ_FST ) - SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, ICMP, DDEPJ, DDEPJ_FST, CNGRD ) + SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, ICMP, CNGRD ) C----------------------------------------------------------------------- C Asymmetric Convective Model v2 (ACM2/ACM1) -- Pleim(2006/2014) @@ -30,7 +25,7 @@ SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, ICMP, DDEPJ, DDEPJ_FST, CNGRD ) C calculates vertical diffusion C Subroutines and Functions Called: -C INIT3, SEC2TIME, TIME2SEC, WRITE3, NEXTIME, +C SEC2TIME, TIME2SEC, WRITE3, NEXTIME, C M3EXIT, EDDYX, TRI, MATRIX, PA_UPDATE_EMIS, PA_UPDATE_DDEP C Revision History: @@ -46,17 +41,39 @@ SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, ICMP, DDEPJ, DDEPJ_FST, CNGRD ) C matrix solver C 30 May 14 J.Young: split vdiff calculation out of vdiff proc. C 07 Nov 14 J.Bash: Updated for the ASX_DATA_MOD shared data module. +C 02 Nov 2018: L.Zhou, S.Napelenok: isam implementation +C May 2019 J.Pleim Changed from sigma coords to Z coords for compatability w/ MPAS and WRF +C 12 Dec 19 S.L.Napelenok: ddm-3d implementation for version 5.3.1 +C 15 Jun 21 J. Pleim: implemented HONO fix for dry depsotion flux C----------------------------------------------------------------------- USE CGRID_SPCS ! CGRID mechanism species USE GRID_CONF - USE EMIS_DEFN + USE DESID_VARS, ONLY : VDEMIS_DIFF,DESID_LAYS + USE DESID_PARAM_MODULE, ONLY : DESID_N_SRM USE DEPV_DEFN USE ASX_DATA_MOD USE VDIFF_MAP USE UTILIO_DEFN - USE BIDI_MOD +! USE BIDI_MOD +! USE LSM_MOD, ONLY: N_LUFRAC +! USE VDIFF_DIAG, NLPCR => NLPCR_MEAN C USE PT3D_EMIS_DEFN + USE HGRD_DEFN,only : COLSX_PE, ROWSX_PE + USE BDSNP_MOD, only: GET_N_DEP +#ifdef isam + USE SA_DEFN, ONLY: N_SPCTAG, ISAM, VNAM_SPCTAG, TRANSPORT_SPC, + & SA_VDEMIS_DIFF, ITAG, NTAG_SA, NSPC_SA, + & S_SPCTAG, T_SPCTAG, SA_DDEP, OTHRTAG, ISAM_SPEC, + & L_NO3, SA_BIDI, BIDITAG, L_NH4 +#endif + +#ifdef sens + USE DDM3D_DEFN, ONLY : NP, NPMAX, SNGRD, S_DDEP, S_PLDV, SVDEMIS_DIFF, + & SENS, S_EMIS, S_DD, S_UU, S_DDBF, S_POL, + & S_DELC, S_PLDV_HONO +#endif + IMPLICIT NONE @@ -70,8 +87,6 @@ SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, ICMP, DDEPJ, DDEPJ_FST, CNGRD ) REAL, INTENT( INOUT ) :: SEDDY ( :,:,: ) ! flipped EDDYV REAL, INTENT( INOUT ) :: DDEP ( :,:,: ) ! ddep accumulator REAL, INTENT( INOUT ) :: ICMP ( :,:,: ) ! component flux accumlator - REAL, INTENT( INOUT ), OPTIONAL :: DDEPJ ( :,:,:,: ) ! ddep for mosaic - REAL, INTENT( INOUT ), OPTIONAL :: DDEPJ_FST( :,:,:,: ) ! ddep for stomtal/cuticular pathway REAL, INTENT( INOUT ) :: CNGRD ( :,:,:,: ) ! cgrid replacement C Parameters: @@ -80,6 +95,8 @@ SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, ICMP, DDEPJ, DDEPJ_FST, CNGRD ) REAL, PARAMETER :: THETA = 0.5, & THBAR = 1.0 - THETA +! REAL, PARAMETER :: EPS = 1.0E-06 + C External Functions: None C Local Variables: @@ -87,39 +104,128 @@ SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, ICMP, DDEPJ, DDEPJ_FST, CNGRD ) CHARACTER( 16 ), SAVE :: PNAME = 'VDIFFACMX' LOGICAL, SAVE :: FIRSTIME = .TRUE. + LOGICAL, SAVE :: SPECLOG = .TRUE. ! For BDSNP REAL, ALLOCATABLE, SAVE :: DD_FAC ( : ) ! combined subexpression REAL, ALLOCATABLE, SAVE :: DDBF ( : ) ! secondary DDEP - REAL, ALLOCATABLE, SAVE :: CMPF ( : ) ! intermediate CMP + REAl, ALLOCATABLE, SAVE :: CMPF ( : ) ! intermediate CMP REAL, ALLOCATABLE, SAVE :: CONC ( :,: ) ! secondary CGRID expression REAL, ALLOCATABLE, SAVE :: EMIS ( :,: ) ! emissions subexpression REAL DTDENS1 ! DT * layer 1 air density C ACM Local Variables + REAL :: EDDY ( NLAYS ) ! local converted eddyv + REAL MEDDY ! ACM2 intermediate var + REAL MBAR ! ACM2 mixing rate (S-1) + REAL :: MBARKS( NLAYS ) ! by layer + REAL :: MDWN ( NLAYS ) ! ACM down mix rate + REAL :: MFAC ( NLAYS ) ! intermediate loop factor + REAL :: AA ( NLAYS ) ! matrix column one + REAL :: BB1 ( NLAYS ) ! diagonal for MATRIX1 + REAL :: BB2 ( NLAYS ) ! diagonal for TRI + REAL :: CC ( NLAYS ) ! subdiagonal + REAL :: EE1 ( NLAYS ) ! superdiagonal for MATRIX1 + REAL :: EE2 ( NLAYS ) ! superdiagonal for TRI + REAL, ALLOCATABLE, SAVE :: DD ( :,: ) ! R.H.S + REAL, ALLOCATABLE, SAVE :: UU ( :,: ) ! returned solution REAL DFACP, DFACQ +! REAL :: DFSP( NLAYS ), DFSQ( NLAYS ) ! intermediate loop factors +! REAL DELC, DELP, RP, RQ REAL RP, RQ +! REAL :: LFAC1( NLAYS ) ! intermediate factor for CONVT +! REAL :: LFAC2( NLAYS ) ! intermediate factor for CONVT +! REAL :: LFAC3( NLAYS ) ! intermediate factor for eddy +! REAL :: LFAC4( NLAYS ) ! intermediate factor for eddy REAL, ALLOCATABLE, SAVE :: DEPVCR ( : ) ! dep vel in one cell + ! one cell for each landuse category REAL, ALLOCATABLE, SAVE :: EFAC1 ( : ) REAL, ALLOCATABLE, SAVE :: EFAC2 ( : ) REAL, ALLOCATABLE, SAVE :: POL ( : ) ! prodn/lossrate = PLDV/DEPV REAL PLDV_HONO ! PLDV for HONO REAL DEPV_NO2 ! dep vel of NO2 REAL DEPV_HNO3 ! dep vel of HNO3 - INTEGER, SAVE :: NO2_HIT, HONO_HIT, HNO3_HIT, NO2_MAP, HNO3_MAP - INTEGER, SAVE :: NH3_HIT +! REAL FNL ! ACM2 Variable +! INTEGER NLP, NL, LCBL + INTEGER, SAVE :: NO2_HIT = 0, HONO_HIT = 0, HNO3_HIT = 0, NO2_MAP= 0, HONO_MAP = 0, HNO3_MAP = 0 + INTEGER, SAVE :: O3_HIT = 0, O3_MAP = 0 + INTEGER, SAVE :: NH3_HIT = 0 +! REAL DTLIM, DTS, DTACM, RZ REAL DTS - - INTEGER, SAVE :: LOGDEV INTEGER ASTAT INTEGER C, R, L, S, V, I, J ! loop induction variables INTEGER MDATE, MTIME ! internal simulation date&time +!--Local Arrays for Z-coord implimentation + REAL :: DZH ( NLAYS ) ! ZF(L) - ZF(L-1) + REAL :: DZHI ( NLAYS ) ! 1/DZH + REAL :: DZFI ( NLAYS ) ! ZH(L+1) - ZH(L) + integer gl_c, gl_r + +#ifdef isam + REAL :: TOTAL_SA_NO2 + REAL, ALLOCATABLE, SAVE :: SA_DDBF( : ) + INTEGER IBGN, JSPCTAG + + REAL, ALLOCATABLE,SAVE :: SAEMIS( :,: ) + REAL, ALLOCATABLE,SAVE :: SACONC( :,: ) + REAL, ALLOCATABLE,SAVE :: SA_DD( :,: ) + REAL, ALLOCATABLE,SAVE :: SA_UU( :,: ) + + REAL, ALLOCATABLE,SAVE :: SAFRAC( : ) + REAL, ALLOCATABLE,SAVE :: SA_NO2( : ) + REAL, ALLOCATABLE,SAVE :: SA_SUM( : ) + + INTEGER, SAVE :: ISAM_INDEX_NO2 = 0 ! ...Index locating NO2 in ISAM + INTEGER, SAVE :: ISAM_INDEX_NH3 = 0 ! ...Index locating NH3 in ISAM + INTEGER, SAVE :: PLDV_INDEX_NH3 = 0 ! ...Index locating NH3 in PLDV + + INTEGER, ALLOCATABLE, SAVE :: ISAM_DEPV( : ) + INTEGER, ALLOCATABLE, SAVE :: INDEX_SA_HONO( : ) + INTEGER, ALLOCATABLE, SAVE :: INDEX_SA_NH3( : ) + + + CHARACTER( 16 ) :: ISAM_SPECIES + + INTEGER TOP, BOT + + REAL NH3_SUM +#endif + + +! INTERFACE +! SUBROUTINE MATRIX1 ( KL, A, B, E, D, X ) +! INTEGER, INTENT( IN ) :: KL +! REAL, INTENT( IN ) :: A( : ), B( : ), E( : ) +! REAL, INTENT( IN ) :: D( :,: ) +! REAL, INTENT( OUT ) :: X( :,: ) +! END SUBROUTINE MATRIX1 +! SUBROUTINE TRI ( L, D, U, B, X ) +! REAL, INTENT( IN ) :: L( : ), D( : ), U( : ) +! REAL, INTENT( IN ) :: B( :,: ) +! REAL, INTENT( OUT ) :: X( :,: ) +! END SUBROUTINE TRI + +#ifdef isam + SUBROUTINE SA_MATRIX1 ( KL, A, B, E, D, X ) + INTEGER, INTENT( IN ) :: KL + REAL, INTENT( IN ) :: A( : ), B( : ), E(: ) + REAL, INTENT( IN ) :: D( :,: ) + REAL, INTENT( OUT ) :: X( :,: ) + END SUBROUTINE SA_MATRIX1 + + SUBROUTINE SA_TRI ( L, D, U, B, X ) + REAL, INTENT( IN ) :: L( : ), D( : ), U( : ) + REAL, INTENT( IN ) :: B( :,: ) + REAL, INTENT( OUT ) :: X( :,: ) + END SUBROUTINE SA_TRI +#endif +! END INTERFACE + C----------------------------------------------------------------------- IF ( FIRSTIME ) THEN FIRSTIME = .FALSE. - LOGDEV = INIT3() MDATE = 0; MTIME = 0 @@ -150,48 +256,371 @@ SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, ICMP, DDEPJ, DDEPJ_FST, CNGRD ) END IF CONC = 0.0; EMIS = 0.0 ! array assignment +! ALLOCATE ( DD( N_SPC_DIFF,NLAYS ), +! & UU( N_SPC_DIFF,NLAYS ), STAT = ASTAT ) +! IF ( ASTAT .NE. 0 ) THEN +! XMSG = 'Failure allocating DD or UU' +! CALL M3EXIT( PNAME, MDATE, MTIME, XMSG, XSTAT1 ) +! END IF +! DD = 0.0; UU = 0.0 ! array assignment + HONO_HIT = 0; HNO3_HIT = 0; NO2_HIT = 0; NH3_HIT = 0 - HNO3_MAP = 0; NO2_MAP = 0 + HONO_MAP = 0; HNO3_MAP = 0; NO2_MAP = 0 DO V = 1, N_SPC_DEPV IF ( DV2DF_SPC( V ) .EQ. 'NO2' ) THEN NO2_HIT = V NO2_MAP = DV2DF( V ) ELSE IF ( DV2DF_SPC( V ) .EQ. 'HONO' ) THEN HONO_HIT = V + HONO_MAP = DV2DF( V ) ELSE IF ( DV2DF_SPC( V ) .EQ. 'HNO3' ) THEN HNO3_HIT = V HNO3_MAP = DV2DF( V ) ELSE IF ( DV2DF_SPC( V ) .EQ. 'NH3' ) THEN NH3_HIT = V + ELSE IF ( DV2DF_SPC( V ) .EQ. 'O3' ) THEN + O3_HIT = V + O3_MAP = DV2DF( V ) + END IF + END DO + +#ifdef isam + ALLOCATE ( SA_DDBF( N_SPCTAG ), + & SACONC( N_SPCTAG, NLAYS ), + & SAEMIS( N_SPCTAG, NLAYS ), + & SA_DD ( N_SPCTAG, NLAYS ), + & SA_UU ( N_SPCTAG, NLAYS ), STAT = ASTAT ) + IF ( ASTAT .NE. 0 ) THEN + XMSG = 'Failure ISAM diffusion variables' + CALL M3EXIT( PNAME, MDATE, MTIME, XMSG, XSTAT1 ) + END IF + ALLOCATE ( SAFRAC ( N_SPCTAG ), + & SA_SUM ( NSPC_SA ), + & ISAM_DEPV( N_SPCTAG ), STAT = ASTAT ) + IF ( ASTAT .NE. 0 ) THEN + XMSG = 'Failure ISAM depv variables' + CALL M3EXIT( PNAME, MDATE, MTIME, XMSG, XSTAT1 ) + END IF + + ALLOCATE ( SA_NO2( NTAG_SA ), + & INDEX_SA_HONO( NTAG_SA ), + & INDEX_SA_NH3 ( NTAG_SA ), STAT = ASTAT ) + IF ( ASTAT .NE. 0 ) THEN + XMSG = 'Failure ISAM HONO/NH3 variables' + CALL M3EXIT( PNAME, MDATE, MTIME, XMSG, XSTAT1 ) + END IF + + SACONC = 0.0 + SAEMIS = 0.0 + SA_DD = 0.0 + SA_UU = 0.0 + + SAFRAC = 0.0 + ISAM_DEPV = 0 + SA_NO2 = 1.0 / REAL( NTAG_SA ) + INDEX_SA_HONO = 0 + INDEX_SA_NH3 = 0 + +! set default partitioning of surface fluxes + DO JSPCTAG = 1, N_SPCTAG + IF ( T_SPCTAG( JSPCTAG ) .EQ. OTHRTAG ) THEN + SAFRAC( JSPCTAG ) = 1.0 + ELSE + SAFRAC( JSPCTAG ) = 0.0 END IF END DO +! find NO2 in tracked species + DO S = 1, NSPC_SA + IF( ISAM_SPEC( S,1 ) .EQ. 'NO2' )THEN + ISAM_INDEX_NO2 = S + EXIT + END IF + END DO + +! find NH3 in tracked species + IF ( SA_BIDI ) THEN + DO S = 1, NSPC_SA + IF( ISAM_SPEC( S,1 ) .EQ. 'NH3' )THEN + ISAM_INDEX_NH3 = S + EXIT + END IF + END DO + S = -1 + S = INDEX1( 'NH3', N_SPC_DEPV, DEPV_SPC ) + IF ( S .GT. 0 ) THEN + PLDV_INDEX_NH3 = S + ELSE + XMSG = 'NH3 not found in DEPV_SPC array' + CALL M3EXIT( 'PLDV_INDEX_NH3', 0, 0, XMSG, XSTAT1 ) + END IF + END IF + +! set indices determining depv treatment, equals zero if none + ITAG = 0 + WRITE(LOGDEV,'(/,A7,1X,2(A16,1X))')'JSPCTAG','ISAM_SPECIES','DEPV Value' + DO JSPCTAG = 1, N_SPCTAG + ISAM_SPECIES = ISAM_SPEC( S_SPCTAG( JSPCTAG ),1 ) + IF( TRIM( ISAM_SPECIES ) .EQ. 'HONO' )THEN + ITAG = ITAG + 1 + INDEX_SA_HONO( ITAG ) = JSPCTAG + END IF + DO V = 1, N_SPC_DEPV + IF ( TRIM( ISAM_SPECIES ) .EQ. DV2DF_SPC( V ) ) THEN + ISAM_DEPV( JSPCTAG ) = V + END IF + END DO + END DO + WRITE(LOGDEV,'(/,A4,1X,A13,1X,A16)')'ITAG','INDEX_SA_HONO','ISAM_SPECIES' + DO ITAG = 1, NTAG_SA + JSPCTAG = INDEX_SA_HONO( ITAG ) + IF ( JSPCTAG .GT. 0 ) THEN + WRITE(LOGDEV,'(I2,3X,I4,8X,A16)')ITAG,JSPCTAG,VNAM_SPCTAG( JSPCTAG ) + ELSE + WRITE(LOGDEV,'(I2,3X,I4,8X,A16)')ITAG,JSPCTAG,'MISSING' + END IF + END DO +c WRITE(LOGDEV,* )'TAG_species, Default Partitioning Coeff.' +c DO JSPCTAG = 1, N_SPCTAG +c WRITE(LOGDEV,*)VNAM_SPCTAG( JSPCTAG ),' ,',SAFRAC( JSPCTAG ) +c END DO + IF ( ABFLUX .AND. L_NH4 ) THEN + ITAG = 0 + DO JSPCTAG = 1, N_SPCTAG + ISAM_SPECIES = ISAM_SPEC( S_SPCTAG( JSPCTAG ),1 ) + IF( TRIM( ISAM_SPECIES ) .EQ. 'NH3' )THEN + ITAG = ITAG + 1 + INDEX_SA_NH3( ITAG ) = JSPCTAG + END IF + END DO + +c DO ITAG = 1, NTAG_SA +c JSPCTAG = INDEX_SA_NH3( ITAG ) +c SAFRAC( JSPCTAG ) = 0.0 ! to not double count the bi-di emmissions +c END DO + END IF +#endif + +#ifdef sens + ALLOCATE ( S_POL ( NPMAX, N_SPC_DEPV ), STAT = ASTAT ) + IF ( ASTAT .NE. 0 ) THEN + XMSG = 'Failure allocating S_POL' + CALL M3EXIT( PNAME, MDATE, MTIME, XMSG, XSTAT1 ) + END IF + S_POL = 0.0 + + ALLOCATE ( S_DDBF( N_SPC_DEPV, NPMAX ), STAT = ASTAT ) + IF ( ASTAT .NE. 0 ) THEN + XMSG = 'Failure allocating S_DBF' + CALL M3EXIT( PNAME, MDATE, MTIME, XMSG, XSTAT1 ) + END IF + S_DDBF = 0.0 + + ALLOCATE ( SENS( N_SPC_DIFF,NLAYS,NPMAX ), + & S_EMIS( N_SPC_DIFF,NLAYS,NPMAX ), STAT = ASTAT ) + IF ( ASTAT .NE. 0 ) THEN + XMSG = 'Failure allocating SENS or S_EMIS' + CALL M3EXIT( PNAME, MDATE, MTIME, XMSG, XSTAT1 ) + END IF + SENS = 0.0; S_EMIS = 0.0 ! array assignment + + ALLOCATE ( S_DD( N_SPC_DIFF,NLAYS,NPMAX ), + & S_UU( N_SPC_DIFF,NLAYS,NPMAX ), STAT = ASTAT ) + IF ( ASTAT .NE. 0 ) THEN + XMSG = 'Failure allocating S_DD or S_UU' + CALL M3EXIT( PNAME, MDATE, MTIME, XMSG, XSTAT1 ) + END IF + S_DD = 0.0; S_UU = 0.0 ! array assignment + + ALLOCATE ( S_PLDV_HONO( NPMAX ), STAT = ASTAT ) + IF ( ASTAT .NE. 0 ) THEN + XMSG = 'Failure allocating S_PLDV_HONO' + CALL M3EXIT( PNAME, MDATE, MTIME, XMSG, XSTAT1 ) + END IF + S_PLDV_HONO = 0.0 ! array assignment + + +#endif END IF ! if Firstime -C CALL GET_PT3D_EMIS () C ------------------------------------------- Row, Col LOOPS ----------- DTS = DTSEC + DO 345 R = 1, NROWS + DO 344 C = 1, NCOLS + + DZH(1) = Met_Data%ZF( C,R,1 ) + DZHI(1) = 1./DZH(1) + DO L = 2, NLAYS + DZH(L) = Met_Data%ZF( C,R,L ) - Met_Data%ZF( C,R,L-1 ) + DZHI(L) = 1./DZH(L) + ENDDO + DO L = 1, NLAYS - 1 + DZFI(L) = 1. / ( Met_Data%ZH( C,R,L+1 ) - Met_Data%ZH( C,R,L ) ) + ENDDO + DZFI(NLAYS) = DZFI(NLAYS-1) + +!C for ACM time step +! DTLIM = DTSEC +! +!C dt = .75 dzf*dzh / Kz +! DO L = 1, NLAYS - 1 +! DTLIM = MIN( DTLIM, 0.75 / ( SEDDY( L,C,R ) * DZHI(L)*DZFI(L) ) ) +! END DO +! MBARKS = 0.0 ! array assignment +! MDWN = 0.0 ! array assignment +! +!C conjoin ACM & EDDY --------------------------------------------------- +! +! MBAR = 0.0 +! FNL = 0.0 +! +! IF ( Met_Data%CONVCT( C,R ) ) THEN ! Do ACM for this column +! LCBL = Met_Data%LPBL( C,R ) +! MEDDY = SEDDY( 1,C,R ) * DZFI(1) / (Met_Data%PBL( C,R ) - Met_Data%ZF(C,R,1)) +! FNL = 1.0 / ( 1.0 + ( ( KARMAN / ( -Met_Data%HOL( C,R ) ) ) ** 0.3333 ) +! & / ( 0.72 * KARMAN ) ) +! MBAR = MEDDY * FNL +! IF ( MEDDY .LT. EPS ) THEN +! gl_c = c + COLSX_PE(1,mype+1) -1 +! gl_r = r + ROWSX_PE(1,mype+1) -1 +! WRITE( LOGDEV,* ) ' Warning --- MEDDY < 1e-6 s-1' +! WRITE( LOGDEV,* ) ' SEDDY, MEDDY, FNL, HOL = ', +! & SEDDY( 1,C,R ), MEDDY, FNL, Met_Data%HOL( C,R ) +! XMSG = '*** ACM fails ***' +! WRITE( LOGDEV,*)' c,r=', gl_c,gl_r,' pbl,ust=',Met_Data%PBL( C,R ),Met_Data%USTAR( C,R ) +! CALL M3EXIT( PNAME, MDATE, MTIME, XMSG, XSTAT2 ) +! END IF - DO 345 R = 1, MY_NROWS - DO 344 C = 1, MY_NCOLS +! IF ( ( FNL .LE. 0.0 ) .OR. ! never gonna happen for CONVCT +! & ( LCBL .GE. NLAYS-1 ) .OR. ! .GT. never gonna happen +! & ( Met_Data%HOL( C,R ) .GT. -0.00001 ) ) ! never gonna happen +! & WRITE( LOGDEV,1015 ) LCBL, MBAR, FNL, SEDDY( 1,C,R ), Met_Data%HOL( C,R ) +!1015 FORMAT( ' LCBL, MBAR, FNL, SEDDY1, HOL:', I3, 1X, 4(1PE13.5) ) +! +! DO L = 2, LCBL +! SEDDY( L,C,R ) = ( 1.0 - FNL ) * SEDDY( L,C,R ) +! MBARKS( L ) = MBAR +! MDWN( L ) = MBAR * (Met_Data%PBL( C,R ) - Met_Data%ZF(C,R,L-1)) * DZHI(L) +! END DO +! SEDDY( 1,C,R ) = ( 1.0 - FNL ) * SEDDY( 1,C,R ) +! MBARKS(1) = MBAR +! MBARKS(LCBL) = MDWN(LCBL) +! MDWN(LCBL+1) = 0.0 +!C Modify Timestep for ACM2 +! RZ = (Met_Data%ZF(C,R,LCBL) - Met_Data%ZF(C,R,1)) * DZHI(1) +! DTACM = 1.0 / ( MBAR * RZ ) +! DTLIM = MIN( 0.75 * DTACM, DTLIM ) +! ELSE +! LCBL = 1 +! END IF + +!C----------------------------------------------------------------------- + +! NLP = INT( DTSEC / DTLIM + 0.99 ) +! IF ( VDIFFDIAG ) NLPCR( C,R ) = REAL( NLP ) +! DTS = DTSEC / REAL( NLP ) DTDENS1 = DTS * Met_Data%DENS1( C,R ) DFACP = THETA * DTS DFACQ = THBAR * DTS +!#ifdef Verbose_Vdiff +! IF ( R .EQ. NROWS / 2 .AND. C .EQ. NCOLS / 2 ) +! & WRITE( LOGDEV,1021 ) Met_Data%CONVCT( C,R ), DTS, EDDYV( C,R,1 ), MBAR, FNL +!1021 FORMAT( ' CONVCT, DTS, EDDYV, MBAR, FNL: ', L3, 1X, 4(1PE13.5) ) +!#endif + DO L = 1, NLAYS DO V = 1, N_SPC_DIFF CONC( V,L ) = CNGRD( DIFF_MAP( V ),L,C,R ) END DO +#ifdef isam + DO JSPCTAG = 1, N_SPCTAG + SACONC( JSPCTAG,L ) = ISAM( C,R,L,S_SPCTAG( JSPCTAG ),T_SPCTAG( JSPCTAG ) ) + END DO +#endif END DO +#ifdef sens + DO NP = 1, NPMAX + DO L = 1, NLAYS + DO V = 1, N_SPC_DIFF + SENS( V,L,NP ) = SNGRD( DIFF_MAP( V ),L,C,R,NP ) + END DO + END DO + END DO +#endif + +#ifdef isam + SA_SUM = 0.0 + DO V = 1, NSPC_SA + DO ITAG = 1, NTAG_SA + SA_SUM( V ) = SA_SUM( V ) + ISAM( C,R,1,V,ITAG ) + END DO + SA_SUM( V ) = MAX ( 1.0E-30, SA_SUM( V ) ) + END DO + + SAFRAC = 0.0 + DO JSPCTAG = 1, N_SPCTAG + SAFRAC( JSPCTAG ) = SACONC( JSPCTAG,1 ) / SA_SUM ( S_SPCTAG( JSPCTAG ) ) + END DO + + IF ( ABFLUX .AND. L_NH4 ) THEN + DO ITAG = 1, NTAG_SA + JSPCTAG = INDEX_SA_NH3( ITAG ) + SAFRAC( JSPCTAG ) = 0.0 ! to not double count the bi-di emmissions + END DO + END IF + + IF( L_NO3 .AND. SFC_HONO ) THEN +! compute the flux partitioning for HONO from NO2 surface reaction + DO ITAG = 1, NTAG_SA + SA_NO2( ITAG ) = MAX( ISAM( C,R,1,ISAM_INDEX_NO2,ITAG ), 1.0E-30 ) + END DO + TOTAL_SA_NO2 = 1.0 / SUM( SA_NO2 ) + DO ITAG = 1, NTAG_SA + JSPCTAG = INDEX_SA_HONO( ITAG ) + SAFRAC( JSPCTAG ) = SA_NO2( ITAG ) * TOTAL_SA_NO2 + END DO + END IF +#endif + EMIS = 0.0 ! array assignment - DO L = 1, EMLAYS - DO V = 1, N_SPC_DIFF - EMIS( V,L ) = DTS * VDEMIS( DF2EM( V ),L,C,R ) + IF ( DESID_N_SRM .GE. 1 ) + & EMIS( :,1:DESID_LAYS ) = DTS * VDEMIS_DIFF( :,:,C,R ) + +#ifdef isam + SAEMIS = 0.0 + +! modify ground emissions for bidirectional species (for bidi, PLVD > 0.0) + IF ( SA_BIDI ) THEN + SA_VDEMIS_DIFF( ISAM_INDEX_NH3,1,C,R,BIDITAG ) + & = PLDV(PLDV_INDEX_NH3,C,R) * Met_Data%RDEPVHT( C,R ) + END IF + +! collapse ISAM emissions array + DO L = 1, DESID_LAYS + DO ITAG = 1, NTAG_SA + BOT = (ITAG-1)*NSPC_SA+1 + TOP = NSPC_SA*ITAG + SAEMIS( BOT:TOP,L ) = DTS * SA_VDEMIS_DIFF( :,L,C,R,ITAG ) END DO END DO +#endif + +#ifdef sens + S_EMIS = 0.0 + DO NP = 1, NPMAX + S_EMIS( :,1:DESID_LAYS,NP ) = DTS * SVDEMIS_DIFF( :,:,C,R,NP ) + END DO +#endif + +! DO L = 1, NLAYS +! DFSP( L ) = DFACP * DZHI( L ) +! DFSQ( L ) = DFACQ * DZHI( L ) +! EDDY( L ) = SEDDY( L,C,R ) * DZFI(L) +! END DO RP = DFACP * Met_Data%RDEPVHT( C,R ) RQ = DFACQ * Met_Data%RDEPVHT( C,R ) @@ -202,17 +631,64 @@ SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, ICMP, DDEPJ, DDEPJ_FST, CNGRD ) EFAC1 ( V ) = EXP( -DEPVCR( V ) * RP ) EFAC2 ( V ) = EXP( -DEPVCR( V ) * RQ ) POL ( V ) = PLDV( V,C,R ) / DEPVCR( V ) - IF ( ABFLUX .AND. V .EQ. NH3_HIT ) THEN - DO I = 1, LCMP - CMPF( I ) = ICMP( I,C,R ) - END DO - END IF +#ifdef sens + DO NP = 1, NPMAX + S_POL ( NP,V ) = S_PLDV( NP,V,C,R ) / DEPVCR( V ) + S_DDBF( V, NP ) = S_DDEP( V, C, R, NP ) + END DO +#endif END DO PLDV_HONO = PLDV( HONO_HIT,C,R ) +#ifdef sens + DO NP = 1, NPMAX + S_PLDV_HONO( NP ) = S_PLDV( NP,HONO_HIT,C,R ) + END DO +#endif -C----------------------------------------------------------------------- +#ifdef isam + DO JSPCTAG = 1, N_SPCTAG + SA_DDBF( JSPCTAG ) = SA_DDEP( C,R,JSPCTAG ) + END DO +#endif - DO V = 1, N_SPC_DEPV +!C These don`t change in the NLP sub-time step loop:--------------------- +! DO L = 1, NLAYS +! AA ( L ) = 0.0 +! BB1( L ) = 0.0 +! EE1( L ) = 0.0 +! CC ( L ) = 0.0 +! EE2( L ) = 0.0 +! BB2( L ) = 0.0 +! END DO +! IF ( Met_Data%CONVCT( C,R ) ) THEN +! L = 1 +! DELP = Met_Data%PBL( C,R ) - Met_Data%ZF( C,R,L ) +! BB1( L ) = 1.0 + DELP * DFSP( L ) * MBARKS( L ) +! LFAC1( L ) = DFSQ( L ) * DELP * MBARKS( L ) +! LFAC2( L ) = DFSQ( L ) * MDWN( L+1 ) * DZH( L+1 ) +! DO L = 2, LCBL +! AA ( L ) = -DFACP * MBARKS( L ) +! BB1( L ) = 1.0 + DFACP * MDWN( L ) +! EE1( L ) = -DFSP( L-1 ) * DZH( L ) * MDWN( L ) +! MFAC( L ) = DZH( L+1 ) * DZHI( L ) * MDWN( L+1 ) +! END DO +! END IF +! +! DO L = 1, NLAYS +! EE2( L ) = - DFSP( L ) * EDDY( L ) +! LFAC3( L ) = DFSQ( L ) * EDDY( L ) +! END DO +! +! BB2( 1 ) = 1.0 - EE2( 1 ) +! DO L = 2, NLAYS +! CC ( L ) = - DFSP( L ) * EDDY( L-1 ) +! BB2( L ) = 1.0 - CC( L ) - EE2( L ) +! LFAC4( L ) = DFSQ( L ) * EDDY( L-1 ) +! END DO + +! DO 301 NL = 1, NLP ! loop over sub time + + DO V = 1, N_SPC_DEPV C --------- HET HONO RX ----------------- @@ -225,6 +701,12 @@ SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, ICMP, DDEPJ, DDEPJ_FST, CNGRD ) DEPV_HNO3 = DEPVCR( V ) + PLDV_HONO / CONC( NO2_MAP,1 ) DD_FAC( V ) = DTDENS1 * DD_CONV( V ) * DEPV_HNO3 DDBF( V ) = DDBF( V ) + THETA * DD_FAC( V ) * CONC( S,1 ) +#ifdef sens + DO NP = 1, NPMAX + SENS( S,1,NP ) = S_POL( NP,V ) + ( SENS( S,1,NP ) - S_POL( NP,V ) ) * EFAC1( V ) + S_DDBF( V, NP ) = S_DDBF( V, NP ) + THETA * DD_FAC( V ) * SENS ( S,1,NP ) + END DO +#endif C Use special treatment for NO2 C Loss of NO2 via the heterogeneous reaction is accounted for as an additional @@ -239,32 +721,347 @@ SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, ICMP, DDEPJ, DDEPJ_FST, CNGRD ) POL ( V ) = PLDV( V,C,R ) / DEPV_NO2 CONC( S,1 ) = POL( V ) + ( CONC( S,1 ) - POL( V ) ) * EFAC1( V ) DDBF( V ) = DDBF( V ) + THETA * DD_FAC( V ) * CONC( S,1 ) +#ifdef sens + DO NP = 1, NPMAX + S_POL( NP, V ) = S_PLDV( NP,V,C,R ) / DEPV_NO2 + SENS( S,1,NP ) = S_POL( NP,V ) + ( SENS( S,1,NP ) - S_POL( NP,V ) ) * EFAC1( V ) + S_DDBF( V, NP ) = S_DDBF( V, NP ) + THETA * DD_FAC( V ) * SENS ( S,1,NP ) + END DO +#endif + + ELSE IF ( V .EQ. HONO_HIT ) THEN + S = HONO_MAP + CONC( S,1 ) = POL( V ) + ( CONC( S,1 ) - POL( V ) ) * EFAC1( V ) + DDBF( V ) = DDBF( V ) + THETA * DD_FAC( V ) * CONC( S,1 ) +C Don't add HONO emissions as negative dep flux +! & - DTDENS1 * DD_CONV( V ) * PLDV( V,C,R ) ) +#ifdef sens + DO NP = 1, NPMAX + SENS( S,1,NP ) = S_POL( NP,V ) + ( SENS( S,1,NP ) - S_POL( NP,V ) ) * EFAC1( V ) + S_DDBF( V, NP ) = S_DDBF( V, NP ) + THETA * DD_FAC( V ) * SENS ( S,1,NP ) + END DO +#endif C --------- END of HET HONO RX ---------- ELSE + +C Pass selected N species to the BDSNP Soil NO emissions scheme + + IF ( MGN_ONLN_DEP ) THEN + + IF(SPECLOG) then + IF( V .eq. N_SPC_DEPV) THEN + SPECLOG = .false. ! no need to do any species more than once + WRITE( LOGDEV,*) 'BDSNP Species list complete', speclog + END IF + END IF + + IF ( (INDEX(TRIM( DV2DF_SPC( V ) ), 'NH3') .NE. 0) .OR. + & (INDEX(TRIM( DV2DF_SPC( V ) ), 'NH4') .NE. 0) .OR. + & (INDEX(TRIM( DV2DF_SPC( V ) ), 'HNO3').NE. 0) .OR. + & (INDEX(TRIM( DV2DF_SPC( V ) ), 'NO3') .NE. 0) .OR. + & (INDEX(TRIM( DV2DF_SPC( V ) ), 'NO2') .NE. 0) .OR. + & (INDEX(TRIM( DV2DF_SPC( V ) ), 'PAN') .NE. 0)) THEN + + + IF( SPECLOG ) THEN !write species each time it is used + WRITE( LOGDEV,*) 'BDSNP Dry Species Used:', TRIM(DV2DF_SPC( V ) ), V, N_SPC_DEPV + END IF + + IF ( ( DDBF(V)- DDEP( V,C,R) ) .LT. 0.0 ) THEN !negative error checking + + XMSG = 'Negative Deposition' +! WRITE( LOGDEV,*) 'BDSNP Negative Deposition vdiff, variable:', +! & TRIM( DV2DF_SPC( V )), ( DDBF(V)- DDEP( V,C,R) ), C, R +! CALL M3EXIT( PNAME, MDATE, MTIME, XMSG, XSTAT1 ) + CALL GET_N_DEP (DV2DF_SPC( V ), 0/ + & DTSEC, C, R ) + else + CALL GET_N_DEP (DV2DF_SPC( V ), ( DDBF(V)- DDEP( V,C,R) )/ + & DTSEC, C, R ) + END IF !end negative error checking + + + END IF !end species check + + END IF !end BDSNP check + S = DV2DF( V ) CONC( S,1 ) = POL( V ) + ( CONC( S,1 ) - POL( V ) ) * EFAC1( V ) - DDBF( V ) = DDBF( V ) + THETA * DD_FAC( V ) * CONC( S,1 ) + DDBF( V ) = DDBF( V ) + THETA * ( DD_FAC( V ) * CONC( S,1 ) +C Add evasion as negative dep flux + & - DTDENS1 * DD_CONV( V ) * PLDV( V,C,R ) ) + +#ifdef sens + DO NP = 1, NPMAX + SENS( S,1,NP ) = S_POL( NP,V ) + ( SENS( S,1,NP ) - S_POL( NP,V ) ) * EFAC1( V ) + S_DDBF( V, NP ) = S_DDBF( V, NP ) + THETA * ( DD_FAC( V ) * SENS( S, 1,NP ) + & - DTDENS1 * DD_CONV( V ) * S_PLDV( NP,V,C,R ) ) + END DO +#endif - IF ( ABFLUX .AND. V .EQ. NH3_HIT ) THEN - DO I = 1, LCMP - CMPF( I ) = CMPF( I ) + THETA * CMP( I,C,R ) * DD_CONV( V ) * DTDENS1 - END DO - END IF END IF END DO -C --------- ADD EMISSIONS --------------- - DO L = 1, NLAYS DO V = 1, N_SPC_DIFF +! DD( V,L ) = 0.0 +! UU( V,L ) = 0.0 CONC( V,L ) = CONC( V,L ) + EMIS( V,L ) +#ifdef sens + DO NP = 1, NPMAX + S_DD( V,L,NP) = 0.0 + S_UU( V,L,NP) = 0.0 + END DO +#endif + END DO + END DO + +#ifdef isam + DO JSPCTAG = 1, N_SPCTAG + S = ISAM_DEPV( JSPCTAG ) + IF ( S .GT. 0 ) THEN + SACONC( JSPCTAG,1 ) = SACONC( JSPCTAG,1 ) * EFAC1( S ) + & + SAFRAC( JSPCTAG ) * POL( S ) * ( 1.0 - EFAC1( S ) ) + SA_DDBF( JSPCTAG ) = SA_DDBF( JSPCTAG ) + & + THETA * DD_FAC( S ) * SACONC( JSPCTAG,1 ) + END IF + END DO + +c Recalculate bidi NH3 deposition + IF ( ABFLUX .AND. SA_BIDI ) THEN + NH3_SUM = 0.0 + DO JSPCTAG = 1, N_SPCTAG + S = ISAM_DEPV( JSPCTAG ) + IF ( S .EQ. NH3_HIT ) NH3_SUM = NH3_SUM + SACONC( JSPCTAG,1 ) + END DO + + DO JSPCTAG = 1, N_SPCTAG + S = ISAM_DEPV( JSPCTAG ) + IF ( S .EQ. NH3_HIT ) THEN + IF( NH3_SUM .GT. 1.0E-25 ) THEN + SA_DDBF( JSPCTAG ) = DDBF(NH3_HIT) * ( SACONC( JSPCTAG,1 ) / NH3_SUM ) + ELSE + SA_DDBF( JSPCTAG ) = 0.0 + END IF + END IF + END DO + END IF + + DO L = 1, NLAYS + DO V = 1, N_SPCTAG + SA_DD( V,L ) = 0.0 + SA_UU( V,L ) = 0.0 + END DO + END DO +#endif + +!C Compute tendency of CBL concentrations - semi-implicit solution +!C Set MATRIX1 elements A (col 1), B (diag.), E (superdiag.) and D (RHS) +! +! IF ( Met_Data%CONVCT( C,R ) ) THEN +! +! L = 1 +! DO V = 1, N_SPC_DIFF +! DD( V,L ) = CONC( V,L ) +! & - LFAC1( L ) * CONC( V,L ) +! & + LFAC2( L ) * CONC( V,L+1 ) +#ifdef sens + DO NP = 1, NPMAX + S_DD( V,L,NP ) = SENS( V,L,NP ) + & - LFAC1( L ) * SENS( V,L,NP ) + & + LFAC2( L ) * SENS( V,L+1,NP ) + END DO +#endif +! END DO + +#ifdef isam + DO JSPCTAG = 1, N_SPCTAG + SA_DD( JSPCTAG, L) = SACONC( JSPCTAG,L ) + & - LFAC1( L ) * SACONC( JSPCTAG,L ) + & + LFAC2( L ) * SACONC( JSPCTAG,L+1 ) + ENDDO +#endif + +! DO L = 2, LCBL +! DO V = 1, N_SPC_DIFF +! DELC = MBARKS( L ) * CONC( V,1 ) +! & - MDWN( L ) * CONC( V,L ) +! & + MFAC( L ) * CONC( V,L+1 ) +! DD( V,L ) = CONC( V,L ) + DFACQ * DELC +#ifdef sens + DO NP = 1, NPMAX + S_DELC = MBARKS( L ) * SENS( V,1,NP ) + & - MDWN( L ) * SENS( V,L,NP ) + & + MFAC( L ) * SENS( V,L+1,NP ) + S_DD( V,L,NP ) = SENS( V,L,NP ) + DFACQ * S_DELC + END DO +#endif +! END DO + +#ifdef isam + DO JSPCTAG = 1, N_SPCTAG + DELC = MBARKS( L ) * SACONC( JSPCTAG,1 ) + & - MDWN( L ) * SACONC( JSPCTAG,L ) + & + MFAC( L ) * SACONC( JSPCTAG,L+1 ) + SA_DD( JSPCTAG,L ) = SACONC( JSPCTAG,L ) + DFACQ * DELC + END DO +#endif + +! END DO + +! CALL MATRIX1 ( LCBL, AA, BB1, EE1, DD, UU ) +#ifdef isam + CALL SA_MATRIX1( LCBL, AA, BB1,EE1, SA_DD, SA_UU) +#endif + +#ifdef sens + DO NP = 1, NPMAX + CALL MATRIX1 ( LCBL, AA, BB1, EE1, S_DD(:,:,NP), S_UU(:,:,NP) ) END DO +#endif + + +!C update conc +! DO L = 1, LCBL +! DO V = 1, N_SPC_DIFF +! CONC( V,L ) = UU( V,L ) +#ifdef sens + DO NP = 1, NPMAX + SENS( V,L,NP ) = S_UU( V,L,NP ) + END DO +#endif +! END DO +#ifdef isam + DO JSPCTAG = 1, N_SPCTAG + SACONC ( JSPCTAG,L ) = SA_UU( JSPCTAG,L ) + ENDDO +#endif +! END DO + +!C reinitialize for TRI solver +! DO L = 1, NLAYS +! DO V = 1, N_SPC_DIFF +! DD( V,L ) = 0.0 +! UU( V,L ) = 0.0 +#ifdef sens + DO NP = 1, NPMAX + S_DD( V,L,NP ) = 0.0 + S_UU( V,L,NP ) = 0.0 + END DO +#endif +! END DO +#ifdef isam + DO JSPCTAG = 1, N_SPCTAG + SA_DD( JSPCTAG,L ) = 0.0 + SA_UU( JSPCTAG,L ) = 0.0 + ENDDO +#endif +! END DO + +! END IF + +! L = 1 +! DO V = 1, N_SPC_DIFF +! DD( V,L ) = CONC( V,L ) +! & + LFAC3( L ) * ( CONC( V,L+1 ) - CONC( V,L ) ) +! & + EMIS( V,L ) +#ifdef sens + DO NP = 1, NPMAX + S_DD( V,L,NP ) = SENS( V,L,NP ) + & + LFAC3( L ) * ( SENS( V,L+1,NP ) - SENS( V,L,NP ) ) + & + S_EMIS( V,L,NP ) + END DO +#endif +! END DO + +#ifdef isam + DO JSPCTAG = 1, N_SPCTAG + SA_DD( JSPCTAG,L ) = SACONC( JSPCTAG,L ) + & + LFAC3( L ) * ( SACONC( JSPCTAG,L+1 ) - SACONC( JSPCTAG,L ) ) + & + SAEMIS( JSPCTAG,L ) END DO +#endif + +! DO L = 2, NLAYS-1 +! DO V = 1, N_SPC_DIFF +! DD( V,L ) = CONC( V,L ) +! & + LFAC3( L ) * ( CONC( V,L+1 ) - CONC( V,L ) ) +! & - LFAC4( L ) * ( CONC( V,L ) - CONC( V,L-1 ) ) +! & + EMIS( V,L ) +#ifdef sens + DO NP = 1, NPMAX + S_DD( V,L,NP ) = SENS( V,L,NP ) + & + LFAC3( L ) * ( SENS( V,L+1,NP ) - SENS( V,L,NP ) ) + & - LFAC4( L ) * ( SENS( V,L,NP ) - SENS( V,L-1,NP ) ) + & + S_EMIS( V,L,NP ) + END DO +#endif +! END DO +#ifdef isam + DO JSPCTAG = 1, N_SPCTAG + SA_DD( JSPCTAG,L ) = SACONC( JSPCTAG,L ) + & + LFAC3( L ) * ( SACONC( JSPCTAG,L+1 ) - SACONC( JSPCTAG,L ) ) + & - LFAC4( L ) * ( SACONC( JSPCTAG,L ) - SACONC( JSPCTAG,L-1 ) ) + & + SAEMIS( JSPCTAG,L ) + END DO +#endif +! END DO + +! L = NLAYS +! DO V = 1, N_SPC_DIFF +! DD( V,L ) = CONC( V,L ) +! & - LFAC4( L ) * ( CONC( V,L ) - CONC( V,L-1 ) ) +#ifdef sens + DO NP = 1, NPMAX + S_DD( V,L,NP ) = SENS( V,L,NP ) + & - LFAC4( L ) * ( SENS( V,L,NP ) - SENS( V,L-1,NP ) ) + END DO +#endif +! END DO +#ifdef isam + DO JSPCTAG = 1, N_SPCTAG + SA_DD( JSPCTAG,L ) = SACONC( JSPCTAG,L ) + & - LFAC4( L ) * ( SACONC( JSPCTAG,L ) - SACONC( JSPCTAG,L-1 ) ) + END DO +#endif + +! CALL TRI ( CC, BB2, EE2, DD, UU ) +#ifdef isam + CALL SA_TRI ( CC, BB2, EE2, SA_DD, SA_UU ) +#endif + +#ifdef sens + DO NP = 1, NPMAX + CALL TRI ( CC, BB2, EE2, S_DD(:,:,NP), S_UU(:,:,NP) ) + END DO +#endif + + +!C Load into CGRID +! DO L = 1, NLAYS +! DO V = 1, N_SPC_DIFF +! CONC( V,L ) = UU( V,L ) +#ifdef sens + DO NP = 1, NPMAX + SENS( V,L,NP ) = S_UU( V,L,NP ) + END DO +#endif +! END DO +#ifdef isam + DO JSPCTAG = 1, N_SPCTAG + SACONC( JSPCTAG,L ) = SA_UU( JSPCTAG,L ) + END DO +#endif +! END DO + + + + + -C --------- END EMISSIONS --------------- DO V = 1, N_SPC_DEPV @@ -275,43 +1072,136 @@ SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, ICMP, DDEPJ, DDEPJ_FST, CNGRD ) CONC( S,1 ) = POL( V ) + ( CONC( S,1 ) - POL( V ) ) * EFAC2( V ) DDBF( V ) = DDBF( V ) + THBAR * DD_FAC( V ) * CONC( S,1 ) +#ifdef sens + DO NP = 1, NPMAX + SENS( S,1,NP ) = S_POL( NP,V ) + ( SENS( S,1,NP ) - S_POL( NP,V ) ) * EFAC2( V ) + S_DDBF( V,NP ) = S_DDBF( V,NP ) + THBAR * DD_FAC( V ) * SENS( S,1,NP ) + END DO +#endif + ELSE IF ( V .EQ. NO2_HIT ) THEN S = NO2_MAP CONC( S,1 ) = POL( V ) + ( CONC( S,1 ) - POL( V ) ) * EFAC2( V ) DDBF( V ) = DDBF( V ) + THBAR * DD_FAC( V ) * CONC( S,1 ) +#ifdef sens + DO NP = 1, NPMAX + SENS( S,1,NP ) = S_POL( NP,V ) + ( SENS( S,1,NP ) - S_POL( NP,V ) ) * EFAC2( V ) + S_DDBF( V,NP ) = S_DDBF( V,NP ) + THBAR * DD_FAC( V ) * SENS( S,1,NP ) + END DO +#endif + + ELSE IF ( V .EQ. HONO_HIT ) THEN + S = HONO_MAP + CONC( S,1 ) = POL( V ) + ( CONC( S,1 ) - POL( V ) ) * EFAC2( V ) + DDBF( V ) = DDBF( V ) + THBAR * DD_FAC( V ) * CONC( S,1 ) +C Don't add HONO emissions as negative dep flux +! & - DTDENS1 * DD_CONV( V ) * PLDV( V,C,R ) ) +#ifdef sens + DO NP = 1, NPMAX + SENS( S,1,NP ) = S_POL( NP,V ) + ( SENS( S,1,NP ) - S_POL( NP,V ) ) * EFAC2( V ) + S_DDBF( V,NP ) = S_DDBF( V,NP ) + THBAR * DD_FAC( V ) * SENS( S,1,NP ) + END DO +#endif + C --------- END of HET HONO RX ---------- ELSE S = DV2DF( V ) CONC( S,1 ) = POL( V ) + ( CONC( S,1 ) - POL( V ) ) * EFAC2( V ) - DDBF( V ) = DDBF( V ) + THBAR * DD_FAC( V ) * CONC( S,1 ) - - IF ( ABFLUX .AND. V .EQ. NH3_HIT ) THEN - DO I = 1, LCMP - CMPF( I ) = CMPF( I ) + THBAR * CMP( I,C,R ) * DD_CONV( V ) * DTDENS1 - END DO - END IF + DDBF( V ) = DDBF( V ) + THBAR * ( DD_FAC( V ) * CONC( S,1 ) +C Add evasion as negative dep flux + & - DTDENS1 * DD_CONV( V ) * PLDV( V,C,R ) ) +#ifdef sens + DO NP = 1, NPMAX + SENS( S,1,NP ) = S_POL( NP,V ) + ( SENS( S,1,NP ) - S_POL( NP,V ) ) * EFAC2( V ) + S_DDBF( V,NP ) = S_DDBF( V,NP ) + THBAR * ( DD_FAC( V ) * SENS( S,1,NP ) + & - DTDENS1 * DD_CONV( V ) * S_PLDV( NP,V,C,R ) ) + END DO +#endif + END IF END DO +#ifdef isam +C Update ISAM Dry Deposition + DO JSPCTAG = 1, N_SPCTAG + S = ISAM_DEPV( JSPCTAG ) + IF ( S .GT. 0 ) THEN + SACONC( JSPCTAG,1 ) = SACONC( JSPCTAG,1 ) * EFAC2( S ) + & + SAFRAC( JSPCTAG ) * POL( S ) * ( 1.0 - EFAC2( S ) ) + SA_DDBF( JSPCTAG ) = SA_DDBF( JSPCTAG ) + & + THBAR * DD_FAC( S ) * SACONC( JSPCTAG,1 ) + END IF + END DO + +c Recalculate bidi NH3 deposition + IF ( ABFLUX .AND. SA_BIDI ) THEN + NH3_SUM = 0.0 + DO JSPCTAG = 1, N_SPCTAG + S = ISAM_DEPV( JSPCTAG ) + IF ( S .EQ. NH3_HIT ) NH3_SUM = NH3_SUM + SACONC( JSPCTAG,1 ) + END DO + + DO JSPCTAG = 1, N_SPCTAG + S = ISAM_DEPV( JSPCTAG ) + IF ( S .EQ. NH3_HIT ) THEN + IF( NH3_SUM .GT. 1.0E-25 ) THEN + SA_DDBF( JSPCTAG ) = DDBF(NH3_HIT) * ( SACONC( JSPCTAG,1 ) / NH3_SUM ) + ELSE + SA_DDBF( JSPCTAG ) = 0.0 + END IF + END IF + END DO + END IF +#endif + +301 CONTINUE ! end sub time loop + + DO L = 1, NLAYS DO V = 1, N_SPC_DIFF CNGRD( DIFF_MAP( V ),L,C,R ) = CONC( V,L ) END DO +#ifdef isam + DO JSPCTAG = 1, N_SPCTAG + IF( TRANSPORT_SPC( JSPCTAG ) )THEN + ISAM( C,R,L,S_SPCTAG( JSPCTAG ),T_SPCTAG( JSPCTAG ) ) = SACONC( JSPCTAG,L ) + END IF + END DO + +#endif END DO DO V = 1, N_SPC_DEPV DDEP( V,C,R ) = DDBF( V ) END DO - - IF ( ABFLUX ) THEN - DO I = 1, LCMP - ICMP( I,C,R ) = CMPF( I ) + +#ifdef isam + DO JSPCTAG = 1, N_SPCTAG + SA_DDEP( C,R,JSPCTAG ) = SA_DDBF( JSPCTAG ) + END DO +#endif + +#ifdef sens + DO NP = 1, NPMAX + + DO L = 1, NLAYS + DO V = 1, N_SPC_DIFF + SNGRD( DIFF_MAP( V ),L,C,R,NP ) = SENS( V,L,NP ) + END DO END DO - END IF + + DO V = 1, N_SPC_DEPV + S_DDEP( V,C,R,NP ) = S_DDBF( V,NP ) + END DO + + END DO +#endif + + 344 CONTINUE ! end loop on col C 345 CONTINUE ! end loop on row R diff --git a/src/shr/aqm_config_mod.F90 b/src/shr/aqm_config_mod.F90 index 01aaeae..3aca5ce 100644 --- a/src/shr/aqm_config_mod.F90 +++ b/src/shr/aqm_config_mod.F90 @@ -23,6 +23,9 @@ module aqm_config_mod character(len=AQM_MAXSTR) :: csqy_data = "" character(len=AQM_MAXSTR) :: optics_data = "" character(len=AQM_MAXSTR) :: omi = "" + character(len=AQM_MAXSTR) :: desid_chem_ctrl = "" + character(len=AQM_MAXSTR) :: desid_ctrl = "" + character(len=AQM_MAXSTR) :: misc_ctrl = "" character(len=AQM_MAXSTR) :: mp_map = "" character(len=AQM_MAXSTR) :: ctm_stdout = "" integer :: dy_map_beg = 0 @@ -42,6 +45,7 @@ module aqm_config_mod logical :: run_aero = .false. logical :: run_rescld = .false. logical :: verbose = .false. + logical :: canopy_yn = .false. type(aqm_species_type), pointer :: species => null() end type aqm_config_type @@ -139,6 +143,33 @@ subroutine aqm_config_read(model, config, rc) rcToReturn=rc)) & return ! bail out + ! -- DESID_CHEM_CTRL + call ESMF_ConfigGetAttribute(cf, config % desid_chem_ctrl, & + label="desid_chem_ctrl:", rc=localrc) + if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__, & + rcToReturn=rc)) & + return ! bail out + + ! -- DESID_CTRL + call ESMF_ConfigGetAttribute(cf, config % desid_ctrl, & + label="desid_ctrl:", rc=localrc) + if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__, & + rcToReturn=rc)) & + return ! bail out + + ! -- MISC_CTRL for ELMO + call ESMF_ConfigGetAttribute(cf, config % misc_ctrl, & + label="misc_ctrl:", rc=localrc) + if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__, & + rcToReturn=rc)) & + return ! bail out + ! -- read run settings call ESMF_ConfigGetAttribute(cf, config % run_aero, & label="run_aerosol:", default=.true., rc=localrc) @@ -197,7 +228,16 @@ subroutine aqm_config_read(model, config, rc) file=__FILE__, & rcToReturn=rc)) & return ! bail out - + + ! Canopy Options + call ESMF_ConfigGetAttribute(cf, config % canopy_yn, & + label="canopy_yn:", default=.false., rc=localrc) + if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__, & + rcToReturn=rc)) & + return ! bail out + call ESMF_ConfigGetAttribute(cf, value, & label="ctm_stdout:", default="all", rc=localrc) if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, & @@ -528,6 +568,27 @@ subroutine aqm_config_log(config, name, rc) file=__FILE__, & rcToReturn=rc)) & return ! bail out + call ESMF_LogWrite(trim(name) // ": config: read: desid_chem_ctrl: " & + // config % desid_chem_ctrl, ESMF_LOGMSG_INFO, rc=localrc) + if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__, & + rcToReturn=rc)) & + return ! bail out + call ESMF_LogWrite(trim(name) // ": config: read: desid_ctrl: " & + // config % desid_ctrl, ESMF_LOGMSG_INFO, rc=localrc) + if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__, & + rcToReturn=rc)) & + return ! bail out + call ESMF_LogWrite(trim(name) // ": config: read: misc_ctrl: " & + // config % misc_ctrl, ESMF_LOGMSG_INFO, rc=localrc) + if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__, & + rcToReturn=rc)) & + return ! bail out if (config % ctm_aod) then call ESMF_LogWrite(trim(name) // ": config: read: ctm_aod: true", & ESMF_LOGMSG_INFO, rc=localrc) @@ -562,6 +623,23 @@ subroutine aqm_config_log(config, name, rc) rcToReturn=rc)) & return ! bail out end if + if (config % canopy_yn) then + call ESMF_LogWrite(trim(name) // ": config: read: canopy_yn: true", & + ESMF_LOGMSG_INFO, rc=localrc) + if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__, & + rcToReturn=rc)) & + return ! bail out + else + call ESMF_LogWrite(trim(name) // ": config: read: canopy_yn: false", & + ESMF_LOGMSG_INFO, rc=localrc) + if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__, & + rcToReturn=rc)) & + return ! bail out + end if call ESMF_LogWrite(trim(name) // ": config: read: ctm_stdout: " & // config % ctm_stdout, ESMF_LOGMSG_INFO, rc=localrc) if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, & diff --git a/src/shr/aqm_emis_mod.F90 b/src/shr/aqm_emis_mod.F90 index e432577..7227aed 100644 --- a/src/shr/aqm_emis_mod.F90 +++ b/src/shr/aqm_emis_mod.F90 @@ -1512,18 +1512,20 @@ logical function aqm_emis_ispresent(etype) end function aqm_emis_ispresent - - subroutine aqm_emis_desc( etype, nlays, nvars, vnames, units ) + !Add number of points for fire and point source + subroutine aqm_emis_desc( etype, nlays, nvars, vnames, units, npoints ) character(len=*), intent(in) :: etype integer, optional, intent(out) :: nlays integer, optional, intent(out) :: nvars character(len=16), optional, intent(out) :: vnames(:) character(len=16), optional, intent(out) :: units(:) + integer, optional, intent(out) :: npoints ! -- local variables integer :: localrc integer :: item, nsrc type(aqm_internal_emis_type), pointer :: em + type(aqm_state_type), pointer :: stateIn ! -- begin ! -- get emission data @@ -1549,11 +1551,26 @@ subroutine aqm_emis_desc( etype, nlays, nvars, vnames, units ) if (present(nvars)) nvars = nsrc if (present(vnames)) vnames( 1:nsrc ) = em % table( 1:nsrc, 1 ) if (present(units)) units ( 1:nsrc ) = em % table( 1:nsrc, 2 ) + !add npoints here ;treat grid data as points + if (present(npoints)) then + if (etype == 'gbbepx') then + nullify(stateIn) + call aqm_model_get(stateIn=stateIn, rc=localrc) + if (aqm_rc_check(localrc, msg="Failure to retrieve model input state", & + file=__FILE__, line=__LINE__)) return + npoints = size (stateIn % area) + else if (etype == 'point-source') then + npoints = size (em % ijmap) + else + npoints = 0 + end if + end if else if (present(nlays)) nlays = 0 if (present(nvars)) nvars = 0 if (present(vnames)) vnames = "" if (present(units)) units = "" + if (present(npoints)) npoints = 0 end if end subroutine aqm_emis_desc @@ -1600,6 +1617,12 @@ subroutine aqm_emis_grd_read(em, spcname, buffer, localDe, rc) return ! bail out end if + if (trim(em % type) == "canopy") then + ! -- ensure canopy variables are not normalized by area like + ! -- emissions conversions below + em % dens_flag(item) = 1 + end if + select case (em % dens_flag(item)) case (:-1) ! -- this case indicates that input emissions are provided as totals/cell @@ -1611,7 +1634,7 @@ subroutine aqm_emis_grd_read(em, spcname, buffer, localDe, rc) if (abs(fptr(i,j)) < emAccept) then buffer(k) = buffer(k) & + em % factors(item) * fptr(i,j) / stateIn % area(i,j) & - / stateIn % area(i,j) + / stateIn % area(i,j) end if end do end do @@ -1714,7 +1737,7 @@ subroutine aqm_emis_pts_read(em, spcname, buffer, ip, jp, ijmap, localDe, rc) j = em % jp(n) buffer(n) = buffer(n) & + em % factors(item) * em % rates(item) % values(n) / stateIn % area(i,j) & - / stateIn % area(i,j) + / stateIn % area(i,j) end do case (0) ! -- emissions are totals over each grid cell @@ -1730,7 +1753,7 @@ subroutine aqm_emis_pts_read(em, spcname, buffer, ip, jp, ijmap, localDe, rc) do m = 1, size(em % ijmap) n = em % ijmap(m) buffer(n) = buffer(n) & - + em % factors(item) * em % rates(item) % values(n) + + em % factors(item) * em % rates(item) % values(n) end do case default ! -- this case should never occur diff --git a/src/shr/aqm_methods.F90 b/src/shr/aqm_methods.F90 index 8501c2f..0098d07 100644 --- a/src/shr/aqm_methods.F90 +++ b/src/shr/aqm_methods.F90 @@ -106,10 +106,8 @@ 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 + !!Replace INIT_GASC,AERO,NONR,TRAC to INIT_CONC_1 + IF ( (TRIM(FNAME) .EQ. TRIM(INIT_CONC_1)) ) THEN ! -- Input initial background values for the following species NVARS3D = 3 @@ -126,19 +124,31 @@ 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. + ELSE IF ( TRIM( FNAME ) .EQ. 'GR_EMIS_001' ) THEN NLAYS3D = 0 - - call aqm_emis_desc("gbbepx", NLAYS=EMLAYS) + call aqm_emis_desc("anthropogenic", NLAYS=EMLAYS, NVARS=NVARS3D, VNAMES=VNAME3D, UNITS=UNITS3D) NLAYS3D = MAX(EMLAYS, NLAYS3D) + !This is to add the TSTEP3D for ratio calculation in interpolate_var function + call aqm_model_get(config=config, rc=localrc) + if (aqm_rc_check(localrc, msg="Failure to retrieve model input state", & + file=__FILE__, line=__LINE__)) return - call aqm_emis_desc("point-source", NLAYS=EMLAYS) + SDATE3D = config % ctm_stdate + STIME3D = config % ctm_sttime + TSTEP3D = config % ctm_tstep + + ELSE IF ( TRIM( FNAME ) .EQ. 'STK_EMIS_001' ) THEN !fire stream + NLAYS3D = 0 + call aqm_emis_desc("gbbepx", NLAYS=EMLAYS,NVARS=NVARS3D, VNAMES=VNAME3D, UNITS=UNITS3D, NPOINTS=NROWS3D) NLAYS3D = MAX(EMLAYS, NLAYS3D) - call aqm_emis_desc("anthropogenic", NLAYS=EMLAYS, NVARS=NVARS3D, VNAMES=VNAME3D, UNITS=UNITS3D) + ELSE IF ( TRIM( FNAME ) .EQ. 'STK_EMIS_002' ) THEN !STKS stream + NLAYS3D = 0 + call aqm_emis_desc("point-source", NLAYS=EMLAYS,NVARS=NVARS3D, VNAMES=VNAME3D, UNITS=UNITS3D,NPOINTS=NROWS3D) NLAYS3D = MAX(EMLAYS, NLAYS3D) + ELSE IF ( TRIM( FNAME ) .EQ. TRIM( GRID_DOT_2D ) ) THEN NVARS3D = 1 VNAME3D( 1:NVARS3D ) = & @@ -162,7 +172,7 @@ LOGICAL FUNCTION DESC3( FNAME ) ELSE IF ( TRIM( FNAME ) .EQ. TRIM( MET_CRO_2D ) ) THEN - NVARS3D = 35 + NVARS3D = 44 VNAME3D( 1:NVARS3D ) = & (/ 'PRSFC ', 'USTAR ', & 'WSTAR ', 'PBL ', & @@ -180,6 +190,11 @@ LOGICAL FUNCTION DESC3( FNAME ) 'SEAICE ', 'SOIM1 ', & 'SOIM2 ', 'SOIT1 ', & 'SOIT2 ', 'LH ', & + 'FCH ', 'FRT ', & + 'CLU ', 'POPU ', & + 'LAIE ', 'C1R ', & + 'C2R ', 'C3R ', & + 'C4R ', & 'CLAYF ', 'SANDF ', & 'DRAG ', 'UTHR ' /) UNITS3D( 1:NVARS3D ) = & @@ -199,6 +214,11 @@ LOGICAL FUNCTION DESC3( FNAME ) 'FRACTION ', 'M**3/M**3 ', & 'M**3/M**3 ', 'K ', & 'K ', 'WATTS/M**2 ', & + 'M ', 'NO UNIT ', & + 'NO UNIT ', 'PEOPLE/KM**2 ', & + 'NO UNIT ', 'NO UNIT ', & + 'NO UNIT ', 'NO UNIT ', & + 'NO UNIT ', & '1 ', '1 ', & '1 ', 'M/S ' /) @@ -209,7 +229,7 @@ LOGICAL FUNCTION DESC3( FNAME ) SDATE3D = config % ctm_stdate STIME3D = config % ctm_sttime TSTEP3D = config % ctm_tstep - + ELSE IF ( TRIM( FNAME ) .EQ. TRIM( MET_CRO_3D ) ) THEN CALL aqm_model_domain_get(nl=NLAYS3D, rc=localrc) @@ -369,6 +389,8 @@ logical function envyn(name, description, defaultval, status) aqm_emis_ispresent("point-source") case ('CTM_GRAV_SETL') envyn = .false. + case ('CTM_CANOPY_SHADE') + envyn = config % canopy_yn case ('CTM_WBDUST_FENGSHA') envyn = aqm_emis_ispresent("fengsha") case ('CTM_WB_DUST') @@ -555,8 +577,11 @@ subroutine nameval(name, eqname) integer :: deCount, localrc type(aqm_config_type), pointer :: config type(aqm_internal_emis_type), pointer :: em + !INTEGER, EXTERNAL :: SETUP_LOGDEV + !INTEGER, SAVE :: LOGDEV ! -- begin + !LOGDEV = SETUP_LOGDEV() eqname = "" nullify(config) @@ -577,6 +602,12 @@ subroutine nameval(name, eqname) eqname = config % tr_matrix_nml case ('CSQY_DATA') eqname = config % csqy_data + case ('MISC_CTRL') + eqname = config % misc_ctrl + case ('DESID_CTRL') + eqname = config % desid_ctrl + case ('DESID_CHEM_CTRL') + eqname = config % desid_chem_ctrl case ('GSPRO') nullify(em) em => aqm_emis_get("biogenic") @@ -804,11 +835,21 @@ logical function interpx( fname, vname, pname, & end do end do case ("CLAYF","DRAG","SANDF","UTHR") - ! -- read in fengsha variables + ! -- fengsha variables call aqm_emis_read("fengsha", vname, buffer, rc=localrc) if (aqm_rc_test((localrc /= 0), & msg="Failure to read fengsha input for " // vname, & file=__FILE__, line=__LINE__)) return + case ("FCH","FRT","CLU","POPU","LAIE","C1R","C2R","C3R","C4R") + ! -- canopy variables + if (config % canopy_yn) then + call aqm_emis_read("canopy", vname, buffer, rc=localrc) + if (aqm_rc_test((localrc /= 0), & + msg="Failure to read canopy input for " // vname, & + file=__FILE__, line=__LINE__)) return + else + buffer(1:lbuf) = 0. + end if case default ! return end select @@ -835,14 +876,15 @@ 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. + else if ( trim(fname) .EQ. 'GR_EMIS_001') then ! -- read in emissions call aqm_emis_read("anthropogenic", vname, buffer, rc=localrc) if (aqm_rc_test((localrc /= 0), & msg="Failure to read emissions for " // vname, & file=__FILE__, line=__LINE__)) return + else if (trim(fname) == trim(MET_CRO_3D)) then call aqm_model_get(config=config, stateIn=stateIn, rc=localrc) @@ -1024,12 +1066,15 @@ LOGICAL FUNCTION XTRACT3 ( FNAME, VNAME, & LAY0, LAY1, ROW0, ROW1, COL0, COL1, & JDATE, JTIME, BUFFER ) - use aqm_types_mod, only : AQM_KIND_R4 - use aqm_model_mod, only : aqm_state_type, aqm_model_get + use aqm_types_mod, only : AQM_KIND_R4, AQM_KIND_R8, AQM_MAXSTR + use aqm_model_mod, only : aqm_config_type,aqm_state_type, & + aqm_model_get, aqm_model_domain_get use aqm_rc_mod, only : aqm_rc_check, aqm_rc_test use aqm_const_mod, only : con_mr2ppm_o3, thrs_p_strato use aqm_emis_mod, only : aqm_emis_read use aqm_config_mod + use aqm_const_mod, only : eps1, grav, onebg, rdgas + USE M3UTILIO, ONLY : M3MESG implicit none @@ -1048,20 +1093,32 @@ LOGICAL FUNCTION XTRACT3 ( FNAME, VNAME, & ! -- local variables integer :: localrc - integer :: c, r, l, k, lbuf, lu_index + integer :: c, r, l, k, n, nl, lbuf, lu_index type(aqm_config_type), pointer :: config type(aqm_state_type), pointer :: stateIn + !add from interpx + logical :: set_non_neg + character(len=16) :: varname + character(len=AQM_MAXSTR) :: msgString + real(AQM_KIND_R8), dimension(:,:), pointer :: lat, lon + real(AQM_KIND_R8), dimension(:,:), pointer :: p2d + real(AQM_KIND_R8), dimension(:,:,:), pointer :: p3d + include SUBST_FILES_ID + logical, parameter :: debug = .true. - ! -- begin + ! -- begin + nullify(p2d) + nullify(p3d) nullify(config) nullify(stateIn) + set_non_neg = .false. lbuf = (LAY1-LAY0+1)*(ROW1-ROW0+1)*(COL1-COL0+1) BUFFER(1:lbuf) = 0. - XTRACT3 = .TRUE. + XTRACT3 = .FALSE. IF (TRIM(FNAME) == TRIM(GRID_CRO_2D)) THEN @@ -1069,12 +1126,30 @@ LOGICAL FUNCTION XTRACT3 ( FNAME, VNAME, & if (aqm_rc_check(localrc, msg="Failure to retrieve model input state", & file=__FILE__, line=__LINE__)) return + call aqm_model_domain_get(lon=lon, lat=lat, rc=localrc) + if (aqm_rc_check(localrc, msg="Failure to retrieve grid coordinates", & + file=__FILE__, line=__LINE__)) return + +! if (vname(1:7) == 'LUFRAC_') then +! if (aqm_rc_test((LAY0.NE.1).OR.(LAY1.NE.1), & +! msg=TRIM(VNAME)//" is 2D. LAY0 and LAY1 must be 1", & +! file=__FILE__, line=__LINE__)) return +! lu_index = 0 +! read(vname(8:), *, iostat=localrc) lu_index +! if (aqm_rc_test(localrc /= 0, msg="Failure to identify LU_INDEX", & +! file=__FILE__, line=__LINE__)) return +! k = 0 +! do r = row0, row1 +! do c = col0, col1 +! k = k + 1 +! if (int(stateIn % stype(c,r)) == lu_index) buffer(k) = 1.0 +! end do +! end do +! end if + if (vname(1:7) == 'LUFRAC_') then - if (aqm_rc_test((LAY0.NE.1).OR.(LAY1.NE.1), & - msg=TRIM(VNAME)//" is 2D. LAY0 and LAY1 must be 1", & - file=__FILE__, line=__LINE__)) return lu_index = 0 - read(vname(8:), *, iostat=localrc) lu_index + read(vname(8:9), *, iostat=localrc) lu_index if (aqm_rc_test(localrc /= 0, msg="Failure to identify LU_INDEX", & file=__FILE__, line=__LINE__)) return k = 0 @@ -1084,8 +1159,327 @@ LOGICAL FUNCTION XTRACT3 ( FNAME, VNAME, & if (int(stateIn % stype(c,r)) == lu_index) buffer(k) = 1.0 end do end do + else + select case (trim(vname)) + case ('HT') + p2d => stateIn % ht + case ('LAT') + p2d => lat + case ('LON') + k = 0 + do r = row0, row1 + do c = col0, col1 + k = k + 1 + if (lon(c,r) > 180.) then + buffer(k) = lon(c,r) - 360. + else + buffer(k) = lon(c,r) + end if + end do + end do + case ('LWMASK') + k = 0 + do r = row0, row1 + do c = col0, col1 + k = k + 1 + buffer(k) = stateIn % slmsk(c,r) + if (nint(buffer(k)) == 2) buffer(k) = 0. ! set sea ice points as water + end do + end do + case ('MSFX2') + buffer(1:lbuf) = 1. + case ('PURB') + case default + return + end select end if + ELSE IF (trim(fname) == trim(MET_CRO_2D)) THEN + + call aqm_model_get(stateIn=stateIn, rc=localrc) + if (aqm_rc_check(localrc, msg="Failure to retrieve model input state", & + file=__FILE__, line=__LINE__)) return + + call aqm_model_get(config=config, stateIn=stateIn, rc=localrc) + if (aqm_rc_check(localrc, msg="Failure to retrieve model input state", & + file=__FILE__, line=__LINE__)) return + + select case (trim(vname)) + case ("HFX") + p2d => stateIn % hfx + case ("LAI") + p2d => stateIn % xlai + case ("LH") + p2d => stateIn % lh + case ("PRSFC") + p2d => stateIn % psfc + case ("PBL") + p2d => stateIn % hpbl + case ("Q2") + p2d => stateIn % q2m + case ("RADYNI") + p2d => stateIn % cmm + case ("RSTOMI") + k = 0 + do r = row0, row1 + do c = col0, col1 + k = k + 1 + if ( stateIn % rc(c,r) /= 0.0 ) buffer(k) = 1.0 / stateIn % rc(c,r) + end do + end do + case ("RA") + k = 0 + do r = row0, row1 + do c = col0, col1 + k = k + 1 + buffer(k) = sqrt(stateIn % uwind(c,r,1) * stateIn % uwind(c,r,1) + & + stateIn % vwind(c,r,1) * stateIn % vwind(c,r,1)) / & + ( stateIn % ustar(c,r) * stateIn % ustar(c,r) ) + end do + end do + case ("RS") + p2d => stateIn % rc + case ("RC") + k = 0 + do r = row0, row1 + do c = col0, col1 + k = k + 1 + buffer(k) = 100. * stateIn % rainc(c,r) + end do + end do + case ("RGRND") + p2d => stateIn % rgrnd + case ("RN") + k = 0 + do r = row0, row1 + do c = col0, col1 + k = k + 1 + buffer(k) = 100. * (stateIn % rain(c,r) - stateIn % rainc(c,r)) + end do + end do + set_non_neg = .true. + case ("SEAICE") + p2d => stateIn % fice + case ("SLTYP") + p2d => stateIn % stype + case ("SNOCOV") + p2d => stateIn % sncov + case ("SOIM1") + p2d => stateIn % smois(:,:,1) + case ("SOIM2") + p2d => stateIn % smois(:,:,2) + case ("SOIT1") + p2d => stateIn % stemp(:,:,1) + case ("SOIT2") + p2d => stateIn % stemp(:,:,2) + case ("TEMPG") + p2d => stateIn % tsfc + case ("TEMP2") + p2d => stateIn % t2m + case ("USTAR") + p2d => stateIn % ustar + case ("VEG") + p2d => stateIn % vfrac + case ("WR") + p2d => stateIn % wr + case ("WSPD10") + k = 0 + do r = row0, row1 + do c = col0, col1 + k = k + 1 + buffer(k) = sqrt(stateIn % u10m(c,r) * stateIn % u10m(c,r) & + + stateIn % v10m(c,r) * stateIn % v10m(c,r)) + end do + end do + case ("ZRUF") + k = 0 + do r = row0, row1 + do c = col0, col1 + k = k + 1 + buffer(k) = 0.01 * stateIn % zorl(c,r) + end do + end do + case ("CLAYF","DRAG","SANDF","UTHR") + ! -- fengsha variables + call aqm_emis_read("fengsha", vname, buffer, rc=localrc) + if (aqm_rc_test((localrc /= 0), & + msg="Failure to read fengsha input for " // vname, & + file=__FILE__, line=__LINE__)) return + case ("FCH","FRT","CLU","POPU","LAIE","C1R","C2R","C3R","C4R") + ! -- canopy variables + if (config % canopy_yn) then + call aqm_emis_read("canopy", vname, buffer, rc=localrc) + if (aqm_rc_test((localrc /= 0), & + msg="Failure to read canopy input for " // vname, & + file=__FILE__, line=__LINE__)) return + else + buffer(1:lbuf) = 0. + end if + case default + ! return + end select + + ELSE IF (trim(fname) == trim(OCEAN_1)) THEN + select case (trim(vname)) + case ("OPEN") + call aqm_model_get(stateIn=stateIn, rc=localrc) + if (aqm_rc_check(localrc, msg="Failure to retrieve model input state", & + file=__FILE__, line=__LINE__)) return + ! -- set to complement to land mask + k = 0 + do r = row0, row1 + do c = col0, col1 + k = k + 1 + buffer(k) = 1.0 - stateIn % slmsk(c,r) + if (nint(stateIn % slmsk(c,r)) == 2) buffer(k) = 1.0 ! set sea ice points as water + end do + end do + case ("SURF") + ! -- zero + case default + return + end select + + ! EMIS_1 is not used anymore. Change to other env variables. + ELSE IF ( trim(fname) .EQ. 'GR_EMIS_001') then + ! -- read in emissions + call aqm_emis_read("anthropogenic", vname, buffer, rc=localrc) + if (aqm_rc_test((localrc /= 0), & + msg="Failure to read emissions for " // vname, & + file=__FILE__, line=__LINE__)) return + + ELSE IF (trim(fname) == trim(MET_CRO_3D)) THEN + + call aqm_model_get(config=config, stateIn=stateIn, rc=localrc) + if (aqm_rc_check(localrc, msg="Failure to retrieve model input state", & + file=__FILE__, line=__LINE__)) return + + select case (trim(vname)) + case ("JACOBF") + call aqm_model_domain_get(nl=nl, rc=localrc) + if (aqm_rc_check(localrc, msg="Failure to retrieve model coordinates", & + file=__FILE__, line=__LINE__)) return + k = 0 + do l = lay0, lay1 + n = min(l + 1, nl) + do r = row0, row1 + do c = col0, col1 + k = k + 1 + buffer(k) = onebg * (stateIn % phil(c,r,n) - stateIn % phil(c,r,n-1)) + end do + end do + end do + case ("JACOBM") + k = 0 + do l = lay0, lay1 + do r = row0, row1 + do c = col0, col1 + k = k + 1 + buffer(k) = onebg * (stateIn % phii(c,r,l+1) - stateIn % phii(c,r,l)) + end do + end do + end do + case ("DENS") + k = 0 + do l = lay0, lay1 + do r = row0, row1 + do c = col0, col1 + k = k + 1 + buffer(k) = stateIn % prl(c,r,l) / ( rdgas * stateIn % temp(c,r,l) ) + end do + end do + end do + case ("DENSA_J") + k = 0 + do l = lay0, lay1 + do r = row0, row1 + do c = col0, col1 + k = k + 1 + ! -- rho + buffer(k) = stateIn % prl(c,r,l) / ( rdgas * stateIn % temp(c,r,l) ) + ! -- Jacobian + buffer(k) = buffer(k) & + * onebg * (stateIn % phii(c,r,l+1) - stateIn % phii(c,r,l)) + end do + end do + end do + case ("PRES") + p3d => stateIn % prl + case ("PRESF") + p3d => stateIn % pri + case ("CFRAC_3D") + p3d => stateIn % cldfl + case ("PV") + buffer(1:lbuf) = 1.0 + case ("QV") + p3d => stateIn % tr(:,:,:,config % species % p_atm_qv) + set_non_neg = .true. + case ("QC") + p3d => stateIn % tr(:,:,:,config % species % p_atm_qc) + set_non_neg = .true. + case ("QR") + if (config % species % p_atm_qr > 0) then + p3d => stateIn % tr(:,:,:,config % species % p_atm_qr) + set_non_neg = .true. + end if + case ("QI") + if (config % species % p_atm_qi > 0) then + p3d => stateIn % tr(:,:,:,config % species % p_atm_qi) + set_non_neg = .true. + end if + case ("QS") + if (config % species % p_atm_qs > 0) then + p3d => stateIn % tr(:,:,:,config % species % p_atm_qs) + set_non_neg = .true. + end if + case ("QG") + if (config % species % p_atm_qg > 0) then + p3d => stateIn % tr(:,:,:,config % species % p_atm_qg) + set_non_neg = .true. + end if + case ("UWINDA") + p3d => stateIn % uwind + case ("VWINDA") + p3d => stateIn % vwind + case ("ZF") + k = 0 + do l = lay0, lay1 + do r = row0, row1 + do c = col0, col1 + k = k + 1 + buffer(k) = onebg * stateIn % phii(c,r,l+1) + end do + end do + end do + set_non_neg = .true. + case ("ZH") + k = 0 + do l = lay0, lay1 + do r = row0, row1 + do c = col0, col1 + k = k + 1 + buffer(k) = onebg * stateIn % phil(c,r,l) + end do + end do + end do + set_non_neg = .true. + case ("TA") + p3d => stateIn % temp + case default + ! set to 0 + end select + + else if (trim(fname) == trim(MET_DOT_3D)) then + + select case (trim(vname)) + case ("UWINDC") + ! u-wind is on C grid, while imported wind component are on A grid + ! this needs to be fixed + ! set to 0 for now + case ("VWINDC") + ! set to 0 for now + end select + ELSE IF (TRIM(FNAME) .EQ. 'MODIS_FPAR') THEN IF (TRIM(VNAME) .EQ. 'MODIS_FPAR_T') THEN @@ -1107,8 +1501,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 + ELSE IF ( TRIM(FNAME) .EQ. TRIM(INIT_CONC_1) ) THEN ! -- initialize gas-phase species (ppmV) SELECT CASE (TRIM(VNAME)) @@ -1145,6 +1539,43 @@ LOGICAL FUNCTION XTRACT3 ( FNAME, VNAME, & END IF + !!interpx + if (associated(p2d)) then + k = 0 + do r = row0, row1 + do c = col0, col1 + k = k + 1 + buffer(k) = p2d(c,r) + end do + end do + else if (associated(p3d)) then + k = 0 + do l = lay0, lay1 + do r = row0, row1 + do c = col0, col1 + k = k + 1 + buffer(k) = p3d(c,r,l) + end do + end do + end do + end if + + if (set_non_neg) buffer(1:lbuf) = max( 0., buffer(1:lbuf) ) + + XTRACT3 = .TRUE. + + call aqm_model_get(config=config, rc=localrc) + if (aqm_rc_check(localrc, msg="Failure to retrieve model configuration", & + file=__FILE__, line=__LINE__)) return + + if (config % verbose) then + varname = vname + write(msgString, '(a,": interpx: ",a16,": ",a16,": min/max = ",2g20.8)') & + trim(config % name), fname, varname, & + minval(buffer(1:lbuf)), maxval(buffer(1:lbuf)) + call m3mesg(msgString) + end if + END FUNCTION XTRACT3 @@ -1205,25 +1636,30 @@ LOGICAL FUNCTION WRITE3_REAL2D( FNAME, VNAME, JDATE, JTIME, BUFFER ) type(aqm_state_type), pointer :: stateOut WRITE3_REAL2D = .TRUE. +!move to WRITE3_REAL4D below since we specify all model layers in CMAQ_Control_Misc.nml. +! IF ( TRIM( FNAME ) .EQ. TRIM( CTM_ELMO_1 ) ) THEN +! IF ( TRIM( FNAME ) .EQ. TRIM( CTM_DEPV_DIAG ) ) THEN !test depv +! IF ( TRIM( FNAME ) .EQ. TRIM( CTM_DRY_DEP_1 ) ) THEN !test depv +! IF ( TRIM( FNAME ) .EQ. TRIM( CTM_DUST_EMIS_1 ) ) THEN !test emis dust +! WRITE3_REAL2D = .FALSE. - IF ( TRIM( FNAME ) .EQ. TRIM( CTM_AOD_1 ) ) THEN - - WRITE3_REAL2D = .FALSE. - - IF ( TRIM( VNAME ) .EQ. TRIM( ALLVAR3 ) ) THEN +! IF ( TRIM( VNAME ) .EQ. TRIM( ALLVAR3 ) ) THEN +! IF ( TRIM( VNAME ) .EQ. 'VMASSJ' ) THEN +! IF ( TRIM( VNAME ) .EQ. 'ASOIL' ) THEN !DDEP +! IF ( TRIM( VNAME ) .EQ. 'PMCOARSE_SOIL' ) THEN !emission - 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 +! 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 +! stateOut % aod = BUFFER - END IF +! END IF - WRITE3_REAL2D = .TRUE. +! WRITE3_REAL2D = .TRUE. - END IF +! END IF END FUNCTION WRITE3_REAL2D @@ -1248,11 +1684,11 @@ LOGICAL FUNCTION WRITE3_REAL4D( FNAME, VNAME, JDATE, JTIME, BUFFER ) type(aqm_state_type), pointer :: stateOut type(aqm_config_type), pointer :: config - integer, parameter :: p_pm25at = 23 + integer, parameter :: p_pm25at = 1 !(change from 23) WRITE3_REAL4D = .TRUE. - - IF ( TRIM( FNAME ) .EQ. TRIM( CTM_PMDIAG_1 ) ) THEN +!CTM_PMDIAG_1 seems to be removed. Use CTM_ELMO_1. + IF ( TRIM( FNAME ) .EQ. TRIM( CTM_ELMO_1 ) ) THEN WRITE3_REAL4D = .FALSE. @@ -1268,6 +1704,8 @@ LOGICAL FUNCTION WRITE3_REAL4D( FNAME, VNAME, JDATE, JTIME, BUFFER ) stateOut % tr(:,:,:,config % species % p_diag_beg + s) = & buffer(:,:,:,p_pm25at + s) end do + ! add AOD here; point to the 4th species in ELMO_INST + stateOut % aod = BUFFER(:,:,1,4) END IF diff --git a/src/shr/aqm_state_mod.F90 b/src/shr/aqm_state_mod.F90 index 9dc762f..0dff89d 100644 --- a/src/shr/aqm_state_mod.F90 +++ b/src/shr/aqm_state_mod.F90 @@ -46,6 +46,17 @@ module aqm_state_mod real(AQM_KIND_R8), dimension(:,:,:,:), pointer :: tr => null() + ! -- canopy variables +! real(AQM_KIND_R8), dimension(:,:), pointer :: cfch => null() +! real(AQM_KIND_R8), dimension(:,:), pointer :: cfrt => null() +! real(AQM_KIND_R8), dimension(:,:), pointer :: cclu => null() +! real(AQM_KIND_R8), dimension(:,:), pointer :: cpopu => null() +! real(AQM_KIND_R8), dimension(:,:), pointer :: claie => null() +! real(AQM_KIND_R8), dimension(:,:), pointer :: cc1r => null() +! real(AQM_KIND_R8), dimension(:,:), pointer :: cc2r => null() +! real(AQM_KIND_R8), dimension(:,:), pointer :: cc3r => null() +! real(AQM_KIND_R8), dimension(:,:), pointer :: cc4r => null() + ! -- diagnostics real(AQM_KIND_R8), dimension(:,:), pointer :: aod => null()