From 89e9a4ff76045aa4e89ab0ad4f6f99d40bb5a9a1 Mon Sep 17 00:00:00 2001 From: "Patrick.C.Campbell@noaa.gov" Date: Thu, 10 Feb 2022 21:27:29 +0000 Subject: [PATCH 01/90] Initial commit of rrfs_cmaq_canopy branch. --- README | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 From e38abcd13ce1196f01235c0dd198e123263eea0f Mon Sep 17 00:00:00 2001 From: "Patrick.C.Campbell@noaa.gov" Date: Fri, 11 Feb 2022 20:06:04 +0000 Subject: [PATCH 02/90] Initial copy of canopy photolysis routines. --- src/model/src/ASX_DATA_MOD.F | 1395 ++++++++++++++ src/model/src/PHOT_MOD.F | 1898 ++++++++++++++++++++ src/model/src/centralized_io_util_module.F | 282 +++ src/model/src/phot.F | 1251 +++++++++++++ 4 files changed, 4826 insertions(+) create mode 100755 src/model/src/ASX_DATA_MOD.F create mode 100644 src/model/src/PHOT_MOD.F create mode 100644 src/model/src/centralized_io_util_module.F create mode 100644 src/model/src/phot.F diff --git a/src/model/src/ASX_DATA_MOD.F b/src/model/src/ASX_DATA_MOD.F new file mode 100755 index 0000000..8cad21f --- /dev/null +++ b/src/model/src/ASX_DATA_MOD.F @@ -0,0 +1,1395 @@ +!------------------------------------------------------------------------! +! The Community Multiscale Air Quality (CMAQ) system software is in ! +! continuous development by various groups and is based on information ! +! from these groups: Federal Government employees, contractors working ! +! within a United States Government contract, and non-Federal sources ! +! including research institutions. These groups give the Government ! +! permission to use, prepare derivative works of, and distribute copies ! +! of their work in the CMAQ system to the public and to permit others ! +! to do so. The United States Environmental Protection Agency ! +! therefore grants similar permission to use the CMAQ system software, ! +! but users are requested to provide copies of derivative works or ! +! products designed to operate in the CMAQ system to the United States ! +! Government without restrictions as to use by others. Software ! +! that is used with the CMAQ system but distributed under the GNU ! +! General Public License or the GNU Lesser General Public License is ! +! subject to their copyright restrictions. ! +!------------------------------------------------------------------------! + +C::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: + Module ASX_DATA_MOD + +C----------------------------------------------------------------------- +C Function: User-defined types + +C Revision History: +C 19 Aug 2014 J.Bash: initial implementation +C 17 July 2015 H.Foroutan: Updated the calculation of MOL, MOLI, HOL, and WSTAR +C 25 Aug 2015 H. Pye: Added IEPOX, HACET surrogates +C modified PROPNN and H2O2 +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 +C---------Notes +C * Updates based on literature review 7/96 JEP +C # Diff and H based on Wesely (1988) same as RADM +C + Estimated by JEP 2/97 +C @ Updated by JEP 9/01 +C ~ Added by YW 1/02. Dif0 based on Massman (1998). Henry's Law constant +C is defined here as: h=cg/ca, where cg is the concentration of a species +C in gas-phase, and ca is its aqueous-phase concentration. The smaller h, +C the larger solubility. Henry's Law constant in another definition (KH): +C KH = ca/pg [M/atm], KH = KH0 * exp(-DKH/R(1/T-1/T0)), where KH0 and -DKH +C values are from Rolf Sander (1999). h=1/(KH*R*T). +C ** Update by DBS based on estimates by JEP 1/03 +C ^^ From Bill Massman, personal communication 4/03 +C ## Diffusivity calculated by SPARC, reactivity = other aldehydes +C ++ Dif0 in Massman is diffusivity at temperature 0C and 1 atm (101.325kPa), so +C chemicals that were not in Massman's paper need to be adjusted. We assume +C JEP's original values were for 25C and 1 atm. +C % Added by G. Sarwar (10/04) +C $ Added by R. Bullock (02/05) HG diffusivity is from Massman (1999). +C HGIIGAS diffusivity calculated from the HG value and a mol. wt. scaling +C factor of MW**(-2/3) from EPA/600/3-87/015. ORD, Athens, GA. HGIIGAS +C mol.wt. used is that of HgCl2. Reactivity of HG is 1/20th of NO and NO2 +C values based on general atmospheric lifetimes of each species. Reactivity +C of HGIIGAS is based on HNO3 surrogate. +C @@ Mesophyll resistances for NO, NO2, and CO added by J. Pleim (07/07) based +C on values in Pleim, Venkatram, and Yamartino, 1984: ADOM/TADAP Model +C Development Program, Volume 4, The Dry Deposition Module. ERT, Inc., +C Concord, MA (peer reviewed). +C ~~ Reactivity for PAN changed from 4.0 to 16.0 by J. Pleim (07/07) based on +C comparisons with Turnipseed et al., JGR, 2006. +C %% Species ICL1 and ICL2 are removed, not used in CB05. G. Sarwar (07/07) +C <> Hazardous Air Pollutants that are believed to undergo significant dry +C deposition. Hydrazine and triethylamine reactivities are based on analogies +C to NH3. Maleic anhydride reactivity is assumed similar to aldehydes. +C Toluene diisocyanate and hexamethylene diisocyanate reactivities are +C assumed to be similar to SO2. Diffusivities are calculated with standard +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------------------------------------------------------------------------------- + + Use GRID_CONF ! horizontal & vertical domain specifications + Use LSM_MOD ! Land surface data + Use DEPVVARS, Only: ltotg + + Implicit None + + Include SUBST_CONST ! constants + + Type :: MET_Type +!> 2-D meteorological fields: + Real, Allocatable :: RDEPVHT ( :,: ) ! air dens / dep vel ht + 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 :: RC ( :,: ) ! convective precipitation [cm] + Real, Allocatable :: RN ( :,: ) ! non-convective precipitation [mc] + 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] + Real, Allocatable :: SNOCOV ( :,: ) ! Snow cover [1=yes, 0=no] + Real, Allocatable :: TEMP2 ( :,: ) ! two meter temperature [K] + Real, Allocatable :: TEMPG ( :,: ) ! skin temperature [K] + Real, Allocatable :: TSEASFC ( :,: ) ! SST [K] + Real, Allocatable :: USTAR ( :,: ) ! surface friction velocity [m/s] + Real, Allocatable :: VEG ( :,: ) ! fractional vegetation coverage [ratio] + Real, Allocatable :: LAI ( :,: ) ! grid cell leaf area index [m**2/m**2] + Real, Allocatable :: WR ( :,: ) ! precip intercepted by canopy [m] + Real, Allocatable :: WSPD10 ( :,: ) ! 10-m wind speed [m/s] + Real, Allocatable :: WSTAR ( :,: ) ! convective velocity scale [m/s] + Real, Allocatable :: Z0 ( :,: ) ! roughness length [m] + Real, Allocatable :: SOIM1 ( :,: ) ! 1 cm soil moisture [m**3/m**3] + Real, Allocatable :: SOIM2 ( :,: ) ! 1 m soil moisture [m**3/m**3] + Real, Allocatable :: SOIT1 ( :,: ) ! 1 cm soil temperature [K] + Real, Allocatable :: SOIT2 ( :,: ) ! 1 m soil temperature [K] + Real, Allocatable :: SEAICE ( :,: ) ! Sea ice coverage [%] + Real, Allocatable :: MOL ( :,: ) ! Monin-Obukhov length [m] + Real, Allocatable :: MOLI ( :,: ) ! inverse of Monin-Obukhov length [m] + Real, Allocatable :: HOL ( :,: ) ! PBL over Obukhov length + Real, Allocatable :: XPBL ( :,: ) ! PBL sigma height + 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) +!> 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 :: QV ( :,:,: ) ! water vapor mixing ratio + Real, Allocatable :: QC ( :,:,: ) ! cloud water mixing ratio + Real, Allocatable :: THETAV ( :,:,: ) ! potential temp + Real, Allocatable :: TA ( :,:,: ) ! temperature (K) + Real, Allocatable :: ZH ( :,:,: ) ! mid-layer height above ground [m] + Real, Allocatable :: ZF ( :,:,: ) ! layer height [m] + Real, Allocatable :: DZF ( :,:,: ) ! layer surface thickness + Real, Allocatable :: DENS ( :,:,: ) ! air density + Real, Allocatable :: RJACM ( :,:,: ) ! reciprocal mid-layer Jacobian + Real, Allocatable :: RJACF ( :,:,: ) ! reciprocal full-layer Jacobian + Real, Allocatable :: RRHOJ ( :,:,: ) ! reciprocal density X Jacobian + End Type MET_Type + + Type :: GRID_Type +!> Grid infomation: +!> Vertical information + Real, Allocatable :: DX3F ( : ) ! sigma layer surface thickness ! vdiffacmx.F + Real, Allocatable :: RDX3F ( : ) ! reciprocal sigma layer thickness ! EMIS_DEFN.F, sedi.F, vdiffacmx.F, vdiffproc.F + Real, Allocatable :: RDX3M ( : ) ! reciprocal sigma midlayer thickness ! vdiffproc.F +!> Horizontal Information: + Real, Allocatable :: RMSFX4 ( :,: ) ! inverse map scale factor ** 4 + 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 :: PURB ( :,: ) ! percent urban [%] + Integer, Allocatable :: SLTYP ( :,: ) ! soil type [category] + Real, Allocatable :: WSAT ( :,: ) ! soil wilting point + 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 :: RHOB ( :,: ) ! soil bulk density + 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 + + Integer, Save :: n_spc_m3dry = ltotg ! from DEPVVARS module +!> M3 asx constants + Real, Parameter :: a0 = 8.0 ! [dim'less] + Real, Parameter :: d3 = 1.38564e-2 ! [dim'less] + Real, Parameter :: dwat = 0.2178 ! [cm^2/s] at 273.15K + Real, Parameter :: hplus_ap = 1.0e-6 ! pH=6.0 leaf apoplast solution Ph (Massad et al 2008) + Real, Parameter :: hplus_def = 1.0e-5 ! pH=5.0 + Real, Parameter :: hplus_east = 1.0e-5 ! pH=5.0 + Real, Parameter :: hplus_h2o = 7.94328e-9 ! 10.0**(-8.1) + Real, Parameter :: hplus_west = 3.16228e-6 ! 10.0**(-5.5) + Real, Parameter :: kvis = 0.132 ! [cm^2 / s] at 273.15K + Real, Parameter :: pr = 0.709 ! [dim'less] + Real, Parameter :: rcut0 = 3000.0 ! [s/m] + Real, Parameter :: rcw0 = 125000.0 ! acc'd'g to Padro and + Real, Parameter :: resist_max = 1.0e30 ! maximum resistance + 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 :: 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 + Real, Parameter :: twothirds = 2.0 / 3.0 + Real, Parameter :: betah = 5.0 ! WRF 3.6 px uses Dyer + Real, Parameter :: gamah = 16.0 + Real, Parameter :: pr0 = 0.95 + Real, Parameter :: karman = 0.40 + Real, Parameter :: f3min = 0.25 + Real, Parameter :: ftmin = 0.0000001 ! m/s + Real, Parameter :: nscat = 16.0 + Real, Parameter :: rsmax = 5000.0 ! s/m + + Real :: ar ( ltotg ) ! reactivity relative to HNO3 + Real :: dif0 ( ltotg ) ! molecular diffusivity [cm2/s] + Real :: lebas ( ltotg ) ! Le Bas molar volume [cm3/mol ] + Real :: meso ( ltotg ) ! Exception for species that + ! react with cell walls. fo in + ! Wesely 1989 eq 6. + 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. + + Public :: INIT_MET + + Logical, Private, Save :: ifsst = .false. + Logical, Private, Save :: ifq2 = .false. + Logical, Private, Save :: rinv = .True. + Logical, Private, Save :: iflh = .false. + + Integer, Private :: C, R, L, S ! loop induction variables + Integer, Private :: SPC + Character( 16 ), Private, Save :: vname_rc, vname_rn, vname_uc, vname_vc + Real, Private, Save :: P0 ! reference pressure (100000.0 Pa) for Potential Temperature, note that in meteorology they do not use the SI 1 ATM. + + Integer, Private, Save :: LOGDEV + Integer, Private, Save :: GXOFF, GYOFF ! global origin offset from file + Integer, Private, Save :: STRTCOLMC3, ENDCOLMC3, STRTROWMC3, ENDROWMC3 ! MET_CRO_3D + Integer, Private, Save :: STRTCOLMD3, ENDCOLMD3, STRTROWMD3, ENDROWMD3 ! MET_DOT_3D + Integer, Private, Save :: STRTCOLMC2, ENDCOLMC2, STRTROWMC2, ENDROWMC2 ! MET_CRO_2D + Integer, Private, Save :: STRTCOL_O1, ENDCOL_O1, STRTROW_O1, ENDROW_O1 ! OCEAN_1 + + Real, Pointer, Private :: BUFF1D( : ) ! 1D temp var number of layers + Real, Pointer, Private :: BUFF2D( :,: ) ! 2D temp var + Real, Pointer, Private :: BUFF3D( :,:,: ) ! 3D temp var + + 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. + + CONTAINS + +C======================================================================= + Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) + +C----------------------------------------------------------------------- +C 30 Mar 01 J.Young: dyn alloc - Use HGRD_DEFN; replace INTERP3 with INTERPX; +C allocatable RDEPVHT, RJACM, RRHOJ +C 14 Nov 03 J.Young: add reciprocal vertical Jacobian product for full and +C mid-layer +C Tanya took JACOBF out of METCRO3D! Improvise +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----------------------------------------------------------------------- + + Use UTILIO_DEFN + + 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' + Character( 16 ) :: VNAME + CHARACTER( 16 ) :: UNITSCK + 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 + ALLOCATE ( BUFF1D( NLAYS ), + & BUFF2D( NCOLS,NROWS ), + & BUFF3D( NCOLS,NROWS,NLAYS ), STAT = ALLOCSTAT ) + If ( ALLOCSTAT .Ne. 0 ) Then + XMSG = 'Failure allocating Buffers' + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + + BUFF1D = 0.0 + BUFF2D = 0.0 + BUFF3D = 0.0 + +!> Allocate shared arrays +!> Met_Data + ALLOCATE( Met_Data%RDEPVHT ( NCOLS,NROWS ), + & Met_Data%DENS1 ( NCOLS,NROWS ), + & Met_Data%PRSFC ( NCOLS,NROWS ), + & Met_Data%Q2 ( NCOLS,NROWS ), + & Met_Data%QSS_GRND ( NCOLS,NROWS ), + & Met_Data%RH ( NCOLS,NROWS ), + & Met_Data%RA ( NCOLS,NROWS ), + & Met_Data%RS ( NCOLS,NROWS ), + & Met_Data%RC ( NCOLS,NROWS ), + & Met_Data%RN ( NCOLS,NROWS ), + & Met_Data%RGRND ( NCOLS,NROWS ), + & Met_Data%HFX ( NCOLS,NROWS ), + & Met_Data%LH ( NCOLS,NROWS ), + & Met_Data%SNOCOV ( NCOLS,NROWS ), + & Met_Data%TEMP2 ( NCOLS,NROWS ), + & Met_Data%TEMPG ( NCOLS,NROWS ), + & Met_Data%TSEASFC ( NCOLS,NROWS ), + & Met_Data%USTAR ( NCOLS,NROWS ), + & Met_Data%VEG ( NCOLS,NROWS ), + & Met_Data%LAI ( NCOLS,NROWS ), + & Met_Data%WR ( NCOLS,NROWS ), + & Met_Data%WSPD10 ( NCOLS,NROWS ), + & Met_Data%WSTAR ( NCOLS,NROWS ), + & Met_Data%Z0 ( NCOLS,NROWS ), + & Met_Data%SOIM1 ( NCOLS,NROWS ), + & Met_Data%SOIT1 ( NCOLS,NROWS ), + & Met_Data%SEAICE ( NCOLS,NROWS ), + & Met_Data%MOL ( NCOLS,NROWS ), + & Met_Data%MOLI ( NCOLS,NROWS ), + & Met_Data%HOL ( NCOLS,NROWS ), + & Met_Data%XPBL ( NCOLS,NROWS ), + & Met_Data%LPBL ( NCOLS,NROWS ), + & Met_Data%CONVCT ( NCOLS,NROWS ), + & Met_Data%PBL ( NCOLS,NROWS ), + & Met_Data%NACL_EMIS( NCOLS,NROWS ), + & Met_Data%UWIND ( NCOLS+1,NROWS+1,NLAYS ), + & Met_Data%VWIND ( NCOLS+1,NROWS+1,NLAYS ), + & Met_Data%KZMIN ( NCOLS,NROWS,NLAYS ), + & Met_Data%PRES ( NCOLS,NROWS,NLAYS ), + & Met_Data%QV ( NCOLS,NROWS,NLAYS ), + & Met_Data%QC ( NCOLS,NROWS,NLAYS ), + & Met_Data%THETAV ( NCOLS,NROWS,NLAYS ), + & Met_Data%TA ( NCOLS,NROWS,NLAYS ), + & Met_Data%ZH ( NCOLS,NROWS,NLAYS ), + & Met_Data%ZF ( NCOLS,NROWS,NLAYS ), + & Met_Data%DZF ( NCOLS,NROWS,NLAYS ), + & Met_Data%DENS ( NCOLS,NROWS,NLAYS ), + & Met_Data%RJACM ( NCOLS,NROWS,NLAYS ), + & Met_Data%RJACF ( NCOLS,NROWS,NLAYS ), + & Met_Data%RRHOJ ( NCOLS,NROWS,NLAYS ), + & STAT = ALLOCSTAT ) + If ( ALLOCSTAT .Ne. 0 ) Then + XMSG = 'Failure allocating met vars' + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + + ALLOCATE( Grid_Data%DX3F ( NLAYS ), + & Grid_Data%RDX3F ( NLAYS ), + & Grid_Data%RDX3M ( NLAYS ), + & Grid_Data%RMSFX4 ( NCOLS,NROWS ), + & Grid_Data%LON ( NCOLS,NROWS ), + & Grid_Data%LAT ( NCOLS,NROWS ), + & Grid_Data%LWMASK ( NCOLS,NROWS ), + & Grid_Data%OCEAN ( NCOLS,NROWS ), + & Grid_Data%SZONE ( NCOLS,NROWS ), + & Grid_Data%PURB ( NCOLS,NROWS ), + & Grid_Data%SLTYP ( NCOLS,NROWS ), + & Grid_Data%NAME ( n_lufrac ), + & Grid_Data%LU_Type ( n_lufrac ), + & STAT = ALLOCSTAT ) + If ( ALLOCSTAT .Ne. 0 ) Then + XMSG = 'Failure allocating grid vars' + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + Grid_Data%NAME = name_lu + Grid_Data%LU_Type = cat_lu + + If ( ABFLUX .Or. HGBIDI .Or. MOSAIC ) Then + ALLOCATE( Met_Data%SOIM2 ( NCOLS,NROWS ), + & Met_Data%SOIT2 ( NCOLS,NROWS ), + & STAT = ALLOCSTAT ) + If ( ALLOCSTAT .Ne. 0 ) Then + XMSG = 'Failure allocating mosaic met vars' + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + + ALLOCATE( Grid_Data%WSAT ( NCOLS,NROWS ), + & Grid_Data%WWLT ( NCOLS,NROWS ), + & Grid_Data%BSLP ( NCOLS,NROWS ), + & Grid_Data%WRES ( NCOLS,NROWS ), + & Grid_Data%WFC ( NCOLS,NROWS ), + & Grid_Data%LUFRAC ( NCOLS,NROWS,n_lufrac ), + & STAT = ALLOCSTAT ) + If ( ALLOCSTAT .Ne. 0 ) Then + XMSG = 'Failure allocating mosaic 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 + + 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 ), + & STAT = ALLOCSTAT ) + If ( ALLOCSTAT .Ne. 0 ) Then + XMSG = 'Failure allocating chemistry dependent mosaic vars' + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + ChemMos_Data%Rb = resist_max + ChemMos_Data%Rst = resist_max + ChemMos_Data%Rcut = resist_max + ChemMos_Data%Rgc = resist_max + ChemMos_Data%Rgb = resist_max + ChemMos_Data%Rwat = resist_max + ChemMos_Data%CZ0 = 0.0 + ChemMos_Data%Cleaf = 0.0 + ChemMos_Data%Cstom = 0.0 + ChemMos_Data%Ccut = 0.0 + ChemMos_Data%Csoil = 0.0 + ChemMos_Data%NAME = name_lu + ChemMos_Data%LU_Type = cat_lu + ChemMos_Data%SubName = subname + End If + +!> ccccccccccccccccccccc enable backward compatiblity ccccccccccccccccccccc + + If ( .Not. desc3( met_cro_2d ) ) Then + xmsg = 'Could not get ' // MET_CRO_2D // ' file description' + Call m3exit( pname, JDATE, JTIME, xmsg, xstat2 ) + End If + + SPC = INDEX1( 'RA', NVARS3D, VNAME3D ) + If (SPC .Gt. 0) rinv = .FALSE. ! Ra and Rst are in units s/m + + SPC = INDEX1( 'WR', NVARS3D, VNAME3D ) + If (SPC .Gt. 0) ifwr = .True. ! canopy wetness is in METCRO2D + + SPC = INDEX1( 'Q2', NVARS3D, VNAME3D ) + If (SPC .Gt. 0) ifq2 = .True. ! two meter mixing ratio in METCRO2D + + SPC = INDEX1( 'TSEASFC', NVARS3D, VNAME3D ) + If (SPC .Gt. 0) ifsst = .True. ! two meter SST in METCRO2D + + SPC = INDEX1( 'LH', NVARS3D, VNAME3D ) + If (SPC .Gt. 0) iflh = .True. ! LH in METCRO2D + + SPC = INDEX1( 'RCA', NVARS3D, VNAME3D ) + If (SPC .Gt. 0) Then + vname_rc = 'RCA' + Else + vname_rc = 'RC' + End If + + SPC = INDEX1( 'RNA', NVARS3D, VNAME3D ) + If (SPC .Gt. 0) 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 + vname_uc = 'UWINDC' + CSTAGUV = .TRUE. + Else + vname_uc = 'UWIND' + CSTAGUV = .FALSE. + End If + + SPC = INDEX1( 'VWINDC', NVARS3D, VNAME3D ) + If (SPC .Gt. 0) 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 ) ) + End Do + Do L = 1, NLAYS - 1 + Grid_Data%RDX3M( L ) = 1.0 / ( X3M( L+1 ) - X3M( 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 + + 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 + + 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 + + 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 + + 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%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 + + 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 ) ) + Grid_Data%WWLT( C,R ) = WWLT( Grid_Data%SLTYP( C,R ) ) + Grid_Data%WFC ( C,R ) = WFC ( Grid_Data%SLTYP( C,R ) ) + 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 + + MET_INITIALIZED = .true. + + Return + End Subroutine INIT_MET + +C======================================================================= + Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) + +C----------------------------------------------------------------------- +C 30 Mar 01 J.Young: dyn alloc - Use HGRD_DEFN; replace INTERP3 with INTERPX; +C allocatable RDEPVHT, RJACM, RRHOJ +C 14 Nov 03 J.Young: add reciprocal vertical Jacobian product for full and +C mid-layer +C Tanya took JACOBF out of METCRO3D! Improvise +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----------------------------------------------------------------------- + + USE GRID_CONF ! horizontal & vertical domain specifications + Use UTILIO_DEFN +#ifdef parallel + USE SE_MODULES ! stenex (using SE_COMM_MODULE) +#else + USE NOOP_MODULES ! stenex (using NOOP_COMM_MODULE) +#endif + + Implicit None + + 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] + Real, Parameter :: KZMAXL = 500.0 ! upper limit for min Kz [m] + Real, Parameter :: KZ0UT = 1.0 ! minimum eddy diffusivity [m**2/sec] KZ0 + Real, Parameter :: KZL = 0.01 ! lowest KZ + Real, Parameter :: KZU = 1.0 ! 2.0 ! highest KZ + Real, Parameter :: EPS = 1.0E-08 ! small number for temperature difference + +C Local variables: + 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 + + Character( 16 ) :: PNAME = 'GET_MET' + Character( 16 ) :: VNAME + CharactER( 30 ) :: MSG1 = ' Error interpolating variable ' + Character( 96 ) :: XMSG = ' ' + +C----------------------------------------------------------------------- +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 + + 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 + + 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 + + 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 + + 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 + + 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 + + Met_Data%RRHOJ = 1.0 / Met_Data%RRHOJ + + VNAME = 'TA' + IF ( .NOT. INTERPX( MET_CRO_3D, VNAME, PNAME, + & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, + & JDATE, JTIME, Met_Data%TA ) ) THEN + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D + CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + VNAME = 'QV' + IF ( .NOT. INTERPX( MET_CRO_3D, VNAME, PNAME, + & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, + & JDATE, JTIME, Met_Data%QV ) ) THEN + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D + CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + VNAME = 'QC' + IF ( .NOT. INTERPX( MET_CRO_3D, VNAME, PNAME, + & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, + & JDATE, JTIME, Met_Data%QC ) ) THEN + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D + CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + +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 + + 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 + + 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 Soil vars + VNAME = 'SOIM1' + If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, + & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, + & JDATE, JTIME, Met_Data%SOIM1 ) ) Then + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + + If ( ABFLUX .Or. HGBIDI .Or. MOSAIC ) Then + VNAME = 'SOIM2' + If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, + & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, + & JDATE, JTIME, Met_Data%SOIM2 ) ) Then + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + + 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 + + VNAME = 'SOIT1' + If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, + & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, + & JDATE, JTIME, Met_Data%SOIT1 ) ) Then + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + + 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 ) + End If + +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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + 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 + 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 + + 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 + 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 + 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 + + Where( Met_Data%RA .Gt. cond_min ) + Met_Data%RA = 1.0/Met_Data%RA + Elsewhere + 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 + + Where( Met_Data%RS .Gt. cond_min ) + Met_Data%RS = 1.0 / Met_Data%RS + Elsewhere + Met_Data%RS = resist_max + End Where + + 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 + + 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 + + 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 + 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 ) ) + Elsewhere + Es_Grnd = 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 ) + + Es_Air => BUFF2D + Where( Met_Data%TEMP2 .Lt. stdtemp ) + Es_Air = vp0 *Exp( 22.514 - ( 6.15e3 / Met_Data%TEMP2 ) ) + Elsewhere + Es_Air = 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 + End Where + Nullify( Es_Air ) + +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 + + 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 + +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 ) + CALL SUBST_COMM ( Met_Data%VWIND, DSPL_N1_E0_S0_W0, DRCN_N ) + +C-------------------------------- Calculated Variables -------------------------------- + Met_Data%DZF = Met_Data%ZF - EOSHIFT(Met_Data%ZF, Shift = -1, Boundary = 0.0, Dim = 3) + + Met_Data%RDEPVHT = 1.0 / Met_Data%ZF( :,:,1 ) + + IF ( MINKZ ) THEN + Met_Data%KZMIN = KZL + DO L = 1, NLAYS + Where( Met_Data%ZF( :,:,L ) .LE. KZMAXL ) + Met_Data%KZMIN( :,:,L ) = KZL + ( KZU - KZL ) * 0.01 * Grid_data%PURB + End Where + End Do + ELSE + 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 ) + +C------ Updating MOL, then WSTAR, MOLI, HOL + DO R = 1, MY_NROWS + DO C = 1, MY_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 ) ) + TMPVTCON = 1.0 + 0.608 * Met_Data%QV( C,R,1 ) ! Conversion factor for virtual temperature + TST = -TMPFX / Met_Data%USTAR( C,R ) + IF ( Met_Data%TA( C,R,1 ) .GT. STDTEMP ) THEN + LV = LV0 - ( 0.00237 * ( Met_Data%TA( C,R,1 ) - STDTEMP ) ) * 1.0E6 + ELSE + LV = 2.83E6 ! Latent heat of sublimation at 0C from Stull (1988) (J/KG) + END IF + QST = -( Met_Data%LH( C,R ) / LV ) + & / ( Met_Data%USTAR( C,R ) * Met_Data%DENS( C,R,1 ) ) + TSTV = TST * TMPVTCON + Met_Data%THETAV( C,R,1 ) * 0.608 * QST + IF ( ABS( TSTV ) .LT. 1.0E-6 ) THEN + TSTV = SIGN( 1.0E-6, TSTV ) + END IF + Met_Data%MOL( C,R ) = Met_Data%THETAV( C,R,1 ) + & * Met_Data%USTAR( C,R ) ** 2 / ( karman * GRAV * TSTV ) + IF ( Met_Data%MOL( C,R ) .LT. 0.0 ) THEN + Met_Data%WSTAR( C,R ) = Met_Data%USTAR( C,R ) * ( Met_Data%PBL( C,R ) + & / ( karman * ABS( Met_Data%MOL( C,R ) ) ) ) ** 0.333333 + ELSE + Met_Data%WSTAR( C,R ) = 0.0 + END IF + + END DO + END DO + + Met_Data%MOLI = 1.0 / Met_Data%MOL + Met_Data%HOL = Met_Data%PBL / Met_Data%MOL +C------ + + Met_Data%CONVCT = .FALSE. + DO R = 1, MY_NROWS + DO C = 1, MY_NCOLS + DO L = 1, NLAYS + IF ( Met_Data%PBL( C,R ) .LT. Met_Data%ZF( C,R,L ) ) THEN + LP = L; EXIT + END IF + END DO + + Met_Data%LPBL( C,R ) = LP + If ( LP .Eq. 1 ) Then + FINT = ( Met_Data%PBL( C,R ) ) + & / ( Met_Data%ZF( C,R,LP ) ) + Met_Data%XPBL( C,R ) = FINT * ( X3FACE_GD( LP ) - X3FACE_GD( LP-1 ) ) + & + X3FACE_GD( LP-1 ) + Else + FINT = ( Met_Data%PBL( C,R ) - Met_Data%ZF( C,R,LP-1 ) ) + & / ( Met_Data%ZF( C,R,LP ) - Met_Data%ZF( C,R,LP-1 ) ) + Met_Data%XPBL( C,R ) = FINT * ( X3FACE_GD( LP ) - X3FACE_GD( LP-1 ) ) + & + X3FACE_GD( LP-1 ) + End If + END DO + END DO + Where( Met_Data%THETAV( :,:,1 ) - Met_Data%THETAV( :,:,2 ) .Gt. EPS .And. + & Met_Data%HOL .Lt. -0.02 .And. Met_Data%LPBL .Gt. 3 ) + Met_Data%CONVCT = .True. + End Where + + Return + End Subroutine GET_MET + + End Module ASX_DATA_MOD diff --git a/src/model/src/PHOT_MOD.F b/src/model/src/PHOT_MOD.F new file mode 100644 index 0000000..7d93dec --- /dev/null +++ b/src/model/src/PHOT_MOD.F @@ -0,0 +1,1898 @@ + +!------------------------------------------------------------------------! +! The Community Multiscale Air Quality (CMAQ) system software is in ! +! continuous development by various groups and is based on information ! +! from these groups: Federal Government employees, contractors working ! +! within a United States Government contract, and non-Federal sources ! +! including research institutions. These groups give the Government ! +! permission to use, prepare derivative works of, and distribute copies ! +! of their work in the CMAQ system to the public and to permit others ! +! to do so. The United States Environmental Protection Agency ! +! therefore grants similar permission to use the CMAQ system software, ! +! but users are requested to provide copies of derivative works or ! +! products designed to operate in the CMAQ system to the United States ! +! Government without restrictions as to use by others. Software ! +! that is used with the CMAQ system but distributed under the GNU ! +! General Public License or the GNU Lesser General Public License is ! +! subject to their copyright restrictions. ! +!------------------------------------------------------------------------! + +C $Header$ + +C::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: + MODULE PHOT_MOD + +C----------------------------------------------------------------------- +C +C FSB This version has NO internal write statements +C FSB This version has the code for XR96 added. +C FSB change indices from L to II in newOptics loop 08/17/2006 +C FSB This version has all write statements commented out.(08/03/2006) +C +C FSB NOTE - this code assumes that the top of the modeling domain +C is about 100 [mb] or 10 [kPa] ~ 16 [km] in altitude. If a +C higher altitude top is used , the method of calculating the +C ozone column and the ozone optical depth will be necessary. +C +C FSB This version has the addition of Rayleigh optical depth for the +C stratosphere as well as the calculation of single scattering +C albedo for the AOD calculation. (01/17/2006) +C FSB This version has deleted the JPROC values of Cs and Qy as well as +C the default aerosol. It also contains the fast optics +C routines. +C FSB This module supports the SAPRC99 Chemical mechanism within +C CMAQ. +C FSB This version calls a fast optical routine for aerosol +C extinction and scattering +C FSB This version uses a set of constant refractive indices +C The new subroutine GETNEWPAR now sets up the refractive indices. +C +C Bill Hutzell(Mar 2011) moved determining refractive indices to a +C separate file and new subroutine called AERO_PHOTDATA. +C +C Bill Hutzell(Jun 2011) modified TWOSTREAM_S subroutine to account for +C GAM2 equal to zero in the Toon et al. (1989) solution to the two stream +C of the radiative transfer equation based on how the NCAR TUV model +C implements the approximation +C +C Bill Hutzell(May 2013) modified optical depth agruments to give vetical +C profile rather than surface values. Note that TAU_TOT now includes +C stratospheric values. +! Bill Hutzell(Mar 2014) modified calculation of aerosol and cloud optical +! properites as well as their calculated optical depths. The changes employ +! FORTRAN modules that contain the layer level of the optical properties. +C 07 Jul 14 B.Hutzell: replaced mechanism include file(s) with fortran module +C 10/10/14 - DJL added references to IUPAC10 to NO2 and O3 photo rates +C 23Jun15 B.Hutzell: made TWOSTREAM and TRIDIAGONAL routine use REAL(8) variables +C 30Jul15 J.Young: REAL(4) -> REAL for code portability +C----------------------------------------------------------------------- + + USE CSQY_DATA + + IMPLICIT NONE + +!***include files + + INCLUDE SUBST_CONST ! physical constants + +!***parameters + + REAL, PARAMETER :: SMALL = 1.0E-36 ! a small number + +!***Fundamental Constants: ( Source: CRC76, pp 1-1 to 1-6) + + REAL, PARAMETER :: PLANCK_C = 6.62606876E-34 ! Planck's Constant [Js] + REAL, PARAMETER :: LIGHT_SPEED = 299792458.0 ! speed of light in a vacuum + + REAL, PARAMETER :: DU_TO_CONC = 2.6879E16 ! factor from [DU] to [molecules/cm^2] + REAL, PARAMETER :: CONC_TO_DU = 1.0 / DU_TO_CONC + + LOGICAL, PARAMETER :: ADJUST_OZONE = .FALSE. ! Flag to correct tropospheric ozone optical depth based + ! on climatology + + REAL :: MIN_STRATO3_FRAC ! minimum fraction of O3 column in statosphere + REAL :: MAX_TROPOO3_FRAC ! maximum fraction of O3 column in troposphere + +! REAL, PARAMETER :: MIN_STRATO3_FRAC = 0.55 ! minimum fraction of O3 column in statosphere + ! if PTOP = 50 mb +! REAL, PARAMETER :: MAX_TROPOO3_FRAC = 1.0 - MIN_STRATO3_FRAC ! maximum fraction of O3 column in troposphere + +!***LOGDEV for NEW_OPTICS and supporting routines + + INTEGER, SAVE :: NEW_OPTICS_LOG + + INTEGER, PARAMETER :: N_DIAG_WVL = 2 ! number of dianostic wavelengths + INTEGER, SAVE :: DIAG_WVL( N_DIAG_WVL ) ! pointers to diagnostic wavelengths + INTEGER :: N_TROPO_O3_TOGGLE ! number of adjustments to ozone extinction + + REAL, ALLOCATABLE :: ACTINIC_FLUX( :,: ) ! actinic fluxes, initially [Photons/(cm^2s)] then [Watts/m^2] + REAL, ALLOCATABLE :: IRRADIANCE ( :,: ) ! total downward irradiance [Watts/m^2] + REAL :: REFLECTION ! broad band reflection coefficient (diffuse) at model top + REAL :: TRANSMISSION ! broad band transmission coefficient (diffuse) at surface + REAL :: TRANS_DIRECT ! broad band direct transmission coefficient at surface + REAL :: TROPO_O3_COLUMN ! ozone column density in the troposphere [Dobson Units] + REAL :: TROPO_O3_TOGGLE ! factor correcting tropospheric ozone column + REAL :: O3_TOGGLE_AVE ! average of nonunity factors adjusting ozone extinction + REAL :: O3_TOGGLE_MIN ! Max of nonunity factors adjusting ozone extinction + + LOGICAL :: ONLY_SOLVE_RAD ! only compute fluxes + LOGICAL :: OBEY_STRATO3_MINS = .TRUE. ! Has stratospheric O3 column not violated + ! climatological minimums, yet? + LOGICAL :: STRATO3_MINS_MET ! Does the call to NEW_OPTICS meet the stratospheric O3 column + ! climatological minimums? + + + CHARACTER( 133 ) :: PHOT_MOD_MSG + + INTEGER :: PHOT_COL ! cell column of routine calling module routine + INTEGER :: PHOT_ROW ! cell row of routine calling module routine + + + CONTAINS + +C/////////////////////////////////////////////////////////////////////// + SUBROUTINE NEW_OPTICS ( JDATE, JTIME, NLAYS, + & BLKTA, BLKPRS, BLKDENS, BLKZH, BLKZF, + & BLKO3, BLKNO2, + & ZSFC, COSZEN, SINZEN, RSQD, + & NEW_PROFILE, CLOUDS, CLDFRC, + & BLKRJ, TAUC_AERO, TAU_TOT, TAUO3_TOP, + & TAU_RAY, SSA_AERO, TAU_CLOUD, TOTAL_O3_COLUMN ) +C----------------------------------------------------------------------- +C +C FSB NOTE new call vector <<<<<<<<<<<<< ********** +C +C FSB This version has clouds +C FSB calculates the photolysis rates as a function of species and height +C +C first coded 10/19/2004 by Dr. Francis S. Binkowski +C Carolina Environmental Program +C University of North Carolina at Chapel Hill +C email: frank_binkowski@unc.edu +C modified by FSB July 29, 2005, 01/19/2006 by FSB +C +C Mar 2011 Bill Hutzell +C -revised arguement to account for aerosol redesign in +C CMAQ version 5.0 +C -change array declaration to allow flexible number of +C wavelength bins +C Apr 2012 Bill Hutzell +C -revised error checking to needed photolysis data +C -modified case statement for RACM2 photolysis rates +C -moved aerosol optics to its own module +C 07 Jul 14 B.Hutzell: replaced mechanism include file(s) with fortran module +C----------------------------------------------------------------------- + + USE UTILIO_DEFN + USE RXNS_DATA ! chemical mechanism data + USE CLOUD_OPTICS ! data and routines for optics of cloud hydrometeors + + USE AERO_PHOTDATA + + IMPLICIT NONE + +!***arguments + INTEGER, INTENT(IN) :: JDATE ! julian date YYYYDDD + INTEGER, INTENT(IN) :: JTIME ! TIME HHMMSS + INTEGER, INTENT(IN) :: NLAYS ! # of vertical layers + + REAL, INTENT(IN) :: BLKPRS ( : ) ! Air pressure in [ atm ] + REAL, INTENT(IN) :: BLKTA ( : ) ! Air temperature [ K ] + REAL, INTENT(IN) :: BLKDENS( : ) ! Air density [ molecules / cm**3 ] + REAL, INTENT(IN) :: BLKZH ( : ) ! layer half-height [ m ] + REAL, INTENT(IN) :: BLKZF ( : ) ! layer full height[ m ] + REAL, INTENT(IN) :: BLKO3 ( : ) ! O3 concentration [ molecules / cm**3 ] + REAL, INTENT(IN) :: BLKNO2 ( : ) ! NO2 concentration [ molecules / cm**3 ] + REAL, INTENT(IN) :: ZSFC ! surface height (msl) [ m ] + REAL, INTENT(IN) :: COSZEN, SINZEN ! sine and cosine of the zenith angle + REAL, INTENT(IN) :: RSQD ! square of solar distance [ au**2 ] + + LOGICAL, INTENT(IN) :: NEW_PROFILE ! Has the atmospheric profile changed since last call? + LOGICAL, INTENT(IN) :: CLOUDS( : ) ! Does layer have clouds + REAL, INTENT(IN) :: CLDFRC( : ) ! fraction of gridcell covered by cloud + + + REAL, INTENT(OUT) :: BLKRJ( :,: ) ! photolysis rates [ 1 / sec ] + + REAL, INTENT(OUT) :: TAUC_AERO( :,: ) ! aerosol optical depth, bottom of layer + REAL, INTENT(OUT) :: TAU_TOT ( :,: ) ! total optical depth, bottom of layer + REAL, INTENT(OUT) :: TAU_CLOUD( :,: ) ! cloud optical depth, bottom of layer + + REAL, INTENT(INOUT) :: TAUO3_TOP( : ) ! optical depth of ozone above model domain + REAL, INTENT(INOUT) :: TAU_RAY ( : ) ! Rayleigh optical depth above model domain + REAL, INTENT(OUT) :: SSA_AERO ( : ) ! single scatering albedo for aerosol column + + REAL, INTENT(INOUT) :: TOTAL_O3_COLUMN ! total ozone colum density [ DU ] + +!***internal + REAL, PARAMETER :: ONE_OVER_PI = 1.0 / PI + REAL, PARAMETER :: STRAT_TEMP = 225.0 ! stratospheric temperature + REAL, PARAMETER :: ZTOA = 50.0E3 ! top of the atmosphere [ m ] + + INTEGER L, I, IWL, II, ILEV, IPHOT, MODE ! loop indices + + INTEGER NLEVEL + REAL SOLAR_FLUX ! solar flux at atmosphere top in a wavelength band, [photons/(cm^2*s)] + REAL INSOLATION ! downward solar flux at atmosphere top summed over wavelength bands, [photons/(cm^2*s)] + + REAL DELTA_O3_COLUMN ! change in ozone column density [molecules/cm2] + REAL STRAT_O3_COLUMN ! ozone column density in the stratosphere [molecules/cm2] + REAL STRAT_O3_COLMIN ! ozone minium column density in the stratosphere [molecules/cm2] + REAL TAU_O3 ! optical depth of stratospheric ozone [ m ] + REAL DENSTOM ! estimated air density at top of model [ molecules / cm**3 ] + REAL LAMDA ! wavelength [ nm ] + REAL INV_LAMBDA ! reciprocal of wavelength [ 1/nm ] + REAL LAMDA_UM ! wavelength [ um ] + +!***working absorption cross sections [ cm**2 ]. These have been corrected +!*** for ambient ( pressure and temperature ) conditions. + + REAL AO3 + REAL ANO2 + REAL BETA_M ! molecular scattering coefficient [ 1/m ] + REAL BEXT ! total aerosol extinction coefficient [ 1/m ] + REAL VFAC, BSC ! unit correction factors + REAL BSCAT ! total aerosol scattering coefficient [ 1/m ] + REAL G_BAR ! total aerosol asymmetry factor + +!***FSB The following variable is aq switch that allows a fast version of +!*** aerosol optics to be used when set to .TRUE. + +!***scattering and absorption for the layer + + REAL DTABS_A, DTABS_M, DTSCAT_A, DTSCAT_M, DTSCAT, DTABS + +!***variables describing the layer heights and slants +! REAL DJ, DF + REAL ZTOM ! top of model [ m ] + REAL, ALLOCATABLE, SAVE :: DSDH_TD( : ) ! slant path function from top down + REAL, ALLOCATABLE, SAVE :: BLKDZ( : ) ! layer thicknesses [ m ] + REAL, ALLOCATABLE, SAVE :: DSDH( : ) ! slant path function + REAL, SAVE :: DSDH_TOP ! slantpath function from ZTOM to ZTOA + +!***Increment of optical depth + + REAL, ALLOCATABLE, SAVE :: DTAU ( : ) ! total depth at level + REAL, ALLOCATABLE, SAVE :: DT_AERO ( : ) ! aerosol contribution at level + REAL, ALLOCATABLE, SAVE :: DT_CLOUD( : ) ! cloud contribution at level + +!***single scattering albedo for layer + + REAL, ALLOCATABLE, SAVE :: OM( : ) + +!***asymmetry factor + + REAL, ALLOCATABLE, SAVE :: G( : ) + +!***arrays for fluxes and irradiances used in + +!***delta-Eddington code + + REAL, ALLOCATABLE, SAVE :: FDIR( : ) ! direct actinic flux + REAL, ALLOCATABLE, SAVE :: FUP ( : ) ! diffuse upward actinic flux + REAL, ALLOCATABLE, SAVE :: FDN ( : ) ! diffuse downward flux + REAL, ALLOCATABLE, SAVE :: EDIR( : ) ! direct irradiance + REAL, ALLOCATABLE, SAVE :: EUP ( : ) ! diffuse upward irradiance + REAL, ALLOCATABLE, SAVE :: EDN ( : ) ! diffuse downward irradiance + +!***surface albedo + + REAL RSFC + + REAL FX + REAL, ALLOCATABLE, SAVE :: ESUM( : ) ! total downward irradiance + REAL, ALLOCATABLE, SAVE :: FSUM( : ) ! total actinic flux + +!***needed for stratospheric Raleigh optical depth + REAL, PARAMETER :: R_G = 100.0 * RDGAS / GRAV ! dry air gas constant + ! divided by gravitational + ! acceleration [cm/K] NOTE: cgs units + + REAL HSCALE ! Scale height [cm] ! NOTE: cgs units + + REAL NBAR ! total number of air molecules [ # /cm**2 ] + ! above top of model domain + + REAL, SAVE :: COS85 + +!***FSB Cloud properties. +!*** FSB These properties are taken fro HU & Stamnes,1993, +!*** An accurate parameterizationof the radiative properties of +!*** water clouds suitable for use in climate models, Journal of +!*** Climate, vol. 6, pp. 728-742. The values in the data statements +!*** were calculated with an equivalent radius of 10 micrometers. +!*** Note: Hu &Stamnes give beta in [ 1 / km/ for LWC in [ g / m**3 ] +!*** the values for beta/ LWC also give beta in [1/m] with LWC in [g/m **3] + + REAL G_CLOUD ! local cloud asymmetry factor + REAL OM_CLOUD ! local cloud single scattering albedo + REAL DTSCAT_CLOUD ! level increment in cloud scattering optical + REAL TAU_SCAT_CLD ! total scattering optical depth of cloud + REAL LAYERING_FACTOR ! correction factor for cloud layering + REAL STOZONE + + LOGICAL, SAVE :: FIRST = .TRUE. ! Flag for first call + LOGICAL :: SUCCESS + +!***arrays for fluxes and irradiances used in + REAL, ALLOCATABLE, SAVE :: SRAYL( : ) ! Molecular scattering cross sections [ cm ** 2] + REAL, ALLOCATABLE, SAVE :: TAU_SCAT( : ) ! aerosol scattering optical depth + REAL, ALLOCATABLE, SAVE :: CONV_WM2( : ) ! conversion factor [photons/(cm**2 s )] to [Watts/m**2] + +!***three-dimensional array for Cs and Qy +!*** (temperature, wavelength, species) +!***(layer, wavelength species) + + REAL, ALLOCATABLE, SAVE :: CSZ( :,:,: ) + REAL, ALLOCATABLE, SAVE :: QYZ( :,:,: ) + + IF ( FIRST ) THEN + + NEW_OPTICS_LOG = INIT3() + + ALLOCATE( CONV_WM2( NWL ) ) + ALLOCATE( SRAYL ( NWL ) ) + ALLOCATE( TAU_SCAT( NWL ) ) + ALLOCATE( CSZ( NLAYS,NWL,NPHOTAB ) ) + ALLOCATE( QYZ( NLAYS,NWL,NPHOTAB ) ) + + ALLOCATE( ACTINIC_FLUX( NLAYS,NWL ) ) + ALLOCATE( IRRADIANCE ( NLAYS,NWL ) ) + + ALLOCATE( DSDH_TD ( NLAYS+1 ), + & BLKDZ ( NLAYS ), + & DSDH ( NLAYS ), + & DTAU ( NLAYS+1 ), + & DT_AERO ( NLAYS+1 ), + & DT_CLOUD( NLAYS+1 ), + & OM ( NLAYS+1 ), + & G ( NLAYS+1 ), + & FDIR ( NLAYS+1 ), + & FUP ( NLAYS+1 ), + & FDN ( NLAYS+1 ), + & EDIR ( NLAYS+1 ), + & EUP ( NLAYS+1 ), + & EDN ( NLAYS+1 ), + & ESUM ( NLAYS ), + & FSUM ( NLAYS ) ) + +!***FSB Set up conversion factor for +!*** [photons / ( cm**2 s) ] to [Watts / m**2 ] +!*** THE 1.0E13 FACTO IS 1.0E9 * 1.0 E4 +!*** The 1.0e9 is for the wavelength [ nm ] -> [ m ] +!*** The 1.0e4 is for the area [ cm **2 ] -> [ m**2 ] + + DO IWL = 1, NWL + LAMDA = WAVELENGTH( IWL ) + CONV_WM2( IWL ) = 1.0E13 * ( PLANCK_C * LIGHT_SPEED ) / LAMDA + END DO + + COS85 = COS( 85.0 * PI180 ) + +!***get molecular scattering cross sections + + CALL GETSRAY ( NWL, WAVELENGTH, SRAYL ) + + FIRST = .FALSE. + + END IF ! FIRSTIME + +!***initialize BLKRJ and other layer variables + + BLKRJ = 0.0 + ACTINIC_FLUX = 0.0 + IRRADIANCE = 0.0 + REFLECTION = 0.0 + TRANSMISSION = 0.0 + TRANS_DIRECT = 0.0 + INSOLATION = 0.0 + TROPO_O3_TOGGLE = 1.0 + STRATO3_MINS_MET = .TRUE. +!***Initialize sums or set default values for outputs: +! TAUC_AERO, TAU_TOT, TAUO3_TOP, TAU_RAY, SSA_AERO, etc. + + TAUC_AERO = 0.0 + TAU_TOT = 0.0 + TAU_CLOUD = 0.0 + TAU_SCAT = 0.0 + SSA_AERO = 0.0 + TOTAL_TAU_CLD = 0.0 +#ifdef phot_debug + AVE_SSA_CLD = 0.0 + AVE_ASYMM_CLD = 0.0 +#endif +!***Test zenith angle. If coszen is zero or negative, zenith angle is +!*** equal to or greater than 90 degrees, i.e. before sunrise or +!*** after sunset at the surface. +!*** Return all photolysis rates set to zero. Ignore possible twilight +!*** processes in upper troposphere. + +!***FSB NOTE: tests of the algorithm for slant path show that the +!*** critical zenith angle for the tropospheric slant path is 88 degrees, +!*** but the critical zenith angle for the stratospheric slant path is +!*** 85 degrees. Thus, the code returns zeros for angles greater then or +!*** equalt to 85 degrees. cos( 85 degrees ) equals 8.715574e-02. + + IF ( COSZEN .LE. COS85 ) THEN + TAUO3_TOP = 0.0 + TAU_RAY = 0.0 + TOTAL_O3_COLUMN = 0.0 + TROPO_O3_COLUMN = 0.0 + TROPO_O3_TOGGLE = 1.0 + RETURN + END IF + + IF ( NEW_PROFILE ) THEN ! update based on new temperature and density profile +!***Adjust cross sections and quantum yields for ambient conditions + + CALL GET_CSQY ( BLKTA, BLKDENS, CSZ, QYZ ) + +!***calculate scale height from top of model domain + + HSCALE = R_G * BLKTA( NLAYS ) + +!***estimate air density at top of model domain + + DENSTOM = BLKDENS( NLAYS ) + & * EXP( -100.0 * ( BLKZF( NLAYS + 1 ) - BLKZH( NLAYS ) ) + & / HSCALE ) + +!***calculate the total number of air molecules [ # / cm**2 ] +!*** above top of model domain. + + NBAR = HSCALE * DENSTOM + +!***set top of modeling domain + + ZTOM = BLKZF( NLAYS + 1 ) + +!***get layer thicknesses and slantpath starting at the TOP + + CALL SLANTPATH2 ( NLAYS, BLKZF, ZSFC, REARTH, SINZEN, BLKDZ, DSDH ) + +!***get slantpath from ZTOM to ZTOA + + CALL SLANTPATHTOP ( ZTOM, ZTOA, ZSFC, REARTH, SINZEN, DSDH_TOP ) + +C*** find ozone column density for atmosphere, stratosphere, and troposphere + STRAT_O3_COLUMN = DU_TO_CONC * REAL( TOTAL_O3_COLUMN ) +! STRAT_O3_COLMIN = 0.10 * STRAT_O3_COLUMN + STRAT_O3_COLMIN = MIN_STRATO3_FRAC * STRAT_O3_COLUMN + SUCCESS = .TRUE. + TROPO_O3_COLUMN = 0.0 + DO L = NLAYS, 1, -1 + DELTA_O3_COLUMN = 100.0 * BLKO3( L ) * BLKDZ( L ) + STRAT_O3_COLUMN = STRAT_O3_COLUMN - DELTA_O3_COLUMN + TROPO_O3_COLUMN = TROPO_O3_COLUMN + DELTA_O3_COLUMN + IF ( STRAT_O3_COLUMN .LT. STRAT_O3_COLMIN .AND. SUCCESS ) THEN + IF( OBEY_STRATO3_MINS )THEN + WRITE( NEW_OPTICS_LOG,'( /A, F5.2, A, 3(/A), I3, A, F8.3, A , 2(I4,1X) )' ) + & 'PHOT WARNING: First Occurance where computed stratospheric O3 column < ', + & 100.0*MIN_STRATO3_FRAC,'%', + & 'observed total column. The percentage is a global minimum based on ', + & 'climatological ozone profiles. ', + & 'The Error accumulates downward from layer = ', L, ' or alt= ', + & 0.001*BLKZF( L ),' Km for col,row = ', PHOT_COL, PHOT_ROW + END IF + SUCCESS = .FALSE. + END IF + END DO + + STRAT_O3_COLUMN = CONC_TO_DU * STRAT_O3_COLUMN + TROPO_O3_COLUMN = CONC_TO_DU * TROPO_O3_COLUMN + +#ifdef verbose_PHOT_MOD + IF( PHOT_COL .EQ. 1 .AND. PHOT_ROW .EQ. 1 )THEN + WRITE( NEW_OPTICS_LOG,*)'TOTAL_O3_COLUMN, TROPO_O3_COLUMN = ',TOTAL_O3_COLUMN, TROPO_O3_COLUMN + END IF +#endif + + IF ( .NOT. SUCCESS ) THEN + TROPO_O3_TOGGLE = MAX_TROPOO3_FRAC * TOTAL_O3_COLUMN + & / TROPO_O3_COLUMN + N_TROPO_O3_TOGGLE = N_TROPO_O3_TOGGLE + 1 + O3_TOGGLE_AVE = O3_TOGGLE_AVE + TROPO_O3_TOGGLE + O3_TOGGLE_MIN = MIN( O3_TOGGLE_MIN, TROPO_O3_TOGGLE) + STRATO3_MINS_MET = .FALSE. + STRAT_O3_COLUMN = CONC_TO_DU * STRAT_O3_COLMIN + IF( OBEY_STRATO3_MINS )THEN ! write to PE log for first occurance + WRITE( NEW_OPTICS_LOG, 99983)STRAT_O3_COLUMN + IF( ADJUST_OZONE ) WRITE( NEW_OPTICS_LOG, 99984)TROPO_O3_TOGGLE + WRITE( NEW_OPTICS_LOG, 99887) + WRITE( NEW_OPTICS_LOG, 99888)TOTAL_O3_COLUMN, TROPO_O3_COLUMN, MAX_TROPOO3_FRAC + WRITE( NEW_OPTICS_LOG, 99999) + OBEY_STRATO3_MINS = .FALSE. + END IF + IF( .NOT. ADJUST_OZONE ) TROPO_O3_TOGGLE = 1.0 ! reset toggle to one + ELSE + TROPO_O3_TOGGLE = 1.0 + END IF + + +99983 FORMAT( 'Corrective Action: 1) Stratospheric O3 column set to ',F8.3,' DU' ) +99984 FORMAT( 'and 2) Extinction from Model Domain O3 multiplied by ',F9.6 ) +99887 FORMAT(/'Check TROPO_O3_EXCEED and N_EXCEED_TROPO3 in PHOTDIAG1 file for ' + & /'values greater than zero to assess the extent of the ' + & /'problem. TROPO_O3_EXCEED and N_EXCEED_TROPO3 are the average ' + & /'exceedance and their number over file time step for each grid cell,' + & /'respectively. Exceedance depends on the predicted tropospheric' + & /'fraction over the maximum allowed fraction of the total ozone column.' + & /'Its value equals the ratio minus one if ratio is greater than one and' + & /'zero if the ratio is less than or equal to one. N_EXCEED_TROPO3 ' + & /'counts the number of nonzero values per timestep') +99888 FORMAT(/'Direct Cause: Predicted O3 tropospheric Column exceeds maximum allowed ' + & /'fraction of total OMI column.', + & /'OMI Total O3 Column = ',F8.3,' DU: Model Tropospheric O3 Column = ',F8.3,' DU', + & /'Climatological Expected Tropospheric Fraction = ',F9.6) +99999 FORMAT(/'ULTIMATE causes include boundary condition and meteorological input files. ' + & /'Check the former for unrealistic concentrations of ozone and its precursors.' + & /'Check the latter for unrealistic advection and diffusion parameters.') + + DO IWL = 1, NWL +!***Get optical depth for stratospheric ozone column +!***Note that stratosphere ozone coluumn assumed to exist above model domain + CALL GET_TAUO3 ( IWL, STRAT_O3_COLUMN, STRAT_TEMP, TAUO3_TOP( IWL ) ) +!***get Rayleigh optical depth for stratosphere + TAU_RAY( IWL ) = NBAR * SRAYL( IWL ) + END DO + END IF ! for NEW_PROFILE + +!***loop over wavelengths + DO IWL = 1, NWL ! outermost loop + +! RSFC = ALB( IWL ) ! surface albedo + +!***set scaling factor for reducing extraterrestrial flux +!*** add ozone and Rayleigh optical depths. Use the +!*** pseudospherical correction for the stratosphere. + + SOLAR_FLUX = FEXT( IWL ) / RSQD + +!*** initialize tau, delta tau's, other variables and loop over layers + + DTAU = 0.0 + DT_AERO = 0.0 + DT_CLOUD = 0.0 + DTSCAT_CLOUD = 0.0 + TAU_SCAT_CLD = 0.0 + + DO L = 2, NLAYS + 1 + II = NLAYS + 2 - L ! from top to bottom + +!***in the following statements the factor of 100.0 converts +!*** converts [ 1 / cm ] to [ 1 / m ] + + BETA_M = SRAYL( IWL ) * BLKDENS( II ) * 100.0 + AO3 = CSZ( II,IWL,LO3O3P ) * BLKO3 ( II ) * 100.0 + AO3 = TROPO_O3_TOGGLE * AO3 + ANO2 = CSZ( II,IWL,LNO2 ) * BLKNO2 ( II ) * 100.0 + +!***set up aerosol optical properties + + G_BAR = AERO_ASYM_FAC ( II,IWL ) + BEXT = AERO_EXTI_COEF( II,IWL ) + BSCAT = AERO_SCAT_COEF( II,IWL ) + +!***calculate total absorption and scattering contributions +!***to optical depth + +!***The contributions to scattering and absorption from molecules and particles +!*** are calculated separately to facilitate the calculation +!*** of the total single scatering albedo of the column of aerosols +!*** as measured by satellites. + + DTSCAT_M = BETA_M * BLKDZ( II ) ! molecular scattering + DTSCAT_A = BSCAT * BLKDZ( II ) ! particle scattering + + DTSCAT_M = MAX( DTSCAT_M, SMALL ) + DTSCAT_A = MAX( DTSCAT_A, SMALL ) + + + DTABS_M = ( AO3 + ANO2 ) * BLKDZ( II ) ! molecular absorption + DTABS_A = ( BEXT - BSCAT ) * BLKDZ( II ) ! particle absorption + + DTABS_M = MAX( DTABS_M, SMALL ) + DTABS_A = MAX( DTABS_A, SMALL ) + + IF ( CLOUDS( II ) ) THEN + + DT_CLOUD( L ) = ( CLOUD_LIQUID_EXT( II,IWL ) + & + CLOUD_ICE_EXT( II,IWL ) + & + CLOUD_AGGREG_EXT( II,IWL ) ) * BLKDZ( II ) + DTSCAT_CLOUD = ( CLOUD_LIQUID_SCAT( II,IWL ) + & + CLOUD_ICE_SCAT( II,IWL ) + & + CLOUD_AGGREG_SCAT( II,IWL ) ) * BLKDZ( II ) + +!Adjust DT_CLOUD for cloud fraction by 1/2 power of CLDFRC to approximate cloud overlap. +!Note that the power results because the resolved cloud conentrations are averaged over +!the grid cell so the net overlap correction equal cfrac**(3/2) from Briegleb (1992) times +!cfrac**(-1) for actual in-cloud concentrations (see Voulgarakis et al., 2009, Geosci Model +!Dev., vol. 2, pp. 59-72. + + IF ( CLOUD_LAYERING( II ) ) THEN + LAYERING_FACTOR = SQRT( CLDFRC( II ) ) + ELSE + LAYERING_FACTOR = CLDFRC( II ) + END IF + DT_CLOUD( L ) = DT_CLOUD( L ) * LAYERING_FACTOR + DTSCAT_CLOUD = DTSCAT_CLOUD * LAYERING_FACTOR + + TAU_SCAT_CLD = TAU_SCAT_CLD + DTSCAT_CLOUD + + IF ( DT_CLOUD( L ) .GT. 1.0E-6 ) THEN + OM_CLOUD = MAX( DTSCAT_CLOUD /DT_CLOUD( L ), 1.0) + IF ( OM_CLOUD .LT. 0.0 .OR. OM_CLOUD .GT. 1.0 .OR. OM_CLOUD .NE. OM_CLOUD) THEN + WRITE( NEW_OPTICS_LOG,'(A,I3,A,ES12.4,A)',ADVANCE = 'NO') + & 'OM_CLOUD( L = ', L, ' ) = ', OM_CLOUD,' resetting to ' + OM_CLOUD = MAX( 0.000001, MIN( OM_CLOUD, 0.99999)) + WRITE( NEW_OPTICS_LOG,'(ES12.4)')OM_CLOUD + WRITE( NEW_OPTICS_LOG,'(A,2(ES12.4,1X))')'LIQUID_EXT, LIQUID_SCAT = ', + & CLOUD_LIQUID_EXT( II,IWL ), CLOUD_LIQUID_SCAT( II,IWL ) + WRITE( NEW_OPTICS_LOG,'(A,2(ES12.4,1X))')'ICE_EXT, ICE_SCAT = ', + & CLOUD_ICE_EXT( II,IWL ), CLOUD_ICE_SCAT( II,IWL ) + WRITE( NEW_OPTICS_LOG,'(A,2(ES12.4,1X))')'AGGREG_EXT, AGGREG_SCAT = ', + & CLOUD_AGGREG_EXT( II,IWL ), CLOUD_AGGREG_SCAT( II,IWL ) + CALL M3EXIT( 'NEW_OPTICS', JDATE, JTIME, ' ', XSTAT1 ) + END IF + ELSE + OM_CLOUD = 1.0 + END IF + + IF ( DTSCAT_CLOUD .GT. 1.0E-6 ) THEN + + G_CLOUD = ( (CLOUD_LIQUID_ASY( II,IWL ) * CLOUD_LIQUID_SCAT( II,IWL )) + & + (CLOUD_ICE_ASY( II,IWL ) * CLOUD_ICE_SCAT( II,IWL )) + & + (CLOUD_AGGREG_ASY( II,IWL ) * CLOUD_AGGREG_SCAT( II,IWL )) ) + & * BLKDZ( II ) * LAYERING_FACTOR + +#ifdef phot_debug + IF ( .NOT. ONLY_SOLVE_RAD ) THEN + AVE_ASYMM_CLD( IWL ) = AVE_ASYMM_CLD( IWL ) + G_CLOUD + IF ( AVE_ASYMM_CLD( IWL ) .GT. TAU_SCAT_CLD ) THEN + WRITE( NEW_OPTICS_LOG,'(A,I3,2(A,ES12.4))' ) + & 'Sum for AVE_ASYMM_CLD at L (', L,') = ', AVE_ASYMM_CLD( IWL ), + & ' Sum for TAU_SCAT_CLD = ',TAU_SCAT_CLD + WRITE( NEW_OPTICS_LOG,'(A,2(ES12.4,1X))' ) + & 'AVE_ASYMM_CLD Increment = ', G_CLOUD + WRITE( NEW_OPTICS_LOG,'(A,2(ES12.4,1X))' ) + & 'TAU_SCAT_CLD Increment = ', DTSCAT_CLOUD + END IF + END IF +#endif + + G_CLOUD = G_CLOUD / DTSCAT_CLOUD + + IF ( G_CLOUD .GE. 1.0 .OR. G_CLOUD .LE. -1.0 .OR. G_CLOUD .NE. G_CLOUD ) THEN + WRITE( NEW_OPTICS_LOG,'(A,I3,A,ES12.4,A)',ADVANCE = 'NO' ) + & 'G_CLOUD( L = ', L, ' ) = ', G_CLOUD,' resetting to ' + G_CLOUD = MIN( 0.9999, MAX( G_CLOUD, -0.9999) ) + WRITE( NEW_OPTICS_LOG,'(ES12.4)') G_CLOUD + WRITE( NEW_OPTICS_LOG,'(A,2(ES12.4,1X))' ) + & 'LIQUID_ASY, LIQUID_SCAT = ', + & CLOUD_LIQUID_ASY( II,IWL ), CLOUD_LIQUID_SCAT( II,IWL ) + WRITE( NEW_OPTICS_LOG,'(A,2(ES12.4,1X))' ) + & 'ICE_ASY, ICE_SCAT = ', + & CLOUD_ICE_ASY( II,IWL ), CLOUD_ICE_SCAT( II,IWL ) + WRITE( NEW_OPTICS_LOG,'(A,2(ES12.4,1X))' ) + & 'AGGREG_ASY, AGGREG_SCAT = ', + & CLOUD_AGGREG_ASY( II,IWL ), CLOUD_AGGREG_SCAT( II,IWL ) + CALL M3EXIT( 'NEW_OPTICS', JDATE, JTIME, ' ', XSTAT1 ) + END IF + ELSE + G_CLOUD = 0.0 + END IF + ELSE + DTSCAT_CLOUD = 0.0 + G_CLOUD = 0.0 + OM_CLOUD = 1.0 + END IF + +!***calculate total absorption and scattering contributions +!***to optical depth + + DTSCAT = DTSCAT_M + DTSCAT_A + DTSCAT_CLOUD + DTABS = DTABS_M + DTABS_A + MAX(( 1.0 - OM_CLOUD ), 0.0) * DT_CLOUD( L ) + +!***set aerosol optical depth for later use + + DT_AERO ( L ) = BEXT * BLKDZ( II ) + +!***Now calculate the vertical profiles of optical depth, +!*** single scattering albedo, asymmetry factor +!*** and DSDH starting at the top. + + DTAU( L ) = DTSCAT + DTABS + OM ( L ) = DTSCAT / ( DTSCAT + DTABS ) + G ( L ) = ( G_BAR * DTSCAT_A + G_CLOUD * DTSCAT_CLOUD ) / DTSCAT + + IF ( G( L ) .GE. 1.0 .OR. G( L ) .LE. -1.0 .OR. G( L ) .NE. G( L ) ) THEN + WRITE( NEW_OPTICS_LOG,'(A,ES12.4,A)',ADVANCE = 'NO' ) + & 'G( L ) = ', G( L ),' resetting to ' + G( L ) = MIN( 0.9999, MAX( G( L ), -0.9999) ) + WRITE( NEW_OPTICS_LOG,'(ES12.4)')G( L ) + WRITE( NEW_OPTICS_LOG,'(A,10(1X,ES12.4))' ) + & 'DTSCAT_M, DTSCAT_A, DTSCAT_CLOUD, G_BAR, G_CLOUD = ', + & DTSCAT_M, DTSCAT_A, DTSCAT_CLOUD, G_BAR, G_CLOUD + END IF + + IF ( OM( L ) .GT. 1.0 .OR. OM( L ) .LE. 0.0 .OR. OM( L ) .NE. OM( L ) ) THEN + WRITE( NEW_OPTICS_LOG,'(A,ES12.4,A)',ADVANCE = 'NO' ) + & 'OM( L ) = ', OM( L ),' resetting to ' + OM( L ) = MIN( 0.9999, MAX( OM( L ), 0.0001) ) +#ifdef phot_debug + WRITE( NEW_OPTICS_LOG,'(ES12.4)' ) OM( L ) + WRITE( NEW_OPTICS_LOG,'(A,4(1X,ES12.4))' ) + & 'DTSCAT, DTABS, ( DTSCAT + DTABS) = ', + & DTSCAT, DTABS, ( DTSCAT + DTABS ) + WRITE( NEW_OPTICS_LOG,'(A,4(1X,ES12.4))' ) + & 'DTSCAT_M, DTSCAT_A, DTSCAT_CLOUD = ', + & DTSCAT_M, DTSCAT_A, DTSCAT_CLOUD + WRITE( NEW_OPTICS_LOG,'(A,4(1X,ES12.4))' ) + & 'DDTABS_M, DTABS_A, MAX(( 1.0-OM_CLOUD ), 0.0) * DT_CLOUD( L ) = ', + & DTABS_M, DTABS_A, MAX(( 1.0 - OM_CLOUD ), 0.0) * DT_CLOUD( L ) + WRITE( NEW_OPTICS_LOG,'(A,4(1X,ES12.4))' ) + & ' AO3, ANO2,AERO_BEXT, AERO_BSCAT = ', + & AO3, ANO2,BEXT, BSCAT +#endif + ELSE +#ifdef phot_debug + IF ( OM( L ) .EQ. 1.0 ) THEN + WRITE( NEW_OPTICS_LOG,'(A,4(1X,ES12.4))' ) + & 'DTSCAT, DTABS, ( DTSCAT + DTABS ) = ', + & DTSCAT, DTABS, (DTSCAT + DTABS) + WRITE( NEW_OPTICS_LOG,'(A,4(1X,ES12.4))' ) + & 'DTSCAT_M, DTSCAT_A, DTSCAT_CLOUD = ', + & DTSCAT_M, DTSCAT_A, DTSCAT_CLOUD + WRITE( NEW_OPTICS_LOG,'(A,4(1X,ES12.4))' ) + & 'DDTABS_M, DTABS_A, MAX(( 1.0-OM_CLOUD ), 0.0) * DT_CLOUD( L ) = ', + & DTABS_M, DTABS_A, MAX(( 1.0 - OM_CLOUD ), 0.0 ) * DT_CLOUD( L) + WRITE( NEW_OPTICS_LOG,'(A,4(1X,ES12.4))' ) + & 'AO3, ANO2,AERO_BEXT, AERO_BSCAT = ', + & AO3, ANO2,BEXT, BSCAT + END IF +#endif + OM( L ) = MIN( 0.9999, OM( L ) ) + END IF + + DSDH_TD( L ) = DSDH( L - 1 ) + + IF ( ONLY_SOLVE_RAD ) CYCLE +!***FSB get sums of unscaled optical depths + + TAU_SCAT( IWL ) = TAU_SCAT ( IWL ) + DTSCAT_A + +!***initialize optical depth profiles to the layer increment + + TAUC_AERO( II,IWL ) = DT_AERO( L ) ! aerosol optical depth + TAU_TOT ( II,IWL ) = DTAU( L ) ! total optical depth + TAU_CLOUD( II,IWL ) = DT_CLOUD( L ) ! cloud optical depth + + END DO ! loop over layers + +!***set values for the stratosphere + + OM ( 1 ) = TAU_RAY( IWL ) / ( TAU_RAY( IWL ) + TAUO3_TOP( IWL ) ) + G ( 1 ) = 0.05 + DTAU ( 1 ) = TAUO3_TOP( IWL ) + TAU_RAY( IWL ) + DSDH_TD( 1 ) = DSDH_TOP + + NLEVEL = NLAYS + 1 + + IF ( .NOT. ONLY_SOLVE_RAD ) THEN +!***calculate optical depth profiles + TAU_TOT ( NLAYS,IWL ) = TAU_TOT ( NLAYS,IWL ) + DTAU( 1 ) + TAUC_AERO( NLAYS,IWL ) = TAUC_AERO( NLAYS,IWL ) + DT_AERO( 1 ) + TAU_CLOUD( NLAYS,IWL ) = TAU_CLOUD( NLAYS,IWL ) + DT_CLOUD( 1 ) + + DO L = NLAYS-1, 1, -1 + TAU_TOT ( L,IWL ) = TAU_TOT ( L,IWL ) + TAU_TOT ( L+1,IWL ) + TAUC_AERO( L,IWL ) = TAUC_AERO( L,IWL ) + TAUC_AERO( L+1,IWL ) + TAU_CLOUD( L,IWL ) = TAU_CLOUD( L,IWL ) + TAU_CLOUD( L+1,IWL ) + END DO + END IF + +!***Set fluxes to zero + + FDIR = 0.0 + FUP = 0.0 + FDN = 0.0 + EDIR = 0.0 + EUP = 0.0 + EDN = 0.0 + +!***calculate fluxes and irradiances + + CALL TWOSTREAM_S ( NLEVEL, COSZEN, ALB( IWL ), DTAU, OM, G, DSDH_TD, + & FDIR, FUP, FDN, EDIR, EUP, EDN ) + + DO L = 1, NLAYS + II = NLAYS + 2 - L + FSUM( L ) = FDIR( II ) + FDN( II ) + FUP( II ) ! actinic flux + ESUM( L ) = EDIR( II ) + EDN( II ) ! downward irradiance + END DO ! loop over layers + +! add diffusion and direct components for calculating reflectivity and transmissivity + INSOLATION = INSOLATION + SOLAR_FLUX + REFLECTION = REFLECTION + SOLAR_FLUX * EUP( 1 ) + TRANSMISSION = TRANSMISSION + SOLAR_FLUX * EDN( NLEVEL ) + TRANS_DIRECT = TRANS_DIRECT + SOLAR_FLUX * EDIR( NLEVEL ) + + IF ( ONLY_SOLVE_RAD ) CYCLE + +!***FSB Calculate column averaged scattering albedo and asymmetry factor + + IF ( TAUC_AERO( 1,IWL ) .GT. 1.0E-30 ) THEN + SSA_AERO( IWL ) = TAU_SCAT( IWL ) / TAUC_AERO( 1,IWL ) + END IF + + TOTAL_TAU_CLD( IWL ) = TAU_CLOUD( 1,IWL ) + +#ifdef phot_debug + IF ( TAU_CLOUD( 1,IWL ) .GT. 1.0E-20 ) THEN + IF ( AVE_ASYMM_CLD( IWL ) .GT. TAU_SCAT_CLD ) THEN + WRITE( NEW_OPTICS_LOG,'(A,I3,2(A,ES12.4))' ) + & 'Sum for AVE_ASYMM_CLD at L(', 1,') = ', AVE_ASYMM_CLD( IWL ), + & 'Sum for TAU_SCAT_CLD = ',TAU_SCAT_CLD + WRITE( NEW_OPTICS_LOG,'(A,2(ES12.4,1X))' ) + & 'AVE_ASYMM_CLD Increment = ', G_CLOUD + WRITE( NEW_OPTICS_LOG,'(A,2(ES12.4,1X))' ) + & 'TAU_SCAT_CLD Increment = ', + & DTSCAT_CLOUD + END IF + IF ( TAU_SCAT_CLD .GT. 1.0E-20 ) THEN + AVE_ASYMM_CLD( IWL ) = AVE_ASYMM_CLD( IWL ) / TAU_SCAT_CLD + AVE_SSA_CLD ( IWL ) = TAU_SCAT_CLD / TAU_CLOUD( 1,IWL ) + ELSE + AVE_ASYMM_CLD( IWL ) = 0.0 + AVE_SSA_CLD ( IWL ) = 0.0 + END IF + IF ( ABS( AVE_ASYMM_CLD( IWL ) ) .GE. 1.0 ) THEN + WRITE( NEW_OPTICS_LOG,'(A,I3,2(A,ES12.4))' ) + & 'Sum for AVE_ASYMM_CLD at L(', 1,') = ', AVE_ASYMM_CLD( IWL )*TAU_SCAT_CLD, + & 'Sum for TAU_SCAT_CLD = ',TAU_SCAT_CLD + WRITE( NEW_OPTICS_LOG,'(A,2(ES12.4,1X))' ) + & 'AVE_ASYMM_CLD Increment = ', G_CLOUD + WRITE( NEW_OPTICS_LOG,'(A,2(ES12.4,1X))' ) + & 'TAU_SCAT_CLD Increment = ', DTSCAT_CLOUD + END IF + ELSE + TOTAL_TAU_CLD( IWL ) = 0.0 + AVE_SSA_CLD ( IWL ) = 0.0 + AVE_ASYMM_CLD( IWL ) = 0.0 + END IF +#endif + +!***FSB capture the total downward irradiance at the surface [ W / m**2] +! +! ETOT_SFC( IWL ) = CONV_WM2( IWL ) * FLXSCALE * FEXT( IWL ) +! & * ESUM( 1 ) + + FORALL( L = 1:NLAYS ) +!***multiply by the solar flux at the domain top for +!***actinic flux and irradiance; keeping actinic flux in photons/(cm^2*s) + ACTINIC_FLUX( L,IWL ) = SOLAR_FLUX * FSUM( L ) + IRRADIANCE ( L,IWL ) = SOLAR_FLUX * CONV_WM2( IWL ) * ESUM( L ) + END FORALL + END DO ! loop over wavelengths + +! normalize reflection and transmission coefficients + INSOLATION = 1.0 / ( COSZEN * INSOLATION ) + TRANS_DIRECT = TRANS_DIRECT * INSOLATION + REFLECTION = ONE_OVER_PI * REFLECTION * INSOLATION + TRANSMISSION = ONE_OVER_PI * TRANSMISSION * INSOLATION + + IF ( ONLY_SOLVE_RAD ) RETURN + +! compute photolysis rates + DO IPHOT = 1, NPHOTAB + DO IWL = 1, NWL + DO L = 1, NLAYS + BLKRJ( L,IPHOT ) = BLKRJ( L,IPHOT ) + & + ACTINIC_FLUX( L,IWL ) + & * CSZ( L,IWL,IPHOT ) * QYZ( L,IWL,IPHOT ) ! [ 1 / sec ] + END DO + END DO + END DO ! loop on layers, wavelength, IPHOT +! convert actinic flux to watts/m^2 + FORALL( L = 1:NLAYS, IWL=1:NWL ) + ACTINIC_FLUX( L,IWL ) = ACTINIC_FLUX( L,IWL ) * CONV_WM2( IWL ) + END FORALL + +!***compute rate of photolysis (j-values) for each reaction + +9503 FORMAT('LAYER = ',I3,' MODE = ',I3,' LAMBDA(nm) = ',ES12.4,' DGN_CORE(m) = ',ES12.4, + & ' DGN_SHELL(m) = ', ES12.4 / ' REFRACT_IDX_SHELL(NR,NI) = ', 2(ES12.4,1X), + & ' REFRACT_IDX_CORE(NR,NI) = ', 2(ES12.4,1X) / ' LN(GEO.STD.DEV.) = ', + & ES12.4) +9504 FORMAT('LAYER = ',I3,' MODE = ',I3,' LAMBDA(nm) = ',ES12.4,' DGN(m) = ',ES12.4, + & ' REFRACT_IDX(NR,NI) = ', 2(ES12.4,1X) / ' VOL.DENS. = ', ES12.4, + & ' LN(GEO.STD.DEV.) = ', ES12.4) + +99985 FORMAT('ERROR: Modeled Troposheric Ozone Column downward from layer ',I3,1X) +99986 FORMAT('exceeds Top Ozone Column based on OMI.data file. Negative Optical Depths ') +99987 FORMAT('but are physically unlikey.') +99988 FORMAT(' SETTING O3 Column ABOVE PTOP TO 25% of OMI.dat value ') +99989 FORMAT(' FOR ROW/COL = ',2(1X,I4)) + + RETURN + END SUBROUTINE NEW_OPTICS + +C/////////////////////////////////////////////////////////////////////// + + SUBROUTINE GETSRAY ( NWL, LAMDA, SRAYL ) +C----------------------------------------------------------------------- +C calculate molecular (Rayleigh) scattering cross section, srayl +C +C coded 09/08/2004 by Dr. Francis S. Binkowski +C Carolina Environmental Program +C University of North Carolina at Chapel Hill +C email: frank_binkowski@unc.edu +C +C Reference: +C Nicolet, M., On the molecular scattering in the terrestrial +C atmosphere: An empirical formula for its calculation in the +C homoshpere, Planetary and Space Science. Vol. 32,No. 11, +C Pages 1467-1468, November 1984. +C----------------------------------------------------------------------- + + IMPLICIT NONE + +!***arguments + + INTEGER, INTENT( IN ) :: NWL ! number of wavelength bins + REAL, INTENT( IN ) :: LAMDA( : ) ! wavelengths [nm] + REAL, INTENT( OUT ) :: SRAYL( : ) ! molecular scattering cross sections [cm**2] + +!***Internal variables + + INTEGER I + REAL WMICRN ! wavelenght in micrometers + REAL WMICRN1 ! 1 / wmicrn + REAL XX ! variable in Nicolet method + +!***get molecular scattering cross section. This is a fixed +!*** function of wavelength. + + DO I = 1, NWL + WMICRN = 1.0E-3 * LAMDA( I ) ! wavelength in micrometers + WMICRN1 = 1.0 / WMICRN + + IF ( WMICRN .LE. 0.55 ) THEN + XX = 3.6772 + 0.389 * WMICRN + 0.09426 * WMICRN1 + ELSE + XX = 4.04 + END IF + + SRAYL( I ) = 4.02E-28 * WMICRN1**XX ! in [cm**2] + + END DO + + RETURN + END SUBROUTINE GETSRAY + + + SUBROUTINE GET_TAUO3 ( IWL, STOZONE, STRAT_TEMP, TAU_O3 ) +C----------------------------------------------------------------------- +C subroutine to calculate the optical depth of ozone in the +C stratosphere +C +C special cross sections for calculating stratospheric ozone +C optical depth +C +C the following temperatures and cross sections are from +C Fast-J +C REFERENCE: +C Wild, O., X. Zhu, and M.J. Prather, Fast-J: Accurate simulation +C of in- and below-clolud photolysis in tropospheric chemical +C models, +C Journal of Atmospheric Chemistry, Vol. 37, pp 245-282, 2000 +C +C coded 10/20/2004 by Dr. Francis S. Binkowski +C Carolina Environmental Program +C University of North Carolina at Chapel Hill +C email: frank_binkowski@unc.edu +C Updated to Fast-JX version 5.0 +C Mar 2011 Bill Hutzell +C revised interpolation method for a general number of +C interpolation points +C +C----------------------------------------------------------------------- + + IMPLICIT NONE + +!***arguments + + INTEGER, INTENT( IN ) :: IWL ! wavelenth index + + REAL, INTENT( IN ) :: STOZONE ! ozone column amount [ DU ] + REAL, INTENT( IN ) :: STRAT_TEMP ! average temperature for stratosphere [ K ] + REAL, INTENT( OUT ) :: TAU_O3 ! optical depth for statosphere + +!***Local + + INTEGER IXT, IXTEMP + + REAL OZONE_CS ! interpolated ozone absorption cross section + REAL YTT ! interpolation variable + +!***Find temperature range: + + IF ( STRAT_TEMP .LE. TEMP_O3_STRAT( 1 ) ) IXTEMP = 0 + + DO IXT = 1, NTEMP_STRAT - 1 + IF ( STRAT_TEMP .GT. TEMP_O3_STRAT( IXT ) .AND. + & STRAT_TEMP .LT. TEMP_O3_STRAT( IXT + 1 ) ) THEN + IXTEMP = IXT + YTT = ( STRAT_TEMP - TEMP_O3_STRAT( IXT ) ) + & / ( TEMP_O3_STRAT( IXT + 1 ) - TEMP_O3_STRAT( IXT ) ) + END IF + END DO + + IF ( STRAT_TEMP .GE. TEMP_O3_STRAT( NTEMP_STRAT ) ) THEN + IXTEMP = NTEMP_STRAT + YTT = 0.0 + END IF + +!***do linear interpolation + + IF ( IXTEMP .EQ. 0 ) THEN + OZONE_CS = XO3CS( 1, IWL ) + ELSE IF ( IXTEMP .GE. 1 .AND. IXTEMP .LT. NTEMP_STRAT ) THEN + OZONE_CS = XO3CS( IXTEMP, IWL ) + + & ( XO3CS( IXTEMP+1, IWL ) - XO3CS( IXTEMP, IWL ) ) * YTT + ELSE IF ( IXTEMP .EQ. NTEMP_STRAT ) THEN + OZONE_CS = XO3CS( IXTEMP, IWL ) + END IF + + TAU_O3 = DU_TO_CONC * STOZONE * OZONE_CS + + RETURN + END SUBROUTINE GET_TAUO3 + +C/////////////////////////////////////////////////////////////////////// + + SUBROUTINE O3AMT ( XLAT, XLONG, MDAY, OZONE ) +C----------------------------------------------------------------------- +C This subroutine implements an algorithm for the annual behavior +C of total ozone ( taken here to be stratospheric) from +C climatology +C Reference: +C Van Heuklon, Thomas K., Estimating atmospheric ozone for solar +C radiation models, Solar Energy, Vol. 22, pp 63-68, 1979. +C updated from an earlier version by +C Dr. Francis S. Binkowski, The Carolina Environmental Program, +C The University of North Carolina at Chapel Hill. +C Email: frank_binkowski@unc.edu +C November 03. 2004. +C Only Northern Hemisphere is implemented. +C----------------------------------------------------------------------- + + IMPLICIT NONE + +!***arguments + + INTEGER, INTENT( IN ) :: MDAY ! Day number during the year + ! Jan 1st = 1.0, Feb 1st = 32, etc. + + REAL, INTENT( IN ) :: XLAT ! latitude of point on earth's surface + REAL, INTENT( IN ) :: XLONG ! longitude of point on earth's surface + REAL, INTENT( OUT ) :: OZONE ! Total column amount of ozone [ DU ] + +!***Internal: + +!***The following parameters are from Table 1 of Van Heuklon (1979). + + REAL, SAVE :: A, B, C, D, F, G, H, FJ + DATA A/150.0/, B/1.28/, C/40.0/, D/0.9865/, F/-30.0/, G/20.0/, + & H/3.0/, FJ/235.0/ + +!***FSB FJ is the equatorial annual average of atmospheric ozone +!*** content, as noted on page 65 of Nav Heulklon (1979). This value +!*** sets the basic background for ozone. + + REAL, PARAMETER :: RD = 0.017453 ! degrees to radians + +!***Variables of convenience + + REAL E, FI, BPHI, DEF, HLI, SINB, SINB2 + +!***set the day + + E = FLOAT( MDAY ) + FI = 20.0 + IF ( XLONG .LT. 0.0 ) FI = 0.0 + BPHI = B * XLAT * RD + DEF = D * ( E + F ) * RD + HLI = H * ( XLONG + FI ) * RD + SINB = SIN( BPHI ) + SINB2 = SINB * SINB + +!***the following equation implements equation (4) of VanHeuklon (1979) + + OZONE = FJ + ( A + C * SIN( DEF ) + G * SIN( HLI ) ) * SINB2 + + RETURN + END SUBROUTINE O3AMT + +C/////////////////////////////////////////////////////////////////////// + + SUBROUTINE SLANTPATH2 ( NLAYS, Z, ZSFC, REARTH, SINZEN, DZ, DSDH ) +C----------------------------------------------------------------------- +C PURPOSE: +C Calculate slant path, ds/dh, over vertical depth in spherical +C geometry also calculates the layer thicknesses. +C NOTE!!! +C This version is restricted to zenith angle less than 90 degrees +C----------------------------------------------------------------------- +C ARGUMENTS: +C INPUT: +C NLAYS - INTEGER, number of specified altitude levels +C z - REAL, altitude (agl) [m] <<< meters +C This is from file ZF ( full layers ) from METCRO3D +C Z(1) is zero. +C zsfc - REAL, ground elevation (msl) [m] +C rearth - REAL, radius of the earth [m] +C sinzen - REAL, sine of solar zenith angle +C +C OUTPUT: +C dz - REAL, layer thicknesses [ m ] +C dsdh - REAL, slant path of direct beam through each layer +C when travelling from the top of the atmosphere downward +C----------------------------------------------------------------------- +C EDIT HISTORY: +C Inspired by sphers from TUV +C 09/08/2004 modified to specialize for CMAQ application +C by Dr. Francis S. Binkowski +C Environmental Modeling for Policy Development group, +C The Carolina Environmental Program +C The University of North Carolina-Chapel Hill +C Email: frank_binkowski@unc.edu +C +C----------------------------------------------------------------------- +C REFERENCE: +C Dahlback, A. and K. Stamnes, A new spherical model for computing +C the radiation field available for photolysis and heating at +C twilight, Planetary and Space Sciences, Vol. 39, No. 5, +C pp 671-683, 1991. +C +C----------------------------------------------------------------------- + + IMPLICIT NONE + +!***arguments + + INTEGER, INTENT( IN ) :: NLAYS + + REAL, INTENT( IN ) :: Z ( : ) + REAL, INTENT( IN ) :: ZSFC + REAL, INTENT( IN ) :: REARTH + REAL, INTENT( IN ) :: SINZEN + REAL, INTENT( OUT ) :: DZ ( : ) ! layer thicknesses counting from surface upward + REAL, INTENT( OUT ) :: DSDH( : ) + +!***Internal + + INTEGER I, J, K ! loop indices + REAL RE + REAL DSJ ! slant path length [m] + REAL DHJ ! layer thickness [m] + REAL( 8 ) :: RJ, RJP1 + REAL( 8 ) :: RPSINZ ! rpsinz = (re + zd(i)) * sinzen + REAL( 8 ) :: RPSINZ2 ! rpsinz * rpsinz + REAL( 8 ) :: GA, GB ! see usage + REAL :: ZE( NLAYS + 1 ) ! altitudes MSL + REAL :: ZD( NLAYS + 1 ) ! array of altitudes indexed from top + REAL :: DZI( NLAYS ) ! layer thicknesses counting downward from the top + +C----------------------------------------------------------------------- + +!***re include the altitude above sea level to the radius of the earth + + RE = REARTH + ZSFC + +!***ze is the altitude above msl + + DO K = 1, NLAYS + 1 + ZE( K ) = Z( K ) +!!sjr ZE(K) = Z(K) - ZSFC + END DO + +!*** DZ(1) = ZE(2) - ZE(1) +!*** DZI(1) = ZE(NLAYS + 1) - ZE(NLAYS) + +!***calculate dz + + DO K = 1, NLAYS + DZ( K ) = ZE( K + 1 ) - ZE( K ) + END DO + +!***zd, dzi are inverse coordinates of ze & dz + + DO K = 1, NLAYS + 1 + J = NLAYS + 1 - K + 1 + ZD( J ) = ZE( K ) + END DO + + DO K = 1, NLAYS + J = NLAYS + 1 - K + DZI( J ) = DZ( K ) + END DO + +!***initialize dsdh + + DO I = 1, NLAYS + DSDH( I ) = 0.0 + END DO + +!***FSB The following code is a direct implementation of appendix B +!*** of Dahlbeck and Stamnes (1991) for the case of solar zenith +!*** angle less than 90 degree. + +!***calculate ds/dh of every layer starting at the top + + DO J = 1, NLAYS +!*** K = NLAYS - J +1 + RPSINZ = REAL( ( RE + ZD( J ) ) * SINZEN , 8 ) + RPSINZ2 = RPSINZ * RPSINZ + + IF ( J .LT. NLAYS ) THEN + RJ = REAL( RE + ZD( J ), 8 ) + RJP1 = REAL( RE + ZD( J + 1 ), 8 ) + DHJ = DZI( J ) + ELSE + RJ = REAL( RE + ZD( J ), 8) + RJP1 = REAL( RE, 8 ) + DHJ = DZI( J ) + END IF + +!***define GA and GB + + GB = SQRT( MAX( 0.0D0, RJ * RJ - RPSINZ2 ) ) + GA = SQRT( MAX( 0.0D0, RJP1 * RJP1 - RPSINZ2 ) ) + +!***This is equation B1 from Dahlbeck and Stamnes (1991) + + DSJ = ABS( REAL(GB - GA, 4 ) ) + +!***this is the slant path (Chapman) function. + + DSDH( J ) = DSJ / DHJ ! Note dsdh is on a top to bottom grid. + + END DO ! loop over altitude + + RETURN + END SUBROUTINE SLANTPATH2 + +C/////////////////////////////////////////////////////////////////////// + + SUBROUTINE SLANTPATHTOP ( ZTOM, ZTOA, ZSFC, REARTH, SINZEN, + & DSDHTOP ) +C----------------------------------------------------------------------- +C FSB This is a SPECIAL version to get the slant path from the top of +C the modeling domain (ztom) to the top of the atmosphere (ztoa). +C----------------------------------------------------------------------- +C PURPOSE: +C Calculate slant path, ds/dh, over vertical depth in spherical +C geometry also calculates the layer thicknesses. +C NOTE!!! +C This version is restricted to zenith angle less than 90 degrees +C----------------------------------------------------------------------- +C ARGUMENTS: +C INPUT: +C ztom - REAL, altitude (agl) of top of modeling domain [m] << 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/phot.F b/src/model/src/phot.F new file mode 100644 index 0000000..66c9531 --- /dev/null +++ b/src/model/src/phot.F @@ -0,0 +1,1251 @@ + +!------------------------------------------------------------------------! +! 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. ! +!------------------------------------------------------------------------! + + +! RCS file, release, date & time of last delta, author, state, [and locker] +! $Header: /project/yoj/arc/CCTM/src/phot/phot_inline/phot.F,v 1.7 2011/10/21 16:11:28 yoj Exp $ + +! what(1) key, module and SID; SCCS file; date and time of last delta: +! %W% %P% %G% %U% + +!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: + SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) + +!----------------------------------------------------------------------- +! +! 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: INIT3, 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 +! +! 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 properites 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 + +!---------------------------------------------------------------------- + +C...modules + + USE RXNS_DATA ! chemistry varaibles and data + USE CGRID_SPCS ! CGRID species number and offsets + USE PCGRID_DEFN ! get cgrid + USE UTILIO_DEFN + USE AERO_DATA ! describes aerosol distribution + USE PHOT_MOD ! photolysis in-line module - inherits CSQY_DATA module + 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 STRATOS_O3_MINFRACS ! annual minimum fraction of ozone column density above Pressure TOP +! USE SEAS_STRAT_O3_FRACS ! monthly minimum fraction of ozone column density above Pressure TOP + USE SEAS_STRAT_O3_MIN ! monthly minimum fraction of ozone column density above Pressure TOP + +#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 +! INCLUDE SUBST_CONST ! physical constants--moved to PHOT_MOD. + +!...arguments + + INTEGER, INTENT( IN ) :: MDATE ! "centered" Julian date (YYYYDDD) + INTEGER, INTENT( IN ) :: MTIME ! "centered" time (HHMMSS) + INTEGER, INTENT( IN ) :: JDATE ! current Julian date (YYYYDDD) + INTEGER, INTENT( IN ) :: JTIME ! current time (HHMMSS) + INTEGER, INTENT( IN ) :: DTSTEP( : ) ! time step vector (HHMMSS) + +! REAL RJ( NCOLS,NROWS,NLAYS, NPHOTAB ) + REAL, INTENT( OUT ) :: RJ( :,:,:,: ) ! gridded J-values (1/min units) + +! REAL CGRID( NCOLS,NROWS,NLAYS, * ) ! Conc array + REAL, SAVE, POINTER :: CGRID( :,:,:,: ) ! species concentrations + +!...parameters + + 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 :: PHOTDIAG ! Flag for PHOTDIAG file + + LOGICAL, SAVE :: CALL_INIT_ALBEDO = .TRUE. + LOGICAL, SAVE :: CALL_GET_ALBEDO = .TRUE. + + LOGICAL :: ZERO_ICE + + CHARACTER( 3 ), ALLOCATABLE, SAVE :: WLTXT( : ) + CHARACTER( 16 ) :: VARNM + CHARACTER( 16 ), SAVE :: PNAME = 'PHOT' + CHARACTER( 16 ), SAVE :: CTM_PHOTDIAG = 'CTM_PHOTDIAG' + + CHARACTER( 80 ) :: VARDESC ! environment variable description + CHARACTER( 240 ) :: XMSG = ' ' + + INTEGER, SAVE :: LOGDEV + INTEGER, SAVE :: LGC_O3 ! pointer to O3 in CGRID + INTEGER, SAVE :: LGC_NO2 ! pointer to NO2 in CGRID + INTEGER, SAVE :: 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 ODATE ! output date + INTEGER OTIME ! output time + + INTEGER ALLOCSTAT + + INTEGER, SAVE :: TDATE + INTEGER, SAVE :: GXOFF, GYOFF ! global origin offset from file + INTEGER, SAVE :: PECOL_OFFSET ! Local Column Offset for processor + INTEGER, SAVE :: PEROW_OFFSET ! Local Column Offset for processor + INTEGER, SAVE :: TSTEP_COUNT ! counter between calls to write diagnostics + +! for INTERPX + INTEGER, SAVE :: STRTCOLGC2, ENDCOLGC2, STRTROWGC2, ENDROWGC2 + INTEGER, SAVE :: STRTCOLMC2, ENDCOLMC2, STRTROWMC2, ENDROWMC2 + INTEGER, SAVE :: STRTCOLMC3, ENDCOLMC3, STRTROWMC3, ENDROWMC3 + + REAL CURRHR ! current GMT hour + REAL JULIAN_DAY ! time of year [days] + REAL CURRHR_LST ! local standard time at each grid cell + 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? + +!...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 :: TROPO_O3_EXCEED( :,: ) ! Factor used to adjust tropospheric ozone optical depth + REAL, ALLOCATABLE, SAVE :: TRANSMIS_DIFFUSE( :,: ) ! diffuse transmission coefficient at surface + REAL, ALLOCATABLE, SAVE :: TRANSMIS_DIRECT( :,: ) ! direct transmission coefficient at surface + REAL, ALLOCATABLE, SAVE :: REFLECT_COEFF( :,: ) ! reflection coefficient at top of atmosphere + REAL, ALLOCATABLE, SAVE :: ETOT_SFC_WL ( :,:,: ) ! total downward irradiance at sfc [ Watts / m**2 ] + REAL, ALLOCATABLE, SAVE :: TAU_AERO_WL ( :,:,: ) ! total aerosol optical depth + REAL, ALLOCATABLE, SAVE :: TAU_CLOUD_WL( :,:,: ) ! total cloud optical depth + REAL, ALLOCATABLE, SAVE :: CLR_TRANSMISSION( :,: ) ! diffuse transmission coefficient of clouds + REAL, ALLOCATABLE, SAVE :: CLR_REFLECTION ( :,: ) ! reflection coefficient of cloud + REAL, ALLOCATABLE, SAVE :: CLR_TRANS_DIRECT( :,: ) ! direct transmission coefficient of clouds +#ifdef phot_debug + 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 :: TAU ( :,:,:,: ) ! optical depth + REAL, ALLOCATABLE, SAVE :: TAU_AERO ( :,:,:,: ) ! aerosol optical depth + REAL, ALLOCATABLE, SAVE :: ACTINIC_FX( :,:,:,: ) ! net actinic flux [watts/m**2] + + INTERFACE + SUBROUTINE O3TOTCOL ( LATITUDE, LONGITUDE, JDATE, OZONE ) + INTEGER, INTENT( IN ) :: JDATE ! Julian day of the year (yyyyddd) + 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 + END INTERFACE + +! ---------------------------------------------------------------------- + + IF ( FIRSTIME ) THEN + + FIRSTIME = .FALSE. + LOGDEV = INIT3() + + TSTEP = TIME2SEC( DTSTEP( 1 ) ) ! output timestep for phot diagnostic files + + CGRID => PCGRID( 1:MY_NCOLS,1:MY_NROWS,:,: ) + +!...Get photolysis rate diagnostic file flag + + PHOTDIAG = .FALSE. ! default + VARDESC= 'Flag for writing the photolysis rate diagnostic file' + PHOTDIAG = ENVYN( CTM_PHOTDIAG, VARDESC, PHOTDIAG, ESTAT ) + IF ( ESTAT .NE. 0 ) WRITE( LOGDEV, '(5X, A)' ) VARDESC + IF ( ESTAT .EQ. 1 ) THEN + XMSG = 'Environment variable improperly formatted' + CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT2 ) + ELSE IF ( ESTAT .EQ. -1 ) THEN + XMSG = + & 'Environment variable set, but empty ... Using default:' + WRITE( LOGDEV, '(5X, A, I9)' ) XMSG, JTIME + ELSE IF ( ESTAT .EQ. -2 ) THEN + XMSG = 'Environment variable not set ... Using default:' + WRITE( LOGDEV, '(5X, A, I9)' ) XMSG, JTIME + END IF + +!...Get met file offsets + + CALL SUBHFILE ( GRID_CRO_2D, GXOFF, GYOFF, + & STRTCOLGC2, ENDCOLGC2, STRTROWGC2, ENDROWGC2 ) + CALL SUBHFILE ( MET_CRO_2D, GXOFF, GYOFF, + & STRTCOLMC2, ENDCOLMC2, STRTROWMC2, ENDROWMC2 ) + CALL SUBHFILE ( MET_CRO_3D, GXOFF, GYOFF, + & STRTCOLMC3, ENDCOLMC3, STRTROWMC3, ENDROWMC3 ) + + PECOL_OFFSET = COLSD_PE( 1, MYPE+1 ) - 1 + PEROW_OFFSET = ROWSD_PE( 1, MYPE+1 ) - 1 + + CALL LOAD_CSQY_DATA( ) + + CALL LOAD_OPTICS_DATA( ) + +!...Allocate array needed to calculation aerosol and cloud optical properties + + CALL INIT_AERO_DATA( ) + + CALL INIT_CLOUD_OPTICS( ) + +!...Initialize Surface albedo method + + IF ( .NOT. INITIALIZE_ALBEDO( JDATE, JTIME, LOGDEV ) ) THEN + XMSG = 'Failure initializing photolysis surface albedo algorithm' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + ALLOCATE( ETOT_SFC ( NWL ) ) + + ALLOCATE( LWC ( NLAYS ) ) + ALLOCATE( RWC ( NLAYS ) ) + ALLOCATE( IWC ( NLAYS ) ) + ALLOCATE( SWC ( NLAYS ) ) + ALLOCATE( GWC ( NLAYS ) ) + ALLOCATE( BLKPRS ( NLAYS ) ) + ALLOCATE( BLKTA ( NLAYS ) ) + ALLOCATE( BLKDENS( NLAYS ) ) + ALLOCATE( BLKZH ( NLAYS ) ) + ALLOCATE( BLKO3 ( NLAYS ) ) + ALLOCATE( BLKNO2 ( NLAYS ) ) + ALLOCATE( 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 ) ) + + IF ( PHOTDIAG ) THEN + ALLOCATE( TROPO_OC ( 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( ETOT_SFC_WL ( NCOLS,NROWS,NWL ) ) + 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 + + DIAG_WVL( 1 ) = 1 + DIAG_WVL( N_DIAG_WVL ) = NWL + + ALLOCATE ( AERO_ASYM( NCOLS,NROWS,NLAYS,N_DIAG_WVL ), STAT = ALLOCSTAT ) + IF ( ALLOCSTAT .NE. 0 ) THEN + XMSG = 'Failure allocating 3D AERO_ASYM' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + ALLOCATE ( AERO_SSA( NCOLS,NROWS,NLAYS,N_DIAG_WVL ), STAT = ALLOCSTAT ) + IF ( ALLOCSTAT .NE. 0 ) THEN + XMSG = 'Failure allocating 3D AERO_SSA' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + ALLOCATE ( TAU_AERO( NCOLS,NROWS,NLAYS,N_DIAG_WVL ), STAT = ALLOCSTAT ) + IF ( ALLOCSTAT .NE. 0 ) THEN + XMSG = 'Failure allocating 3D TAU_AERO' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + ALLOCATE ( TAU( NCOLS,NROWS,NLAYS,N_DIAG_WVL ), STAT = ALLOCSTAT ) + IF ( ALLOCSTAT .NE. 0 ) THEN + XMSG = 'Failure allocating 3D TAU' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + ALLOCATE ( ACTINIC_FX( NCOLS,NROWS,NLAYS,NWL ), STAT = ALLOCSTAT ) + IF ( ALLOCSTAT .NE. 0 ) THEN + XMSG = 'Failure allocating ACTINIC_FX' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + +!...write wavelength data to a character array + + ALLOCATE ( WLTXT( NWL ) ) + + DO IWL = 1, NWL + WRITE( WLTXT( IWL ),'(I3.3)' ) INT( WAVELENGTH( IWL ) ) + END DO + +!...open the photolysis rate diagnostic files + + ODATE = JDATE; OTIME = JTIME +#ifndef phot_extra_tstep + CALL NEXTIME ( ODATE, OTIME, DTSTEP( 1 ) ) ! output timestamp ending time +#endif + IF ( IO_PE_INCLUSIVE ) CALL OPPHOT ( ODATE, OTIME, DTSTEP( 1 ) ) + + CALL SUBST_BARRIER + + END IF ! photdiag + +!...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 + +#ifdef phot_extra_tstep + ELSE + IF ( PHOTDIAG ) THEN + ODATE = JDATE; OTIME = JTIME + CALL NEXTIME ( ODATE, OTIME, DTSTEP( 2 ) ) ! sync time step + END IF +#endif + END IF ! firstime + + IF ( JD_STRAT_O3MIN .NE. JDATE ) THEN +!...set minimum fraction of ozone column above PTOP + + CALL SEASONAL_STRAT_O3( JDATE, JTIME ) + MIN_STRATO3_FRAC = MONTH_STRAT_03_FRAC + MAX_TROPOO3_FRAC = MAX( 1.0 - MONTH_STRAT_03_FRAC, 0.0 ) + WRITE( LOGDEV,*)'PHOT: MIN_STRATO3_FRAC = ',MIN_STRATO3_FRAC + + JD_STRAT_O3MIN = REAL( JDATE, 4) + END IF +!...initialize variables tracking whether stratosphere ozone column satisfies +!...climatological averages. + + O3_TOGGLE_AVE = 0.0 + O3_TOGGLE_MIN = 1.0 + N_TROPO_O3_TOGGLE = 0 + TSTEP_COUNT = TSTEP_COUNT + 1 + + CALL GET_PHOT_MET( JDATE, JTIME, MDATE, MTIME ) + +!...Get cosine of solar parameters and set DARK + + CALL UPDATE_SUN( JDATE, JTIME, MDATE, MTIME ) + + 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( MDATE, MTIME, LOGDEV, COSINE_ZENITH, LAT, LON ) + +!...SA Write COSINE_ZENITH array at the end of each output tstep + + IF ( PHOTDIAG ) THEN +#ifndef phot_extra_tstep + ODATE = JDATE; OTIME = JTIME + CALL NEXTIME ( ODATE, OTIME, DTSTEP( 2 ) ) ! sync time step +#endif + JTIME_CHK = ( MOD( TIME2SEC( OTIME ), TSTEP ) .EQ. 0 ) +#ifdef parallel_io + IF ( .NOT. IO_PE_INCLUSIVE ) THEN + IF ( .NOT. OPEN3( CTM_RJ_1, FSREAD3, PNAME ) ) THEN + 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 + END IF +#endif + ELSE + JTIME_CHK = .FALSE. + END IF + + +!...If sun below horizon at all cells, zero photolysis rates & exit +!... (assumes sun below horizon at *all* levels!) + + IF ( DARK ) THEN + + RJ = 0.0 + +!...write to the log file, CTM_RJ_1 file and return + + WRITE( LOGDEV, 1003 ) MYPE, JDATE, JTIME + +!...Initialize ETOT_SFC, TAU_AERO, TAU_TOT, TAUO3_TOP to 0.0 + +!...Write data to output diagnostic file + + TOTAL_OC = 0.0 + + IF ( JTIME_CHK ) THEN + + TROPO_OC = 0.0 + ETOT_SFC_WL = 0.0 + TAUO3_TOP_WL = 0.0 + TAU_AERO_WL = 0.0 + TAU_CLOUD_WL = 0.0 +#ifdef phot_debug + SSA_CLOUD_WL = 0.0 + ASY_CLOUD_WL = 0.0 +#endif + TAU_TOT_WL = 0.0 + TAU = 0.0 + TAU_AERO = 0.0 + AERO_SSA = 0.0 + AERO_ASYM = 0.0 + ACTINIC_FX = 0.0 + +! TROPO_O3_EXCEED = 0.0 + TRANSMIS_DIFFUSE = 0.0 + TRANSMIS_DIRECT = 0.0 + REFLECT_COEFF = 0.0 + CLR_TRANSMISSION = 0.0 + CLR_TRANS_DIRECT = 0.0 + CLR_REFLECTION = 0.0 + + END IF ! if JTIME_CHK + + ELSE ! all cells not dark + +!...MAIN loop over all rows and columns + LOOP_ROWS: DO ROW = 1, MY_NROWS + LOOP_COLS: DO COL = 1, MY_NCOLS + + PHOT_COL = COL + PECOL_OFFSET + PHOT_ROW = ROW + PEROW_OFFSET + + COSZEN = COSINE_ZENITH( COL,ROW ) ! local cosine of solar zenith angle + + IF ( COSZEN .LE. 0.0 ) THEN +!...the cell is dark: set variables to zero and cycle + RJ( COL,ROW, :,: ) = 0.0 + + IF ( JTIME_CHK ) THEN + TOTAL_OC( COL,ROW ) = 0.0 + TROPO_OC( COL,ROW ) = 0.0 + ETOT_SFC_WL ( COL,ROW, : ) = 0.0 + 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 + TAU ( COL,ROW, :,: ) = 0.0 + TAU_AERO ( COL,ROW, :,: ) = 0.0 + AERO_SSA ( COL,ROW, :,: ) = 0.0 + AERO_ASYM ( COL,ROW, :,: ) = 0.0 + ACTINIC_FX( COL,ROW, :,: ) = 0.0 + +! TROPO_O3_EXCEED( COL,ROW ) = 0.0 + TRANSMIS_DIFFUSE( COL,ROW ) = 0.0 + TRANSMIS_DIRECT ( COL,ROW ) = 0.0 + REFLECT_COEFF ( COL,ROW ) = 0.0 + CLR_TRANSMISSION( COL,ROW ) = 0.0 + CLR_TRANS_DIRECT( COL,ROW ) = 0.0 + CLR_REFLECTION ( COL,ROW ) = 0.0 + END IF + + 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 + +!...local latitude and longitude + +! LATCR = LAT( COL,ROW ) +! LONCR = LON( COL,ROW ) + +!...get total ozone column based on OMI observations + CALL O3TOTCOL ( LAT( COL,ROW ), LON( COL,ROW ), JDATE, TOTAL_O3_COLUMN ) + + 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, CGRID ) +! ELSE +! CALL AERO_OPTICS_INTERNAL( COL,ROW, NLAYS, CGRID ) +! END IF + +! set surface albedo + + FORALL ( IWL = 1:NWL ) + ALB( IWL ) = SURFACE_ALBEDO( IWL, COL,ROW ) + END FORALL +!set min/max fractions of ozone column in stratosphere and troposphere +! MIN_STRATO3_FRAC = MIN_STRAT_03_FRAC( COL, ROW ) +! MAX_TROPOO3_FRAC = MAX( 1.0 - MIN_STRAT_03_FRAC( COL, ROW ), 0.0 ) +! MIN_STRATO3_FRAC = MONTH_STRAT_03_FRAC( COL, ROW ) +! MAX_TROPOO3_FRAC = MAX( 1.0 - MONTH_STRAT_03_FRAC( COL, ROW ), 0.0 ) +!...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 + IF ( PHOTDIAG .AND. .NOT. STRATO3_MINS_MET ) THEN + N_EXCEED_TROPO3( COL,ROW ) = N_EXCEED_TROPO3( COL,ROW ) + 1.0 + TROPO_O3_EXCEED( COL,ROW ) = TROPO_O3_COLUMN/(MAX_TROPOO3_FRAC*TOTAL_O3_COLUMN) - 1.0 +! & + 1.0 / TROPO_O3_TOGGLE - 1.0 + & + TROPO_O3_EXCEED( COL,ROW ) +! ELSE IF( PHOTDIAG ) THEN +! TROPO_O3_EXCEED( COL,ROW ) = 0.0 + END IF + + IF ( JTIME_CHK ) THEN + TOTAL_OC( COL,ROW ) = REAL( TOTAL_O3_COLUMN ) + TROPO_OC( COL,ROW ) = REAL( TROPO_O3_COLUMN ) + TRANSMIS_DIFFUSE( COL,ROW ) = TRANSMISSION + TRANSMIS_DIRECT( COL,ROW ) = TRANS_DIRECT + REFLECT_COEFF( COL,ROW ) = REFLECTION + + + FORALL( IWL = 1:NWL ) + ETOT_SFC_WL ( COL,ROW,IWL ) = IRRADIANCE( 1,IWL ) + TAUO3_TOP_WL( COL,ROW,IWL ) = TAUO3_TOP( IWL ) + TAU_AERO_WL ( COL,ROW,IWL ) = TAUC_AERO( 1,IWL ) + TAU_TOT_WL ( COL,ROW,IWL ) = TAU_TOT ( 1,IWL ) + TAU_CLOUD_WL( COL,ROW,IWL ) = TAU_CLOUD( 1,IWL ) +#ifdef phot_debug + SSA_CLOUD_WL( COL,ROW,IWL ) = AVE_SSA_CLD ( IWL ) + ASY_CLOUD_WL( COL,ROW,IWL ) = AVE_ASYMM_CLD( IWL ) +#endif + END FORALL + FORALL ( LEV = 1:NLAYS, IWL = 1:NWL ) + ACTINIC_FX( COL,ROW,LEV,IWL ) = ACTINIC_FLUX( LEV,IWL ) + END FORALL + + DO L = 1, N_DIAG_WVL + IWL = DIAG_WVL( L ) + FORALL ( LEV = 1:NLAYS ) + TAU ( COL,ROW,LEV,L ) = TAU_TOT ( LEV,IWL ) + TAU_AERO( COL,ROW,LEV,L ) = TAUC_AERO( LEV,IWL ) + END FORALL + FORALL ( LEV = 1:NLAYS, AERO_EXTI_COEF( LEV,IWL ) .GT. EPSLON ) + AERO_SSA ( COL,ROW,LEV,L ) = AERO_SCAT_COEF( LEV,IWL ) + & / AERO_EXTI_COEF( LEV,IWL ) + AERO_ASYM( COL,ROW,LEV,L ) = AERO_ASYM_FAC( LEV,IWL ) + END FORALL + FORALL ( LEV = 1:NLAYS, AERO_EXTI_COEF( LEV,IWL ) .LE. EPSLON ) + AERO_SSA ( COL,ROW,LEV,L ) = 1.0 + AERO_ASYM( COL,ROW,LEV,L ) = 0.0 + END FORALL + END DO + 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 + + 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 +! write(logdev,*)'ACM cloud present fraction, cloud lwc(lev),iwc(lev),rwc(1),gwc(1) = ', +! & ACM_CLOUDS( COL,ROW ),lwc(lev),iwc(lev),rwc(1),gwc(1) + +! get optical properties of of subgrid cloud hydrometeors + CALL GET_DROPLET_OPTICS( LEV, BLKTA, OWATER_FRAC, SEAICE_FRAC, SNOW_FRAC, LWC ) + CALL GET_ICE_OPTICS( LEV, BLKTA, IWC ) + CALL GET_AGGREGATE_OPTICS( LEV, RWC, SWC, GWC ) + +!...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 ) + + IF ( JTIME_CHK ) 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 + FORALL ( IWL = 1:NWL ) + ETOT_SFC_WL ( COL,ROW,IWL ) = MSCALE * ETOT_SFC_WL( COL,ROW,IWL ) + & + ACM_CLOUDS( COL,ROW ) * IRRADIANCE( 1,IWL ) + 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 FORALL ! iwl + FORALL ( LEV = 1:NLAYS, IWL = 1:NWL ) + ACTINIC_FX( COL,ROW,LEV,IWL ) = MSCALE * ACTINIC_FX( COL,ROW,LEV,IWL ) + & + ACM_CLOUDS( COL,ROW ) * ACTINIC_FLUX( LEV,IWL ) + END FORALL ! lev and iwl + + DO L = 1, N_DIAG_WVL + IWL = DIAG_WVL( L ) + FORALL ( LEV = 1:NLAYS) + TAU( COL,ROW,LEV,L ) = MSCALE * TAU( COL,ROW,LEV,L ) + & + ACM_CLOUDS( COL,ROW ) * TAU_TOT( LEV,IWL ) + END FORALL + END DO + END IF ! photdiag +!Photolysis rates become a weighted average of the values from resolved and ACM skies + FORALL ( L = 1:NLAYS, IPHOT = 1:NPHOTAB ) + RJ( COL,ROW, L, IPHOT ) = 60.0 * ACM_CLOUDS( COL,ROW ) * BLKRJ_ACM( L,IPHOT ) + & + MSCALE * RJ( COL,ROW,L,IPHOT ) + END FORALL ! Loop on layers and PHOT + END IF + END IF ! not USE_ACM_CLOUD and ACM_CLOUDS > 0 + + IF ( JTIME_CHK ) 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 + +!...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 + + 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 = '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 + + IMONTH = IMONTH + 1 + IF( IMONTH .GT. 12 )THEN + IMONTH = 1 + TDATE = 2011001 + END IF + TDATE = TDATE + DAYS( IMONTH ) +! CALL SEASONAL_STRAT_O3(TDATE, JTIME ) + + +! VARNM = 'MIN_FRAC_STRATO3' +! IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, MONTH_STRAT_03_FRAC ) ) THEN +! XMSG = 'Error writing variable ' // VARNM +! CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) +! END IF + + + VARNM = '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 = 'TAU_AERO_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 + + WRITE( LOGDEV, '( /5X, 3( A, :, 1X ), I8, ":", I6.6 )' ) + & 'RJ Values written to', CTM_RJ_1, + & 'for date and time', ODATE, OTIME + + DO IPHOT = 1, NPHOTAB + IF ( .NOT. WRITE3( CTM_RJ_2, PHOTAB( IPHOT ), ODATE, + & OTIME, RJ( :,:,:,IPHOT ) ) ) THEN + XMSG = 'Could not write ' // CTM_RJ_2 // ' file' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + END DO + + VARNM = 'CFRAC_3D' + IF ( .NOT. WRITE3( CTM_RJ_2, VARNM, ODATE, OTIME, CFRAC_3D ) ) THEN + XMSG = 'Could not write ' // TRIM( VARNM ) // ' to ' // CTM_RJ_2 // ' file' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + DO IWL = 1, NWL + VARNM = 'ACTINIC_FX_W' // WLTXT( IWL ) + IF ( .NOT. WRITE3( CTM_RJ_2, VARNM, ODATE, OTIME, ACTINIC_FX( :,:,:,IWL ) ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + END DO + + DO L = 1, N_DIAG_WVL + IWL = DIAG_WVL( L ) + + VARNM = 'AERO_SSA_W' // WLTXT( IWL ) + IF ( .NOT. WRITE3( CTM_RJ_2, VARNM, ODATE, OTIME, AERO_SSA( :,:,:,L ) ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + VARNM = 'AERO_ASYM_W' // WLTXT( IWL ) + IF ( .NOT. WRITE3( CTM_RJ_2, VARNM, ODATE, OTIME, AERO_ASYM( :,:,:,L ) ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + VARNM = 'TAU_AERO_W' // WLTXT( IWL ) + IF ( .NOT. WRITE3( CTM_RJ_2, VARNM, ODATE, OTIME, TAU_AERO( :,:,:,L ) ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + VARNM = 'TAU_W' // WLTXT( IWL ) + IF ( .NOT. WRITE3( CTM_RJ_2, VARNM, ODATE, OTIME, TAU( :,:,:,L ) ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + END DO + + WRITE( LOGDEV, '( /5X, 3( A, :, 1X ), I8, ":", I6.6 )' ) + & 'RJ and Optical Data written to', CTM_RJ_2, + & 'for date and time', ODATE, OTIME + + END IF ! if JTIME_CHK + +1003 FORMAT( 8X, 'Processor ',I4.4,' is in darkness at ', I8.7, ':', I6.6, + & 1X, 'GMT - no photolysis') +9500 FORMAT(3(/ A), I7, 1X, I6.6, 1X, / "Total Number: ", I9, ";Mean Value: ", F9.6, + & "; Max Value: ",F9.6 /) + + RETURN + END SUBROUTINE PHOT From 539e975a43f43c4bc9cb7c1103d16beb32f5dc12 Mon Sep 17 00:00:00 2001 From: "Patrick.C.Campbell@noaa.gov" Date: Fri, 11 Feb 2022 21:35:32 +0000 Subject: [PATCH 03/90] Initial modifications to canopy photolysis CMAQ5.2.1 codes. --- src/model/src/ASX_DATA_MOD.F | 100 ++ src/model/src/PHOT_MOD.F | 1898 ---------------------------------- src/model/src/phot.F | 155 ++- 3 files changed, 254 insertions(+), 1899 deletions(-) delete mode 100644 src/model/src/PHOT_MOD.F diff --git a/src/model/src/ASX_DATA_MOD.F b/src/model/src/ASX_DATA_MOD.F index 8cad21f..197be5f 100755 --- a/src/model/src/ASX_DATA_MOD.F +++ b/src/model/src/ASX_DATA_MOD.F @@ -120,6 +120,18 @@ Module ASX_DATA_MOD 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) +!> 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 + + !> U and V wind components on the cross grid points Real, Allocatable :: UWIND ( :,:,: ) ! [m/s] Real, Allocatable :: VWIND ( :,:,: ) ! [m/s] @@ -551,6 +563,21 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) Grid_Data%WRES = 0.0 Grid_Data%BSLP = 0.0 + 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 Canopy Shade variables' + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + ALLOCATE( Mosaic_Data%USTAR ( NCOLS,NROWS,n_lufrac ), & Mosaic_Data%LAI ( NCOLS,NROWS,n_lufrac ), & Mosaic_Data%DELTA ( NCOLS,NROWS,n_lufrac ), @@ -1026,6 +1053,79 @@ Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) End If +C Canopy vars + VNAME = 'FCH' + If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, + & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2,1,1, + & JDATE, JTIME, Met_Data%FCH ) ) Then + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + + VNAME = 'FRT' + If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, + & STRTCOLMC2,ENDCOLMC2,STRTROWMC2,ENDROWMC2,1,1, + & JDATE, JTIME, Met_Data%FRT ) ) Then + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + + VNAME = 'CLU' + If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, + & STRTCOLMC2,ENDCOLMC2,STRTROWMC2,ENDROWMC2,1,1, + & JDATE, JTIME, Met_Data%CLU ) ) Then + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + + VNAME = 'POPU' + If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, + & STRTCOLMC2,ENDCOLMC2,STRTROWMC2,ENDROWMC2,1,1, + & JDATE, JTIME, Met_Data%POPU ) ) Then + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + + VNAME = 'LAIE' + If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, + & STRTCOLMC2,ENDCOLMC2,STRTROWMC2,ENDROWMC2,1,1, + & JDATE, JTIME, Met_Data%LAIE ) ) Then + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + + VNAME = 'C1R' + If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, + & STRTCOLMC2,ENDCOLMC2,STRTROWMC2,ENDROWMC2,1,1, + & JDATE, JTIME, Met_Data%C1R ) ) Then + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + + VNAME = 'C2R' + If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, + & STRTCOLMC2,ENDCOLMC2,STRTROWMC2,ENDROWMC2,1,1, + & JDATE, JTIME, Met_Data%C2R ) ) Then + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + + VNAME = 'C3R' + If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, + & STRTCOLMC2,ENDCOLMC2,STRTROWMC2,ENDROWMC2,1,1, + & JDATE, JTIME, Met_Data%C3R ) ) Then + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + + VNAME = 'C4R' + If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, + & STRTCOLMC2,ENDCOLMC2,STRTROWMC2,ENDROWMC2,1,1, + & JDATE, JTIME, Met_Data%C4R ) ) Then + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + C Soil vars VNAME = 'SOIM1' If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, diff --git a/src/model/src/PHOT_MOD.F b/src/model/src/PHOT_MOD.F deleted file mode 100644 index 7d93dec..0000000 --- a/src/model/src/PHOT_MOD.F +++ /dev/null @@ -1,1898 +0,0 @@ - -!------------------------------------------------------------------------! -! The Community Multiscale Air Quality (CMAQ) system software is in ! -! continuous development by various groups and is based on information ! -! from these groups: Federal Government employees, contractors working ! -! within a United States Government contract, and non-Federal sources ! -! including research institutions. These groups give the Government ! -! permission to use, prepare derivative works of, and distribute copies ! -! of their work in the CMAQ system to the public and to permit others ! -! to do so. The United States Environmental Protection Agency ! -! therefore grants similar permission to use the CMAQ system software, ! -! but users are requested to provide copies of derivative works or ! -! products designed to operate in the CMAQ system to the United States ! -! Government without restrictions as to use by others. Software ! -! that is used with the CMAQ system but distributed under the GNU ! -! General Public License or the GNU Lesser General Public License is ! -! subject to their copyright restrictions. ! -!------------------------------------------------------------------------! - -C $Header$ - -C::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - MODULE PHOT_MOD - -C----------------------------------------------------------------------- -C -C FSB This version has NO internal write statements -C FSB This version has the code for XR96 added. -C FSB change indices from L to II in newOptics loop 08/17/2006 -C FSB This version has all write statements commented out.(08/03/2006) -C -C FSB NOTE - this code assumes that the top of the modeling domain -C is about 100 [mb] or 10 [kPa] ~ 16 [km] in altitude. If a -C higher altitude top is used , the method of calculating the -C ozone column and the ozone optical depth will be necessary. -C -C FSB This version has the addition of Rayleigh optical depth for the -C stratosphere as well as the calculation of single scattering -C albedo for the AOD calculation. (01/17/2006) -C FSB This version has deleted the JPROC values of Cs and Qy as well as -C the default aerosol. It also contains the fast optics -C routines. -C FSB This module supports the SAPRC99 Chemical mechanism within -C CMAQ. -C FSB This version calls a fast optical routine for aerosol -C extinction and scattering -C FSB This version uses a set of constant refractive indices -C The new subroutine GETNEWPAR now sets up the refractive indices. -C -C Bill Hutzell(Mar 2011) moved determining refractive indices to a -C separate file and new subroutine called AERO_PHOTDATA. -C -C Bill Hutzell(Jun 2011) modified TWOSTREAM_S subroutine to account for -C GAM2 equal to zero in the Toon et al. (1989) solution to the two stream -C of the radiative transfer equation based on how the NCAR TUV model -C implements the approximation -C -C Bill Hutzell(May 2013) modified optical depth agruments to give vetical -C profile rather than surface values. Note that TAU_TOT now includes -C stratospheric values. -! Bill Hutzell(Mar 2014) modified calculation of aerosol and cloud optical -! properites as well as their calculated optical depths. The changes employ -! FORTRAN modules that contain the layer level of the optical properties. -C 07 Jul 14 B.Hutzell: replaced mechanism include file(s) with fortran module -C 10/10/14 - DJL added references to IUPAC10 to NO2 and O3 photo rates -C 23Jun15 B.Hutzell: made TWOSTREAM and TRIDIAGONAL routine use REAL(8) variables -C 30Jul15 J.Young: REAL(4) -> REAL for code portability -C----------------------------------------------------------------------- - - USE CSQY_DATA - - IMPLICIT NONE - -!***include files - - INCLUDE SUBST_CONST ! physical constants - -!***parameters - - REAL, PARAMETER :: SMALL = 1.0E-36 ! a small number - -!***Fundamental Constants: ( Source: CRC76, pp 1-1 to 1-6) - - REAL, PARAMETER :: PLANCK_C = 6.62606876E-34 ! Planck's Constant [Js] - REAL, PARAMETER :: LIGHT_SPEED = 299792458.0 ! speed of light in a vacuum - - REAL, PARAMETER :: DU_TO_CONC = 2.6879E16 ! factor from [DU] to [molecules/cm^2] - REAL, PARAMETER :: CONC_TO_DU = 1.0 / DU_TO_CONC - - LOGICAL, PARAMETER :: ADJUST_OZONE = .FALSE. ! Flag to correct tropospheric ozone optical depth based - ! on climatology - - REAL :: MIN_STRATO3_FRAC ! minimum fraction of O3 column in statosphere - REAL :: MAX_TROPOO3_FRAC ! maximum fraction of O3 column in troposphere - -! REAL, PARAMETER :: MIN_STRATO3_FRAC = 0.55 ! minimum fraction of O3 column in statosphere - ! if PTOP = 50 mb -! REAL, PARAMETER :: MAX_TROPOO3_FRAC = 1.0 - MIN_STRATO3_FRAC ! maximum fraction of O3 column in troposphere - -!***LOGDEV for NEW_OPTICS and supporting routines - - INTEGER, SAVE :: NEW_OPTICS_LOG - - INTEGER, PARAMETER :: N_DIAG_WVL = 2 ! number of dianostic wavelengths - INTEGER, SAVE :: DIAG_WVL( N_DIAG_WVL ) ! pointers to diagnostic wavelengths - INTEGER :: N_TROPO_O3_TOGGLE ! number of adjustments to ozone extinction - - REAL, ALLOCATABLE :: ACTINIC_FLUX( :,: ) ! actinic fluxes, initially [Photons/(cm^2s)] then [Watts/m^2] - REAL, ALLOCATABLE :: IRRADIANCE ( :,: ) ! total downward irradiance [Watts/m^2] - REAL :: REFLECTION ! broad band reflection coefficient (diffuse) at model top - REAL :: TRANSMISSION ! broad band transmission coefficient (diffuse) at surface - REAL :: TRANS_DIRECT ! broad band direct transmission coefficient at surface - REAL :: TROPO_O3_COLUMN ! ozone column density in the troposphere [Dobson Units] - REAL :: TROPO_O3_TOGGLE ! factor correcting tropospheric ozone column - REAL :: O3_TOGGLE_AVE ! average of nonunity factors adjusting ozone extinction - REAL :: O3_TOGGLE_MIN ! Max of nonunity factors adjusting ozone extinction - - LOGICAL :: ONLY_SOLVE_RAD ! only compute fluxes - LOGICAL :: OBEY_STRATO3_MINS = .TRUE. ! Has stratospheric O3 column not violated - ! climatological minimums, yet? - LOGICAL :: STRATO3_MINS_MET ! Does the call to NEW_OPTICS meet the stratospheric O3 column - ! climatological minimums? - - - CHARACTER( 133 ) :: PHOT_MOD_MSG - - INTEGER :: PHOT_COL ! cell column of routine calling module routine - INTEGER :: PHOT_ROW ! cell row of routine calling module routine - - - CONTAINS - -C/////////////////////////////////////////////////////////////////////// - SUBROUTINE NEW_OPTICS ( JDATE, JTIME, NLAYS, - & BLKTA, BLKPRS, BLKDENS, BLKZH, BLKZF, - & BLKO3, BLKNO2, - & ZSFC, COSZEN, SINZEN, RSQD, - & NEW_PROFILE, CLOUDS, CLDFRC, - & BLKRJ, TAUC_AERO, TAU_TOT, TAUO3_TOP, - & TAU_RAY, SSA_AERO, TAU_CLOUD, TOTAL_O3_COLUMN ) -C----------------------------------------------------------------------- -C -C FSB NOTE new call vector <<<<<<<<<<<<< ********** -C -C FSB This version has clouds -C FSB calculates the photolysis rates as a function of species and height -C -C first coded 10/19/2004 by Dr. Francis S. Binkowski -C Carolina Environmental Program -C University of North Carolina at Chapel Hill -C email: frank_binkowski@unc.edu -C modified by FSB July 29, 2005, 01/19/2006 by FSB -C -C Mar 2011 Bill Hutzell -C -revised arguement to account for aerosol redesign in -C CMAQ version 5.0 -C -change array declaration to allow flexible number of -C wavelength bins -C Apr 2012 Bill Hutzell -C -revised error checking to needed photolysis data -C -modified case statement for RACM2 photolysis rates -C -moved aerosol optics to its own module -C 07 Jul 14 B.Hutzell: replaced mechanism include file(s) with fortran module -C----------------------------------------------------------------------- - - USE UTILIO_DEFN - USE RXNS_DATA ! chemical mechanism data - USE CLOUD_OPTICS ! data and routines for optics of cloud hydrometeors - - USE AERO_PHOTDATA - - IMPLICIT NONE - -!***arguments - INTEGER, INTENT(IN) :: JDATE ! julian date YYYYDDD - INTEGER, INTENT(IN) :: JTIME ! TIME HHMMSS - INTEGER, INTENT(IN) :: NLAYS ! # of vertical layers - - REAL, INTENT(IN) :: BLKPRS ( : ) ! Air pressure in [ atm ] - REAL, INTENT(IN) :: BLKTA ( : ) ! Air temperature [ K ] - REAL, INTENT(IN) :: BLKDENS( : ) ! Air density [ molecules / cm**3 ] - REAL, INTENT(IN) :: BLKZH ( : ) ! layer half-height [ m ] - REAL, INTENT(IN) :: BLKZF ( : ) ! layer full height[ m ] - REAL, INTENT(IN) :: BLKO3 ( : ) ! O3 concentration [ molecules / cm**3 ] - REAL, INTENT(IN) :: BLKNO2 ( : ) ! NO2 concentration [ molecules / cm**3 ] - REAL, INTENT(IN) :: ZSFC ! surface height (msl) [ m ] - REAL, INTENT(IN) :: COSZEN, SINZEN ! sine and cosine of the zenith angle - REAL, INTENT(IN) :: RSQD ! square of solar distance [ au**2 ] - - LOGICAL, INTENT(IN) :: NEW_PROFILE ! Has the atmospheric profile changed since last call? - LOGICAL, INTENT(IN) :: CLOUDS( : ) ! Does layer have clouds - REAL, INTENT(IN) :: CLDFRC( : ) ! fraction of gridcell covered by cloud - - - REAL, INTENT(OUT) :: BLKRJ( :,: ) ! photolysis rates [ 1 / sec ] - - REAL, INTENT(OUT) :: TAUC_AERO( :,: ) ! aerosol optical depth, bottom of layer - REAL, INTENT(OUT) :: TAU_TOT ( :,: ) ! total optical depth, bottom of layer - REAL, INTENT(OUT) :: TAU_CLOUD( :,: ) ! cloud optical depth, bottom of layer - - REAL, INTENT(INOUT) :: TAUO3_TOP( : ) ! optical depth of ozone above model domain - REAL, INTENT(INOUT) :: TAU_RAY ( : ) ! Rayleigh optical depth above model domain - REAL, INTENT(OUT) :: SSA_AERO ( : ) ! single scatering albedo for aerosol column - - REAL, INTENT(INOUT) :: TOTAL_O3_COLUMN ! total ozone colum density [ DU ] - -!***internal - REAL, PARAMETER :: ONE_OVER_PI = 1.0 / PI - REAL, PARAMETER :: STRAT_TEMP = 225.0 ! stratospheric temperature - REAL, PARAMETER :: ZTOA = 50.0E3 ! top of the atmosphere [ m ] - - INTEGER L, I, IWL, II, ILEV, IPHOT, MODE ! loop indices - - INTEGER NLEVEL - REAL SOLAR_FLUX ! solar flux at atmosphere top in a wavelength band, [photons/(cm^2*s)] - REAL INSOLATION ! downward solar flux at atmosphere top summed over wavelength bands, [photons/(cm^2*s)] - - REAL DELTA_O3_COLUMN ! change in ozone column density [molecules/cm2] - REAL STRAT_O3_COLUMN ! ozone column density in the stratosphere [molecules/cm2] - REAL STRAT_O3_COLMIN ! ozone minium column density in the stratosphere [molecules/cm2] - REAL TAU_O3 ! optical depth of stratospheric ozone [ m ] - REAL DENSTOM ! estimated air density at top of model [ molecules / cm**3 ] - REAL LAMDA ! wavelength [ nm ] - REAL INV_LAMBDA ! reciprocal of wavelength [ 1/nm ] - REAL LAMDA_UM ! wavelength [ um ] - -!***working absorption cross sections [ cm**2 ]. These have been corrected -!*** for ambient ( pressure and temperature ) conditions. - - REAL AO3 - REAL ANO2 - REAL BETA_M ! molecular scattering coefficient [ 1/m ] - REAL BEXT ! total aerosol extinction coefficient [ 1/m ] - REAL VFAC, BSC ! unit correction factors - REAL BSCAT ! total aerosol scattering coefficient [ 1/m ] - REAL G_BAR ! total aerosol asymmetry factor - -!***FSB The following variable is aq switch that allows a fast version of -!*** aerosol optics to be used when set to .TRUE. - -!***scattering and absorption for the layer - - REAL DTABS_A, DTABS_M, DTSCAT_A, DTSCAT_M, DTSCAT, DTABS - -!***variables describing the layer heights and slants -! REAL DJ, DF - REAL ZTOM ! top of model [ m ] - REAL, ALLOCATABLE, SAVE :: DSDH_TD( : ) ! slant path function from top down - REAL, ALLOCATABLE, SAVE :: BLKDZ( : ) ! layer thicknesses [ m ] - REAL, ALLOCATABLE, SAVE :: DSDH( : ) ! slant path function - REAL, SAVE :: DSDH_TOP ! slantpath function from ZTOM to ZTOA - -!***Increment of optical depth - - REAL, ALLOCATABLE, SAVE :: DTAU ( : ) ! total depth at level - REAL, ALLOCATABLE, SAVE :: DT_AERO ( : ) ! aerosol contribution at level - REAL, ALLOCATABLE, SAVE :: DT_CLOUD( : ) ! cloud contribution at level - -!***single scattering albedo for layer - - REAL, ALLOCATABLE, SAVE :: OM( : ) - -!***asymmetry factor - - REAL, ALLOCATABLE, SAVE :: G( : ) - -!***arrays for fluxes and irradiances used in - -!***delta-Eddington code - - REAL, ALLOCATABLE, SAVE :: FDIR( : ) ! direct actinic flux - REAL, ALLOCATABLE, SAVE :: FUP ( : ) ! diffuse upward actinic flux - REAL, ALLOCATABLE, SAVE :: FDN ( : ) ! diffuse downward flux - REAL, ALLOCATABLE, SAVE :: EDIR( : ) ! direct irradiance - REAL, ALLOCATABLE, SAVE :: EUP ( : ) ! diffuse upward irradiance - REAL, ALLOCATABLE, SAVE :: EDN ( : ) ! diffuse downward irradiance - -!***surface albedo - - REAL RSFC - - REAL FX - REAL, ALLOCATABLE, SAVE :: ESUM( : ) ! total downward irradiance - REAL, ALLOCATABLE, SAVE :: FSUM( : ) ! total actinic flux - -!***needed for stratospheric Raleigh optical depth - REAL, PARAMETER :: R_G = 100.0 * RDGAS / GRAV ! dry air gas constant - ! divided by gravitational - ! acceleration [cm/K] NOTE: cgs units - - REAL HSCALE ! Scale height [cm] ! NOTE: cgs units - - REAL NBAR ! total number of air molecules [ # /cm**2 ] - ! above top of model domain - - REAL, SAVE :: COS85 - -!***FSB Cloud properties. -!*** FSB These properties are taken fro HU & Stamnes,1993, -!*** An accurate parameterizationof the radiative properties of -!*** water clouds suitable for use in climate models, Journal of -!*** Climate, vol. 6, pp. 728-742. The values in the data statements -!*** were calculated with an equivalent radius of 10 micrometers. -!*** Note: Hu &Stamnes give beta in [ 1 / km/ for LWC in [ g / m**3 ] -!*** the values for beta/ LWC also give beta in [1/m] with LWC in [g/m **3] - - REAL G_CLOUD ! local cloud asymmetry factor - REAL OM_CLOUD ! local cloud single scattering albedo - REAL DTSCAT_CLOUD ! level increment in cloud scattering optical - REAL TAU_SCAT_CLD ! total scattering optical depth of cloud - REAL LAYERING_FACTOR ! correction factor for cloud layering - REAL STOZONE - - LOGICAL, SAVE :: FIRST = .TRUE. ! Flag for first call - LOGICAL :: SUCCESS - -!***arrays for fluxes and irradiances used in - REAL, ALLOCATABLE, SAVE :: SRAYL( : ) ! Molecular scattering cross sections [ cm ** 2] - REAL, ALLOCATABLE, SAVE :: TAU_SCAT( : ) ! aerosol scattering optical depth - REAL, ALLOCATABLE, SAVE :: CONV_WM2( : ) ! conversion factor [photons/(cm**2 s )] to [Watts/m**2] - -!***three-dimensional array for Cs and Qy -!*** (temperature, wavelength, species) -!***(layer, wavelength species) - - REAL, ALLOCATABLE, SAVE :: CSZ( :,:,: ) - REAL, ALLOCATABLE, SAVE :: QYZ( :,:,: ) - - IF ( FIRST ) THEN - - NEW_OPTICS_LOG = INIT3() - - ALLOCATE( CONV_WM2( NWL ) ) - ALLOCATE( SRAYL ( NWL ) ) - ALLOCATE( TAU_SCAT( NWL ) ) - ALLOCATE( CSZ( NLAYS,NWL,NPHOTAB ) ) - ALLOCATE( QYZ( NLAYS,NWL,NPHOTAB ) ) - - ALLOCATE( ACTINIC_FLUX( NLAYS,NWL ) ) - ALLOCATE( IRRADIANCE ( NLAYS,NWL ) ) - - ALLOCATE( DSDH_TD ( NLAYS+1 ), - & BLKDZ ( NLAYS ), - & DSDH ( NLAYS ), - & DTAU ( NLAYS+1 ), - & DT_AERO ( NLAYS+1 ), - & DT_CLOUD( NLAYS+1 ), - & OM ( NLAYS+1 ), - & G ( NLAYS+1 ), - & FDIR ( NLAYS+1 ), - & FUP ( NLAYS+1 ), - & FDN ( NLAYS+1 ), - & EDIR ( NLAYS+1 ), - & EUP ( NLAYS+1 ), - & EDN ( NLAYS+1 ), - & ESUM ( NLAYS ), - & FSUM ( NLAYS ) ) - -!***FSB Set up conversion factor for -!*** [photons / ( cm**2 s) ] to [Watts / m**2 ] -!*** THE 1.0E13 FACTO IS 1.0E9 * 1.0 E4 -!*** The 1.0e9 is for the wavelength [ nm ] -> [ m ] -!*** The 1.0e4 is for the area [ cm **2 ] -> [ m**2 ] - - DO IWL = 1, NWL - LAMDA = WAVELENGTH( IWL ) - CONV_WM2( IWL ) = 1.0E13 * ( PLANCK_C * LIGHT_SPEED ) / LAMDA - END DO - - COS85 = COS( 85.0 * PI180 ) - -!***get molecular scattering cross sections - - CALL GETSRAY ( NWL, WAVELENGTH, SRAYL ) - - FIRST = .FALSE. - - END IF ! FIRSTIME - -!***initialize BLKRJ and other layer variables - - BLKRJ = 0.0 - ACTINIC_FLUX = 0.0 - IRRADIANCE = 0.0 - REFLECTION = 0.0 - TRANSMISSION = 0.0 - TRANS_DIRECT = 0.0 - INSOLATION = 0.0 - TROPO_O3_TOGGLE = 1.0 - STRATO3_MINS_MET = .TRUE. -!***Initialize sums or set default values for outputs: -! TAUC_AERO, TAU_TOT, TAUO3_TOP, TAU_RAY, SSA_AERO, etc. - - TAUC_AERO = 0.0 - TAU_TOT = 0.0 - TAU_CLOUD = 0.0 - TAU_SCAT = 0.0 - SSA_AERO = 0.0 - TOTAL_TAU_CLD = 0.0 -#ifdef phot_debug - AVE_SSA_CLD = 0.0 - AVE_ASYMM_CLD = 0.0 -#endif -!***Test zenith angle. If coszen is zero or negative, zenith angle is -!*** equal to or greater than 90 degrees, i.e. before sunrise or -!*** after sunset at the surface. -!*** Return all photolysis rates set to zero. Ignore possible twilight -!*** processes in upper troposphere. - -!***FSB NOTE: tests of the algorithm for slant path show that the -!*** critical zenith angle for the tropospheric slant path is 88 degrees, -!*** but the critical zenith angle for the stratospheric slant path is -!*** 85 degrees. Thus, the code returns zeros for angles greater then or -!*** equalt to 85 degrees. cos( 85 degrees ) equals 8.715574e-02. - - IF ( COSZEN .LE. COS85 ) THEN - TAUO3_TOP = 0.0 - TAU_RAY = 0.0 - TOTAL_O3_COLUMN = 0.0 - TROPO_O3_COLUMN = 0.0 - TROPO_O3_TOGGLE = 1.0 - RETURN - END IF - - IF ( NEW_PROFILE ) THEN ! update based on new temperature and density profile -!***Adjust cross sections and quantum yields for ambient conditions - - CALL GET_CSQY ( BLKTA, BLKDENS, CSZ, QYZ ) - -!***calculate scale height from top of model domain - - HSCALE = R_G * BLKTA( NLAYS ) - -!***estimate air density at top of model domain - - DENSTOM = BLKDENS( NLAYS ) - & * EXP( -100.0 * ( BLKZF( NLAYS + 1 ) - BLKZH( NLAYS ) ) - & / HSCALE ) - -!***calculate the total number of air molecules [ # / cm**2 ] -!*** above top of model domain. - - NBAR = HSCALE * DENSTOM - -!***set top of modeling domain - - ZTOM = BLKZF( NLAYS + 1 ) - -!***get layer thicknesses and slantpath starting at the TOP - - CALL SLANTPATH2 ( NLAYS, BLKZF, ZSFC, REARTH, SINZEN, BLKDZ, DSDH ) - -!***get slantpath from ZTOM to ZTOA - - CALL SLANTPATHTOP ( ZTOM, ZTOA, ZSFC, REARTH, SINZEN, DSDH_TOP ) - -C*** find ozone column density for atmosphere, stratosphere, and troposphere - STRAT_O3_COLUMN = DU_TO_CONC * REAL( TOTAL_O3_COLUMN ) -! STRAT_O3_COLMIN = 0.10 * STRAT_O3_COLUMN - STRAT_O3_COLMIN = MIN_STRATO3_FRAC * STRAT_O3_COLUMN - SUCCESS = .TRUE. - TROPO_O3_COLUMN = 0.0 - DO L = NLAYS, 1, -1 - DELTA_O3_COLUMN = 100.0 * BLKO3( L ) * BLKDZ( L ) - STRAT_O3_COLUMN = STRAT_O3_COLUMN - DELTA_O3_COLUMN - TROPO_O3_COLUMN = TROPO_O3_COLUMN + DELTA_O3_COLUMN - IF ( STRAT_O3_COLUMN .LT. STRAT_O3_COLMIN .AND. SUCCESS ) THEN - IF( OBEY_STRATO3_MINS )THEN - WRITE( NEW_OPTICS_LOG,'( /A, F5.2, A, 3(/A), I3, A, F8.3, A , 2(I4,1X) )' ) - & 'PHOT WARNING: First Occurance where computed stratospheric O3 column < ', - & 100.0*MIN_STRATO3_FRAC,'%', - & 'observed total column. The percentage is a global minimum based on ', - & 'climatological ozone profiles. ', - & 'The Error accumulates downward from layer = ', L, ' or alt= ', - & 0.001*BLKZF( L ),' Km for col,row = ', PHOT_COL, PHOT_ROW - END IF - SUCCESS = .FALSE. - END IF - END DO - - STRAT_O3_COLUMN = CONC_TO_DU * STRAT_O3_COLUMN - TROPO_O3_COLUMN = CONC_TO_DU * TROPO_O3_COLUMN - -#ifdef verbose_PHOT_MOD - IF( PHOT_COL .EQ. 1 .AND. PHOT_ROW .EQ. 1 )THEN - WRITE( NEW_OPTICS_LOG,*)'TOTAL_O3_COLUMN, TROPO_O3_COLUMN = ',TOTAL_O3_COLUMN, TROPO_O3_COLUMN - END IF -#endif - - IF ( .NOT. SUCCESS ) THEN - TROPO_O3_TOGGLE = MAX_TROPOO3_FRAC * TOTAL_O3_COLUMN - & / TROPO_O3_COLUMN - N_TROPO_O3_TOGGLE = N_TROPO_O3_TOGGLE + 1 - O3_TOGGLE_AVE = O3_TOGGLE_AVE + TROPO_O3_TOGGLE - O3_TOGGLE_MIN = MIN( O3_TOGGLE_MIN, TROPO_O3_TOGGLE) - STRATO3_MINS_MET = .FALSE. - STRAT_O3_COLUMN = CONC_TO_DU * STRAT_O3_COLMIN - IF( OBEY_STRATO3_MINS )THEN ! write to PE log for first occurance - WRITE( NEW_OPTICS_LOG, 99983)STRAT_O3_COLUMN - IF( ADJUST_OZONE ) WRITE( NEW_OPTICS_LOG, 99984)TROPO_O3_TOGGLE - WRITE( NEW_OPTICS_LOG, 99887) - WRITE( NEW_OPTICS_LOG, 99888)TOTAL_O3_COLUMN, TROPO_O3_COLUMN, MAX_TROPOO3_FRAC - WRITE( NEW_OPTICS_LOG, 99999) - OBEY_STRATO3_MINS = .FALSE. - END IF - IF( .NOT. ADJUST_OZONE ) TROPO_O3_TOGGLE = 1.0 ! reset toggle to one - ELSE - TROPO_O3_TOGGLE = 1.0 - END IF - - -99983 FORMAT( 'Corrective Action: 1) Stratospheric O3 column set to ',F8.3,' DU' ) -99984 FORMAT( 'and 2) Extinction from Model Domain O3 multiplied by ',F9.6 ) -99887 FORMAT(/'Check TROPO_O3_EXCEED and N_EXCEED_TROPO3 in PHOTDIAG1 file for ' - & /'values greater than zero to assess the extent of the ' - & /'problem. TROPO_O3_EXCEED and N_EXCEED_TROPO3 are the average ' - & /'exceedance and their number over file time step for each grid cell,' - & /'respectively. Exceedance depends on the predicted tropospheric' - & /'fraction over the maximum allowed fraction of the total ozone column.' - & /'Its value equals the ratio minus one if ratio is greater than one and' - & /'zero if the ratio is less than or equal to one. N_EXCEED_TROPO3 ' - & /'counts the number of nonzero values per timestep') -99888 FORMAT(/'Direct Cause: Predicted O3 tropospheric Column exceeds maximum allowed ' - & /'fraction of total OMI column.', - & /'OMI Total O3 Column = ',F8.3,' DU: Model Tropospheric O3 Column = ',F8.3,' DU', - & /'Climatological Expected Tropospheric Fraction = ',F9.6) -99999 FORMAT(/'ULTIMATE causes include boundary condition and meteorological input files. ' - & /'Check the former for unrealistic concentrations of ozone and its precursors.' - & /'Check the latter for unrealistic advection and diffusion parameters.') - - DO IWL = 1, NWL -!***Get optical depth for stratospheric ozone column -!***Note that stratosphere ozone coluumn assumed to exist above model domain - CALL GET_TAUO3 ( IWL, STRAT_O3_COLUMN, STRAT_TEMP, TAUO3_TOP( IWL ) ) -!***get Rayleigh optical depth for stratosphere - TAU_RAY( IWL ) = NBAR * SRAYL( IWL ) - END DO - END IF ! for NEW_PROFILE - -!***loop over wavelengths - DO IWL = 1, NWL ! outermost loop - -! RSFC = ALB( IWL ) ! surface albedo - -!***set scaling factor for reducing extraterrestrial flux -!*** add ozone and Rayleigh optical depths. Use the -!*** pseudospherical correction for the stratosphere. - - SOLAR_FLUX = FEXT( IWL ) / RSQD - -!*** initialize tau, delta tau's, other variables and loop over layers - - DTAU = 0.0 - DT_AERO = 0.0 - DT_CLOUD = 0.0 - DTSCAT_CLOUD = 0.0 - TAU_SCAT_CLD = 0.0 - - DO L = 2, NLAYS + 1 - II = NLAYS + 2 - L ! from top to bottom - -!***in the following statements the factor of 100.0 converts -!*** converts [ 1 / cm ] to [ 1 / m ] - - BETA_M = SRAYL( IWL ) * BLKDENS( II ) * 100.0 - AO3 = CSZ( II,IWL,LO3O3P ) * BLKO3 ( II ) * 100.0 - AO3 = TROPO_O3_TOGGLE * AO3 - ANO2 = CSZ( II,IWL,LNO2 ) * BLKNO2 ( II ) * 100.0 - -!***set up aerosol optical properties - - G_BAR = AERO_ASYM_FAC ( II,IWL ) - BEXT = AERO_EXTI_COEF( II,IWL ) - BSCAT = AERO_SCAT_COEF( II,IWL ) - -!***calculate total absorption and scattering contributions -!***to optical depth - -!***The contributions to scattering and absorption from molecules and particles -!*** are calculated separately to facilitate the calculation -!*** of the total single scatering albedo of the column of aerosols -!*** as measured by satellites. - - DTSCAT_M = BETA_M * BLKDZ( II ) ! molecular scattering - DTSCAT_A = BSCAT * BLKDZ( II ) ! particle scattering - - DTSCAT_M = MAX( DTSCAT_M, SMALL ) - DTSCAT_A = MAX( DTSCAT_A, SMALL ) - - - DTABS_M = ( AO3 + ANO2 ) * BLKDZ( II ) ! molecular absorption - DTABS_A = ( BEXT - BSCAT ) * BLKDZ( II ) ! particle absorption - - DTABS_M = MAX( DTABS_M, SMALL ) - DTABS_A = MAX( DTABS_A, SMALL ) - - IF ( CLOUDS( II ) ) THEN - - DT_CLOUD( L ) = ( CLOUD_LIQUID_EXT( II,IWL ) - & + CLOUD_ICE_EXT( II,IWL ) - & + CLOUD_AGGREG_EXT( II,IWL ) ) * BLKDZ( II ) - DTSCAT_CLOUD = ( CLOUD_LIQUID_SCAT( II,IWL ) - & + CLOUD_ICE_SCAT( II,IWL ) - & + CLOUD_AGGREG_SCAT( II,IWL ) ) * BLKDZ( II ) - -!Adjust DT_CLOUD for cloud fraction by 1/2 power of CLDFRC to approximate cloud overlap. -!Note that the power results because the resolved cloud conentrations are averaged over -!the grid cell so the net overlap correction equal cfrac**(3/2) from Briegleb (1992) times -!cfrac**(-1) for actual in-cloud concentrations (see Voulgarakis et al., 2009, Geosci Model -!Dev., vol. 2, pp. 59-72. - - IF ( CLOUD_LAYERING( II ) ) THEN - LAYERING_FACTOR = SQRT( CLDFRC( II ) ) - ELSE - LAYERING_FACTOR = CLDFRC( II ) - END IF - DT_CLOUD( L ) = DT_CLOUD( L ) * LAYERING_FACTOR - DTSCAT_CLOUD = DTSCAT_CLOUD * LAYERING_FACTOR - - TAU_SCAT_CLD = TAU_SCAT_CLD + DTSCAT_CLOUD - - IF ( DT_CLOUD( L ) .GT. 1.0E-6 ) THEN - OM_CLOUD = MAX( DTSCAT_CLOUD /DT_CLOUD( L ), 1.0) - IF ( OM_CLOUD .LT. 0.0 .OR. OM_CLOUD .GT. 1.0 .OR. OM_CLOUD .NE. OM_CLOUD) THEN - WRITE( NEW_OPTICS_LOG,'(A,I3,A,ES12.4,A)',ADVANCE = 'NO') - & 'OM_CLOUD( L = ', L, ' ) = ', OM_CLOUD,' resetting to ' - OM_CLOUD = MAX( 0.000001, MIN( OM_CLOUD, 0.99999)) - WRITE( NEW_OPTICS_LOG,'(ES12.4)')OM_CLOUD - WRITE( NEW_OPTICS_LOG,'(A,2(ES12.4,1X))')'LIQUID_EXT, LIQUID_SCAT = ', - & CLOUD_LIQUID_EXT( II,IWL ), CLOUD_LIQUID_SCAT( II,IWL ) - WRITE( NEW_OPTICS_LOG,'(A,2(ES12.4,1X))')'ICE_EXT, ICE_SCAT = ', - & CLOUD_ICE_EXT( II,IWL ), CLOUD_ICE_SCAT( II,IWL ) - WRITE( NEW_OPTICS_LOG,'(A,2(ES12.4,1X))')'AGGREG_EXT, AGGREG_SCAT = ', - & CLOUD_AGGREG_EXT( II,IWL ), CLOUD_AGGREG_SCAT( II,IWL ) - CALL M3EXIT( 'NEW_OPTICS', JDATE, JTIME, ' ', XSTAT1 ) - END IF - ELSE - OM_CLOUD = 1.0 - END IF - - IF ( DTSCAT_CLOUD .GT. 1.0E-6 ) THEN - - G_CLOUD = ( (CLOUD_LIQUID_ASY( II,IWL ) * CLOUD_LIQUID_SCAT( II,IWL )) - & + (CLOUD_ICE_ASY( II,IWL ) * CLOUD_ICE_SCAT( II,IWL )) - & + (CLOUD_AGGREG_ASY( II,IWL ) * CLOUD_AGGREG_SCAT( II,IWL )) ) - & * BLKDZ( II ) * LAYERING_FACTOR - -#ifdef phot_debug - IF ( .NOT. ONLY_SOLVE_RAD ) THEN - AVE_ASYMM_CLD( IWL ) = AVE_ASYMM_CLD( IWL ) + G_CLOUD - IF ( AVE_ASYMM_CLD( IWL ) .GT. TAU_SCAT_CLD ) THEN - WRITE( NEW_OPTICS_LOG,'(A,I3,2(A,ES12.4))' ) - & 'Sum for AVE_ASYMM_CLD at L (', L,') = ', AVE_ASYMM_CLD( IWL ), - & ' Sum for TAU_SCAT_CLD = ',TAU_SCAT_CLD - WRITE( NEW_OPTICS_LOG,'(A,2(ES12.4,1X))' ) - & 'AVE_ASYMM_CLD Increment = ', G_CLOUD - WRITE( NEW_OPTICS_LOG,'(A,2(ES12.4,1X))' ) - & 'TAU_SCAT_CLD Increment = ', DTSCAT_CLOUD - END IF - END IF -#endif - - G_CLOUD = G_CLOUD / DTSCAT_CLOUD - - IF ( G_CLOUD .GE. 1.0 .OR. G_CLOUD .LE. -1.0 .OR. G_CLOUD .NE. G_CLOUD ) THEN - WRITE( NEW_OPTICS_LOG,'(A,I3,A,ES12.4,A)',ADVANCE = 'NO' ) - & 'G_CLOUD( L = ', L, ' ) = ', G_CLOUD,' resetting to ' - G_CLOUD = MIN( 0.9999, MAX( G_CLOUD, -0.9999) ) - WRITE( NEW_OPTICS_LOG,'(ES12.4)') G_CLOUD - WRITE( NEW_OPTICS_LOG,'(A,2(ES12.4,1X))' ) - & 'LIQUID_ASY, LIQUID_SCAT = ', - & CLOUD_LIQUID_ASY( II,IWL ), CLOUD_LIQUID_SCAT( II,IWL ) - WRITE( NEW_OPTICS_LOG,'(A,2(ES12.4,1X))' ) - & 'ICE_ASY, ICE_SCAT = ', - & CLOUD_ICE_ASY( II,IWL ), CLOUD_ICE_SCAT( II,IWL ) - WRITE( NEW_OPTICS_LOG,'(A,2(ES12.4,1X))' ) - & 'AGGREG_ASY, AGGREG_SCAT = ', - & CLOUD_AGGREG_ASY( II,IWL ), CLOUD_AGGREG_SCAT( II,IWL ) - CALL M3EXIT( 'NEW_OPTICS', JDATE, JTIME, ' ', XSTAT1 ) - END IF - ELSE - G_CLOUD = 0.0 - END IF - ELSE - DTSCAT_CLOUD = 0.0 - G_CLOUD = 0.0 - OM_CLOUD = 1.0 - END IF - -!***calculate total absorption and scattering contributions -!***to optical depth - - DTSCAT = DTSCAT_M + DTSCAT_A + DTSCAT_CLOUD - DTABS = DTABS_M + DTABS_A + MAX(( 1.0 - OM_CLOUD ), 0.0) * DT_CLOUD( L ) - -!***set aerosol optical depth for later use - - DT_AERO ( L ) = BEXT * BLKDZ( II ) - -!***Now calculate the vertical profiles of optical depth, -!*** single scattering albedo, asymmetry factor -!*** and DSDH starting at the top. - - DTAU( L ) = DTSCAT + DTABS - OM ( L ) = DTSCAT / ( DTSCAT + DTABS ) - G ( L ) = ( G_BAR * DTSCAT_A + G_CLOUD * DTSCAT_CLOUD ) / DTSCAT - - IF ( G( L ) .GE. 1.0 .OR. G( L ) .LE. -1.0 .OR. G( L ) .NE. G( L ) ) THEN - WRITE( NEW_OPTICS_LOG,'(A,ES12.4,A)',ADVANCE = 'NO' ) - & 'G( L ) = ', G( L ),' resetting to ' - G( L ) = MIN( 0.9999, MAX( G( L ), -0.9999) ) - WRITE( NEW_OPTICS_LOG,'(ES12.4)')G( L ) - WRITE( NEW_OPTICS_LOG,'(A,10(1X,ES12.4))' ) - & 'DTSCAT_M, DTSCAT_A, DTSCAT_CLOUD, G_BAR, G_CLOUD = ', - & DTSCAT_M, DTSCAT_A, DTSCAT_CLOUD, G_BAR, G_CLOUD - END IF - - IF ( OM( L ) .GT. 1.0 .OR. OM( L ) .LE. 0.0 .OR. OM( L ) .NE. OM( L ) ) THEN - WRITE( NEW_OPTICS_LOG,'(A,ES12.4,A)',ADVANCE = 'NO' ) - & 'OM( L ) = ', OM( L ),' resetting to ' - OM( L ) = MIN( 0.9999, MAX( OM( L ), 0.0001) ) -#ifdef phot_debug - WRITE( NEW_OPTICS_LOG,'(ES12.4)' ) OM( L ) - WRITE( NEW_OPTICS_LOG,'(A,4(1X,ES12.4))' ) - & 'DTSCAT, DTABS, ( DTSCAT + DTABS) = ', - & DTSCAT, DTABS, ( DTSCAT + DTABS ) - WRITE( NEW_OPTICS_LOG,'(A,4(1X,ES12.4))' ) - & 'DTSCAT_M, DTSCAT_A, DTSCAT_CLOUD = ', - & DTSCAT_M, DTSCAT_A, DTSCAT_CLOUD - WRITE( NEW_OPTICS_LOG,'(A,4(1X,ES12.4))' ) - & 'DDTABS_M, DTABS_A, MAX(( 1.0-OM_CLOUD ), 0.0) * DT_CLOUD( L ) = ', - & DTABS_M, DTABS_A, MAX(( 1.0 - OM_CLOUD ), 0.0) * DT_CLOUD( L ) - WRITE( NEW_OPTICS_LOG,'(A,4(1X,ES12.4))' ) - & ' AO3, ANO2,AERO_BEXT, AERO_BSCAT = ', - & AO3, ANO2,BEXT, BSCAT -#endif - ELSE -#ifdef phot_debug - IF ( OM( L ) .EQ. 1.0 ) THEN - WRITE( NEW_OPTICS_LOG,'(A,4(1X,ES12.4))' ) - & 'DTSCAT, DTABS, ( DTSCAT + DTABS ) = ', - & DTSCAT, DTABS, (DTSCAT + DTABS) - WRITE( NEW_OPTICS_LOG,'(A,4(1X,ES12.4))' ) - & 'DTSCAT_M, DTSCAT_A, DTSCAT_CLOUD = ', - & DTSCAT_M, DTSCAT_A, DTSCAT_CLOUD - WRITE( NEW_OPTICS_LOG,'(A,4(1X,ES12.4))' ) - & 'DDTABS_M, DTABS_A, MAX(( 1.0-OM_CLOUD ), 0.0) * DT_CLOUD( L ) = ', - & DTABS_M, DTABS_A, MAX(( 1.0 - OM_CLOUD ), 0.0 ) * DT_CLOUD( L) - WRITE( NEW_OPTICS_LOG,'(A,4(1X,ES12.4))' ) - & 'AO3, ANO2,AERO_BEXT, AERO_BSCAT = ', - & AO3, ANO2,BEXT, BSCAT - END IF -#endif - OM( L ) = MIN( 0.9999, OM( L ) ) - END IF - - DSDH_TD( L ) = DSDH( L - 1 ) - - IF ( ONLY_SOLVE_RAD ) CYCLE -!***FSB get sums of unscaled optical depths - - TAU_SCAT( IWL ) = TAU_SCAT ( IWL ) + DTSCAT_A - -!***initialize optical depth profiles to the layer increment - - TAUC_AERO( II,IWL ) = DT_AERO( L ) ! aerosol optical depth - TAU_TOT ( II,IWL ) = DTAU( L ) ! total optical depth - TAU_CLOUD( II,IWL ) = DT_CLOUD( L ) ! cloud optical depth - - END DO ! loop over layers - -!***set values for the stratosphere - - OM ( 1 ) = TAU_RAY( IWL ) / ( TAU_RAY( IWL ) + TAUO3_TOP( IWL ) ) - G ( 1 ) = 0.05 - DTAU ( 1 ) = TAUO3_TOP( IWL ) + TAU_RAY( IWL ) - DSDH_TD( 1 ) = DSDH_TOP - - NLEVEL = NLAYS + 1 - - IF ( .NOT. ONLY_SOLVE_RAD ) THEN -!***calculate optical depth profiles - TAU_TOT ( NLAYS,IWL ) = TAU_TOT ( NLAYS,IWL ) + DTAU( 1 ) - TAUC_AERO( NLAYS,IWL ) = TAUC_AERO( NLAYS,IWL ) + DT_AERO( 1 ) - TAU_CLOUD( NLAYS,IWL ) = TAU_CLOUD( NLAYS,IWL ) + DT_CLOUD( 1 ) - - DO L = NLAYS-1, 1, -1 - TAU_TOT ( L,IWL ) = TAU_TOT ( L,IWL ) + TAU_TOT ( L+1,IWL ) - TAUC_AERO( L,IWL ) = TAUC_AERO( L,IWL ) + TAUC_AERO( L+1,IWL ) - TAU_CLOUD( L,IWL ) = TAU_CLOUD( L,IWL ) + TAU_CLOUD( L+1,IWL ) - END DO - END IF - -!***Set fluxes to zero - - FDIR = 0.0 - FUP = 0.0 - FDN = 0.0 - EDIR = 0.0 - EUP = 0.0 - EDN = 0.0 - -!***calculate fluxes and irradiances - - CALL TWOSTREAM_S ( NLEVEL, COSZEN, ALB( IWL ), DTAU, OM, G, DSDH_TD, - & FDIR, FUP, FDN, EDIR, EUP, EDN ) - - DO L = 1, NLAYS - II = NLAYS + 2 - L - FSUM( L ) = FDIR( II ) + FDN( II ) + FUP( II ) ! actinic flux - ESUM( L ) = EDIR( II ) + EDN( II ) ! downward irradiance - END DO ! loop over layers - -! add diffusion and direct components for calculating reflectivity and transmissivity - INSOLATION = INSOLATION + SOLAR_FLUX - REFLECTION = REFLECTION + SOLAR_FLUX * EUP( 1 ) - TRANSMISSION = TRANSMISSION + SOLAR_FLUX * EDN( NLEVEL ) - TRANS_DIRECT = TRANS_DIRECT + SOLAR_FLUX * EDIR( NLEVEL ) - - IF ( ONLY_SOLVE_RAD ) CYCLE - -!***FSB Calculate column averaged scattering albedo and asymmetry factor - - IF ( TAUC_AERO( 1,IWL ) .GT. 1.0E-30 ) THEN - SSA_AERO( IWL ) = TAU_SCAT( IWL ) / TAUC_AERO( 1,IWL ) - END IF - - TOTAL_TAU_CLD( IWL ) = TAU_CLOUD( 1,IWL ) - -#ifdef phot_debug - IF ( TAU_CLOUD( 1,IWL ) .GT. 1.0E-20 ) THEN - IF ( AVE_ASYMM_CLD( IWL ) .GT. TAU_SCAT_CLD ) THEN - WRITE( NEW_OPTICS_LOG,'(A,I3,2(A,ES12.4))' ) - & 'Sum for AVE_ASYMM_CLD at L(', 1,') = ', AVE_ASYMM_CLD( IWL ), - & 'Sum for TAU_SCAT_CLD = ',TAU_SCAT_CLD - WRITE( NEW_OPTICS_LOG,'(A,2(ES12.4,1X))' ) - & 'AVE_ASYMM_CLD Increment = ', G_CLOUD - WRITE( NEW_OPTICS_LOG,'(A,2(ES12.4,1X))' ) - & 'TAU_SCAT_CLD Increment = ', - & DTSCAT_CLOUD - END IF - IF ( TAU_SCAT_CLD .GT. 1.0E-20 ) THEN - AVE_ASYMM_CLD( IWL ) = AVE_ASYMM_CLD( IWL ) / TAU_SCAT_CLD - AVE_SSA_CLD ( IWL ) = TAU_SCAT_CLD / TAU_CLOUD( 1,IWL ) - ELSE - AVE_ASYMM_CLD( IWL ) = 0.0 - AVE_SSA_CLD ( IWL ) = 0.0 - END IF - IF ( ABS( AVE_ASYMM_CLD( IWL ) ) .GE. 1.0 ) THEN - WRITE( NEW_OPTICS_LOG,'(A,I3,2(A,ES12.4))' ) - & 'Sum for AVE_ASYMM_CLD at L(', 1,') = ', AVE_ASYMM_CLD( IWL )*TAU_SCAT_CLD, - & 'Sum for TAU_SCAT_CLD = ',TAU_SCAT_CLD - WRITE( NEW_OPTICS_LOG,'(A,2(ES12.4,1X))' ) - & 'AVE_ASYMM_CLD Increment = ', G_CLOUD - WRITE( NEW_OPTICS_LOG,'(A,2(ES12.4,1X))' ) - & 'TAU_SCAT_CLD Increment = ', DTSCAT_CLOUD - END IF - ELSE - TOTAL_TAU_CLD( IWL ) = 0.0 - AVE_SSA_CLD ( IWL ) = 0.0 - AVE_ASYMM_CLD( IWL ) = 0.0 - END IF -#endif - -!***FSB capture the total downward irradiance at the surface [ W / m**2] -! -! ETOT_SFC( IWL ) = CONV_WM2( IWL ) * FLXSCALE * FEXT( IWL ) -! & * ESUM( 1 ) - - FORALL( L = 1:NLAYS ) -!***multiply by the solar flux at the domain top for -!***actinic flux and irradiance; keeping actinic flux in photons/(cm^2*s) - ACTINIC_FLUX( L,IWL ) = SOLAR_FLUX * FSUM( L ) - IRRADIANCE ( L,IWL ) = SOLAR_FLUX * CONV_WM2( IWL ) * ESUM( L ) - END FORALL - END DO ! loop over wavelengths - -! normalize reflection and transmission coefficients - INSOLATION = 1.0 / ( COSZEN * INSOLATION ) - TRANS_DIRECT = TRANS_DIRECT * INSOLATION - REFLECTION = ONE_OVER_PI * REFLECTION * INSOLATION - TRANSMISSION = ONE_OVER_PI * TRANSMISSION * INSOLATION - - IF ( ONLY_SOLVE_RAD ) RETURN - -! compute photolysis rates - DO IPHOT = 1, NPHOTAB - DO IWL = 1, NWL - DO L = 1, NLAYS - BLKRJ( L,IPHOT ) = BLKRJ( L,IPHOT ) - & + ACTINIC_FLUX( L,IWL ) - & * CSZ( L,IWL,IPHOT ) * QYZ( L,IWL,IPHOT ) ! [ 1 / sec ] - END DO - END DO - END DO ! loop on layers, wavelength, IPHOT -! convert actinic flux to watts/m^2 - FORALL( L = 1:NLAYS, IWL=1:NWL ) - ACTINIC_FLUX( L,IWL ) = ACTINIC_FLUX( L,IWL ) * CONV_WM2( IWL ) - END FORALL - -!***compute rate of photolysis (j-values) for each reaction - -9503 FORMAT('LAYER = ',I3,' MODE = ',I3,' LAMBDA(nm) = ',ES12.4,' DGN_CORE(m) = ',ES12.4, - & ' DGN_SHELL(m) = ', ES12.4 / ' REFRACT_IDX_SHELL(NR,NI) = ', 2(ES12.4,1X), - & ' REFRACT_IDX_CORE(NR,NI) = ', 2(ES12.4,1X) / ' LN(GEO.STD.DEV.) = ', - & ES12.4) -9504 FORMAT('LAYER = ',I3,' MODE = ',I3,' LAMBDA(nm) = ',ES12.4,' DGN(m) = ',ES12.4, - & ' REFRACT_IDX(NR,NI) = ', 2(ES12.4,1X) / ' VOL.DENS. = ', ES12.4, - & ' LN(GEO.STD.DEV.) = ', ES12.4) - -99985 FORMAT('ERROR: Modeled Troposheric Ozone Column downward from layer ',I3,1X) -99986 FORMAT('exceeds Top Ozone Column based on OMI.data file. Negative Optical Depths ') -99987 FORMAT('but are physically unlikey.') -99988 FORMAT(' SETTING O3 Column ABOVE PTOP TO 25% of OMI.dat value ') -99989 FORMAT(' FOR ROW/COL = ',2(1X,I4)) - - RETURN - END SUBROUTINE NEW_OPTICS - -C/////////////////////////////////////////////////////////////////////// - - SUBROUTINE GETSRAY ( NWL, LAMDA, SRAYL ) -C----------------------------------------------------------------------- -C calculate molecular (Rayleigh) scattering cross section, srayl -C -C coded 09/08/2004 by Dr. Francis S. Binkowski -C Carolina Environmental Program -C University of North Carolina at Chapel Hill -C email: frank_binkowski@unc.edu -C -C Reference: -C Nicolet, M., On the molecular scattering in the terrestrial -C atmosphere: An empirical formula for its calculation in the -C homoshpere, Planetary and Space Science. Vol. 32,No. 11, -C Pages 1467-1468, November 1984. -C----------------------------------------------------------------------- - - IMPLICIT NONE - -!***arguments - - INTEGER, INTENT( IN ) :: NWL ! number of wavelength bins - REAL, INTENT( IN ) :: LAMDA( : ) ! wavelengths [nm] - REAL, INTENT( OUT ) :: SRAYL( : ) ! molecular scattering cross sections [cm**2] - -!***Internal variables - - INTEGER I - REAL WMICRN ! wavelenght in micrometers - REAL WMICRN1 ! 1 / wmicrn - REAL XX ! variable in Nicolet method - -!***get molecular scattering cross section. This is a fixed -!*** function of wavelength. - - DO I = 1, NWL - WMICRN = 1.0E-3 * LAMDA( I ) ! wavelength in micrometers - WMICRN1 = 1.0 / WMICRN - - IF ( WMICRN .LE. 0.55 ) THEN - XX = 3.6772 + 0.389 * WMICRN + 0.09426 * WMICRN1 - ELSE - XX = 4.04 - END IF - - SRAYL( I ) = 4.02E-28 * WMICRN1**XX ! in [cm**2] - - END DO - - RETURN - END SUBROUTINE GETSRAY - - - SUBROUTINE GET_TAUO3 ( IWL, STOZONE, STRAT_TEMP, TAU_O3 ) -C----------------------------------------------------------------------- -C subroutine to calculate the optical depth of ozone in the -C stratosphere -C -C special cross sections for calculating stratospheric ozone -C optical depth -C -C the following temperatures and cross sections are from -C Fast-J -C REFERENCE: -C Wild, O., X. Zhu, and M.J. Prather, Fast-J: Accurate simulation -C of in- and below-clolud photolysis in tropospheric chemical -C models, -C Journal of Atmospheric Chemistry, Vol. 37, pp 245-282, 2000 -C -C coded 10/20/2004 by Dr. Francis S. Binkowski -C Carolina Environmental Program -C University of North Carolina at Chapel Hill -C email: frank_binkowski@unc.edu -C Updated to Fast-JX version 5.0 -C Mar 2011 Bill Hutzell -C revised interpolation method for a general number of -C interpolation points -C -C----------------------------------------------------------------------- - - IMPLICIT NONE - -!***arguments - - INTEGER, INTENT( IN ) :: IWL ! wavelenth index - - REAL, INTENT( IN ) :: STOZONE ! ozone column amount [ DU ] - REAL, INTENT( IN ) :: STRAT_TEMP ! average temperature for stratosphere [ K ] - REAL, INTENT( OUT ) :: TAU_O3 ! optical depth for statosphere - -!***Local - - INTEGER IXT, IXTEMP - - REAL OZONE_CS ! interpolated ozone absorption cross section - REAL YTT ! interpolation variable - -!***Find temperature range: - - IF ( STRAT_TEMP .LE. TEMP_O3_STRAT( 1 ) ) IXTEMP = 0 - - DO IXT = 1, NTEMP_STRAT - 1 - IF ( STRAT_TEMP .GT. TEMP_O3_STRAT( IXT ) .AND. - & STRAT_TEMP .LT. TEMP_O3_STRAT( IXT + 1 ) ) THEN - IXTEMP = IXT - YTT = ( STRAT_TEMP - TEMP_O3_STRAT( IXT ) ) - & / ( TEMP_O3_STRAT( IXT + 1 ) - TEMP_O3_STRAT( IXT ) ) - END IF - END DO - - IF ( STRAT_TEMP .GE. TEMP_O3_STRAT( NTEMP_STRAT ) ) THEN - IXTEMP = NTEMP_STRAT - YTT = 0.0 - END IF - -!***do linear interpolation - - IF ( IXTEMP .EQ. 0 ) THEN - OZONE_CS = XO3CS( 1, IWL ) - ELSE IF ( IXTEMP .GE. 1 .AND. IXTEMP .LT. NTEMP_STRAT ) THEN - OZONE_CS = XO3CS( IXTEMP, IWL ) + - & ( XO3CS( IXTEMP+1, IWL ) - XO3CS( IXTEMP, IWL ) ) * YTT - ELSE IF ( IXTEMP .EQ. NTEMP_STRAT ) THEN - OZONE_CS = XO3CS( IXTEMP, IWL ) - END IF - - TAU_O3 = DU_TO_CONC * STOZONE * OZONE_CS - - RETURN - END SUBROUTINE GET_TAUO3 - -C/////////////////////////////////////////////////////////////////////// - - SUBROUTINE O3AMT ( XLAT, XLONG, MDAY, OZONE ) -C----------------------------------------------------------------------- -C This subroutine implements an algorithm for the annual behavior -C of total ozone ( taken here to be stratospheric) from -C climatology -C Reference: -C Van Heuklon, Thomas K., Estimating atmospheric ozone for solar -C radiation models, Solar Energy, Vol. 22, pp 63-68, 1979. -C updated from an earlier version by -C Dr. Francis S. Binkowski, The Carolina Environmental Program, -C The University of North Carolina at Chapel Hill. -C Email: frank_binkowski@unc.edu -C November 03. 2004. -C Only Northern Hemisphere is implemented. -C----------------------------------------------------------------------- - - IMPLICIT NONE - -!***arguments - - INTEGER, INTENT( IN ) :: MDAY ! Day number during the year - ! Jan 1st = 1.0, Feb 1st = 32, etc. - - REAL, INTENT( IN ) :: XLAT ! latitude of point on earth's surface - REAL, INTENT( IN ) :: XLONG ! longitude of point on earth's surface - REAL, INTENT( OUT ) :: OZONE ! Total column amount of ozone [ DU ] - -!***Internal: - -!***The following parameters are from Table 1 of Van Heuklon (1979). - - REAL, SAVE :: A, B, C, D, F, G, H, FJ - DATA A/150.0/, B/1.28/, C/40.0/, D/0.9865/, F/-30.0/, G/20.0/, - & H/3.0/, FJ/235.0/ - -!***FSB FJ is the equatorial annual average of atmospheric ozone -!*** content, as noted on page 65 of Nav Heulklon (1979). This value -!*** sets the basic background for ozone. - - REAL, PARAMETER :: RD = 0.017453 ! degrees to radians - -!***Variables of convenience - - REAL E, FI, BPHI, DEF, HLI, SINB, SINB2 - -!***set the day - - E = FLOAT( MDAY ) - FI = 20.0 - IF ( XLONG .LT. 0.0 ) FI = 0.0 - BPHI = B * XLAT * RD - DEF = D * ( E + F ) * RD - HLI = H * ( XLONG + FI ) * RD - SINB = SIN( BPHI ) - SINB2 = SINB * SINB - -!***the following equation implements equation (4) of VanHeuklon (1979) - - OZONE = FJ + ( A + C * SIN( DEF ) + G * SIN( HLI ) ) * SINB2 - - RETURN - END SUBROUTINE O3AMT - -C/////////////////////////////////////////////////////////////////////// - - SUBROUTINE SLANTPATH2 ( NLAYS, Z, ZSFC, REARTH, SINZEN, DZ, DSDH ) -C----------------------------------------------------------------------- -C PURPOSE: -C Calculate slant path, ds/dh, over vertical depth in spherical -C geometry also calculates the layer thicknesses. -C NOTE!!! -C This version is restricted to zenith angle less than 90 degrees -C----------------------------------------------------------------------- -C ARGUMENTS: -C INPUT: -C NLAYS - INTEGER, number of specified altitude levels -C z - REAL, altitude (agl) [m] <<< meters -C This is from file ZF ( full layers ) from METCRO3D -C Z(1) is zero. -C zsfc - REAL, ground elevation (msl) [m] -C rearth - REAL, radius of the earth [m] -C sinzen - REAL, sine of solar zenith angle -C -C OUTPUT: -C dz - REAL, layer thicknesses [ m ] -C dsdh - REAL, slant path of direct beam through each layer -C when travelling from the top of the atmosphere downward -C----------------------------------------------------------------------- -C EDIT HISTORY: -C Inspired by sphers from TUV -C 09/08/2004 modified to specialize for CMAQ application -C by Dr. Francis S. Binkowski -C Environmental Modeling for Policy Development group, -C The Carolina Environmental Program -C The University of North Carolina-Chapel Hill -C Email: frank_binkowski@unc.edu -C -C----------------------------------------------------------------------- -C REFERENCE: -C Dahlback, A. and K. Stamnes, A new spherical model for computing -C the radiation field available for photolysis and heating at -C twilight, Planetary and Space Sciences, Vol. 39, No. 5, -C pp 671-683, 1991. -C -C----------------------------------------------------------------------- - - IMPLICIT NONE - -!***arguments - - INTEGER, INTENT( IN ) :: NLAYS - - REAL, INTENT( IN ) :: Z ( : ) - REAL, INTENT( IN ) :: ZSFC - REAL, INTENT( IN ) :: REARTH - REAL, INTENT( IN ) :: SINZEN - REAL, INTENT( OUT ) :: DZ ( : ) ! layer thicknesses counting from surface upward - REAL, INTENT( OUT ) :: DSDH( : ) - -!***Internal - - INTEGER I, J, K ! loop indices - REAL RE - REAL DSJ ! slant path length [m] - REAL DHJ ! layer thickness [m] - REAL( 8 ) :: RJ, RJP1 - REAL( 8 ) :: RPSINZ ! rpsinz = (re + zd(i)) * sinzen - REAL( 8 ) :: RPSINZ2 ! rpsinz * rpsinz - REAL( 8 ) :: GA, GB ! see usage - REAL :: ZE( NLAYS + 1 ) ! altitudes MSL - REAL :: ZD( NLAYS + 1 ) ! array of altitudes indexed from top - REAL :: DZI( NLAYS ) ! layer thicknesses counting downward from the top - -C----------------------------------------------------------------------- - -!***re include the altitude above sea level to the radius of the earth - - RE = REARTH + ZSFC - -!***ze is the altitude above msl - - DO K = 1, NLAYS + 1 - ZE( K ) = Z( K ) -!!sjr ZE(K) = Z(K) - ZSFC - END DO - -!*** DZ(1) = ZE(2) - ZE(1) -!*** DZI(1) = ZE(NLAYS + 1) - ZE(NLAYS) - -!***calculate dz - - DO K = 1, NLAYS - DZ( K ) = ZE( K + 1 ) - ZE( K ) - END DO - -!***zd, dzi are inverse coordinates of ze & dz - - DO K = 1, NLAYS + 1 - J = NLAYS + 1 - K + 1 - ZD( J ) = ZE( K ) - END DO - - DO K = 1, NLAYS - J = NLAYS + 1 - K - DZI( J ) = DZ( K ) - END DO - -!***initialize dsdh - - DO I = 1, NLAYS - DSDH( I ) = 0.0 - END DO - -!***FSB The following code is a direct implementation of appendix B -!*** of Dahlbeck and Stamnes (1991) for the case of solar zenith -!*** angle less than 90 degree. - -!***calculate ds/dh of every layer starting at the top - - DO J = 1, NLAYS -!*** K = NLAYS - J +1 - RPSINZ = REAL( ( RE + ZD( J ) ) * SINZEN , 8 ) - RPSINZ2 = RPSINZ * RPSINZ - - IF ( J .LT. NLAYS ) THEN - RJ = REAL( RE + ZD( J ), 8 ) - RJP1 = REAL( RE + ZD( J + 1 ), 8 ) - DHJ = DZI( J ) - ELSE - RJ = REAL( RE + ZD( J ), 8) - RJP1 = REAL( RE, 8 ) - DHJ = DZI( J ) - END IF - -!***define GA and GB - - GB = SQRT( MAX( 0.0D0, RJ * RJ - RPSINZ2 ) ) - GA = SQRT( MAX( 0.0D0, RJP1 * RJP1 - RPSINZ2 ) ) - -!***This is equation B1 from Dahlbeck and Stamnes (1991) - - DSJ = ABS( REAL(GB - GA, 4 ) ) - -!***this is the slant path (Chapman) function. - - DSDH( J ) = DSJ / DHJ ! Note dsdh is on a top to bottom grid. - - END DO ! loop over altitude - - RETURN - END SUBROUTINE SLANTPATH2 - -C/////////////////////////////////////////////////////////////////////// - - SUBROUTINE SLANTPATHTOP ( ZTOM, ZTOA, ZSFC, REARTH, SINZEN, - & DSDHTOP ) -C----------------------------------------------------------------------- -C FSB This is a SPECIAL version to get the slant path from the top of -C the modeling domain (ztom) to the top of the atmosphere (ztoa). -C----------------------------------------------------------------------- -C PURPOSE: -C Calculate slant path, ds/dh, over vertical depth in spherical -C geometry also calculates the layer thicknesses. -C NOTE!!! -C This version is restricted to zenith angle less than 90 degrees -C----------------------------------------------------------------------- -C ARGUMENTS: -C INPUT: -C ztom - REAL, altitude (agl) of top of modeling domain [m] << 0 +!------------------------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 + + !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 + & .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 + IF ( JTIME_CHK ) 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 From 941e2353e85dc7214376ed696808c4558e082fbb Mon Sep 17 00:00:00 2001 From: "Patrick.C.Campbell@noaa.gov" Date: Wed, 16 Feb 2022 21:25:10 +0000 Subject: [PATCH 04/90] Updated CMAQ makefiles for modified canopy codes. --- src/model/Makefile.am | 71 +++++++++++++------------- src/model/Makefile.in | 113 +++++++++++++++++++++++------------------- 2 files changed, 98 insertions(+), 86 deletions(-) diff --git a/src/model/Makefile.am b/src/model/Makefile.am index 61c4887..e27058a 100644 --- a/src/model/Makefile.am +++ b/src/model/Makefile.am @@ -163,7 +163,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 \ @@ -214,7 +213,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 @@ -223,7 +221,6 @@ VDIFF = $(CCTM)/vdiff/acm2 libVDIFF = $(VDIFF)/$(libCCTM)- libCCTM_a_SOURCES += \ $(VDIFF)/aero_sedv.F \ - $(VDIFF)/ASX_DATA_MOD.F \ $(VDIFF)/conv_cgrid.F \ $(VDIFF)/matrix1.F \ $(VDIFF)/opddep.F \ @@ -242,8 +239,10 @@ libCCTM_a_SOURCES += \ $(localCCTM)/o3totcol.f \ $(localCCTM)/vdiffacmx.F \ $(localCCTM)/PTMAP.F \ - $(localCCTM)/PT3D_DEFN.F - + $(localCCTM)/PT3D_DEFN.F \ + $(localCCTM)/phot.F \ + $(localCCTM)/ASX_DATA_MOD.F \ + $(localCCTM)/centralized_io_util_module.F libCCTM_a_CPPFLAGS = -DSUBST_FILES_ID=\"FILES_CTM.EXT\" libCCTM_a_CPPFLAGS += -DSUBST_CONST=\"CONST.EXT\" @@ -289,7 +288,7 @@ $(libAERO)AERO_DATA.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libAERO)aero_depv.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libAERO)AERO_DATA.$(OBJEXT) $(libAERO)AEROMET_DATA.$(OBJEXT) \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ $(libDEPV)MOSAIC_MOD.$(OBJEXT) $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) @@ -301,7 +300,7 @@ $(libAERO)aero_driver.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) $(libAERO)SOA_DEFN.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libAERO)AERO_EMIS.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(libAERO)AERO_DATA.$(OBJEXT) $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) \ + $(libAERO)AERO_DATA.$(OBJEXT) $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libEMIS)DUST_EMIS.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libAERO)PRECURSOR_DATA.$(OBJEXT) \ $(liblocalCCTM)PT3D_DEFN.$(OBJEXT) $(liblocalCCTM)PTMAP.$(OBJEXT) \ @@ -318,7 +317,7 @@ $(libAERO)aero_subs.$(OBJEXT) : $(ICL)/const/CONST.EXT $(AERO)/isrpia.inc \ $(libAERO)AOD_DEFN.$(OBJEXT) $(libAERO)PRECURSOR_DATA.$(OBJEXT) \ $(libAERO)SOA_DEFN.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libAERO)AOD_DEFN.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(libAERO)AERO_DATA.$(OBJEXT) $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) \ + $(libAERO)AERO_DATA.$(OBJEXT) $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libAERO)getpar.$(OBJEXT) : \ @@ -347,11 +346,11 @@ $(libAERO)SOA_DEFN.$(OBJEXT) : \ # biog $(libBIOG)beis3.$(OBJEXT) : \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BIOG_EMIS.$(OBJEXT) + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BIOG_EMIS.$(OBJEXT) $(libBIOG)czangle.$(OBJEXT) : $(ICL)/const/CONST.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libBIOG)hrno.$(OBJEXT) : \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BIOG_EMIS.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BIOG_EMIS.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ $(libSTENEX)noop_modules.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libBIOG)parsline.$(OBJEXT) : \ @@ -368,7 +367,7 @@ $(libCLOUD)hlconst.$(OBJEXT) : \ # depv $(libDEPV)ABFLUX_MOD.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ $(libDEPV)MOSAIC_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ @@ -378,7 +377,7 @@ $(libDEPV)cgrid_depv.$(OBJEXT) : \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)DEPV_DEFN.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libDEPV)DEPVVARS.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ $(libDEPV)MOSAIC_MOD.$(OBJEXT) $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) \ @@ -387,13 +386,13 @@ $(libDEPV)gas_depv_map.$(OBJEXT) : \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libDEPV)DEPVVARS.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)HGSIM.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libDEPV)LSM_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)MOSAIC_MOD.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libDEPV)LSM_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)opdepv_diag.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ @@ -405,7 +404,7 @@ $(libDEPV)opdepv_fst.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libDEPV)LSM_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)m3dry.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(libDEPV)ABFLUX_MOD.$(OBJEXT) $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) \ + $(libDEPV)ABFLUX_MOD.$(OBJEXT) $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) \ $(libDEPV)BIDI_MOD.$(OBJEXT) $(libDEPV)DEPVVARS.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libDEPV)HGSIM.$(OBJEXT) \ $(libDEPV)LSM_MOD.$(OBJEXT) $(libDEPV)MOSAIC_MOD.$(OBJEXT) \ @@ -421,12 +420,12 @@ $(libEMIS)BIOG_EMIS.$(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) $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) \ + $(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) \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BEIS_DEFN.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BEIS_DEFN.$(OBJEXT) \ $(libEMIS)BIOG_EMIS.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libDEPV)DEPV_DEFN.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libEMIS)LTNG_DEFN.$(OBJEXT) $(libEMIS)MGEMIS.$(OBJEXT) \ @@ -439,7 +438,7 @@ $(libEMIS)LTNG_DEFN.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libEMIS)LUS_DEFN.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libEMIS)MGEMIS.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(libAERO)AEROMET_DATA.$(OBJEXT) $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) \ + $(libAERO)AEROMET_DATA.$(OBJEXT) $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libGRID)PCGRID_DEFN.$(OBJEXT) \ $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) @@ -452,7 +451,7 @@ $(libEMIS)PTBILIN.$(OBJEXT) : \ $(libEMIS)UDTYPES.$(OBJEXT) $(libGRID)VGRD_DEFN.$(OBJEXT) $(libEMIS)SSEMIS.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libAERO)AERO_DATA.$(OBJEXT) $(libAERO)AEROMET_DATA.$(OBJEXT) \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libSTENEX)noop_modules.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libEMIS)STK_EMIS.$(OBJEXT) : \ @@ -461,7 +460,7 @@ $(libEMIS)STK_PRMS.$(OBJEXT) : \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libEMIS)UDTYPES.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libEMIS)tfabove.$(OBJEXT) : \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libEMIS)LUS_DEFN.$(OBJEXT) $(libEMIS)tfbelow.$(OBJEXT) : \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libEMIS)LUS_DEFN.$(OBJEXT) \ @@ -557,13 +556,6 @@ $(libPHOT)opphot.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libGRID)GRID_CONF.$(OBJEXT) $(libPHOT)PHOT_MET_DATA.$(OBJEXT) \ $(libPHOT)PHOT_MOD.$(OBJEXT) $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) -$(libPHOT)phot.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(libAERO)AERO_DATA.$(OBJEXT) $(libPHOT)AERO_PHOTDATA.$(OBJEXT) \ - $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libPHOT)CLOUD_OPTICS.$(OBJEXT) \ - $(libSTENEX)noop_modules.$(OBJEXT) $(libGRID)PCGRID_DEFN.$(OBJEXT) \ - $(libPHOT)PHOT_MET_DATA.$(OBJEXT) $(libPHOT)PHOT_MOD.$(OBJEXT) \ - $(libPHOT)PHOTOLYSIS_ALBEDO.$(OBJEXT) $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) \ - $(libPHOT)SEAS_STRAT_O3_MIN.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libPHOT)PHOT_MET_DATA.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ $(libPHOT)CLOUD_OPTICS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) @@ -620,12 +612,8 @@ $(libUTIL)subhdomain.$(OBJEXT) : \ # vdiff $(libVDIFF)aero_sedv.$(OBJEXT) : \ $(libAERO)AERO_DATA.$(OBJEXT) $(libAERO)AEROMET_DATA.$(OBJEXT) \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) -$(libVDIFF)ASX_DATA_MOD.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT $(ICL)/mpi/PE_COMM.EXT \ - $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ - $(libDEPV)LSM_MOD.$(OBJEXT) $(libSTENEX)noop_modules.$(OBJEXT) \ - $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libVDIFF)conv_cgrid.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) @@ -645,7 +633,7 @@ $(libVDIFF)rddepv.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libVDIFF)SEDIMENTATION.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) \ $(libVDIFF)VDIFF_DIAG.$(OBJEXT) $(libVDIFF)VDIFF_MAP.$(OBJEXT) $(libVDIFF)tri.$(OBJEXT) : \ @@ -657,7 +645,7 @@ $(libVDIFF)VDIFF_MAP.$(OBJEXT) : $(ICL)/emctrl/EMISPRM.EXT \ $(libAERO)AERO_EMIS.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libVDIFF)vdiffproc.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libDEPV)DEPV_DEFN.$(OBJEXT) \ $(libEMIS)EMIS_DEFN.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libDEPV)HGSIM.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ @@ -669,7 +657,7 @@ $(libVDIFF)vdiffproc.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(liblocalCCTM)o3totcol.$(OBJEXT) : \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(liblocalCCTM)vdiffacmx.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libDEPV)DEPV_DEFN.$(OBJEXT) $(libEMIS)EMIS_DEFN.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) \ $(libVDIFF)VDIFF_MAP.$(OBJEXT) @@ -679,3 +667,14 @@ $(liblocalCCTM)PT3D_DEFN.$(OBJEXT) : $(libAERO)AERO_DATA.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(liblocalCCTM)PTMAP.$(OBJEXT) $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) \ $(libEMIS)STK_EMIS.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) +$(liblocalCCTM)phot.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ + $(libAERO)AERO_DATA.$(OBJEXT) $(libPHOT)AERO_PHOTDATA.$(OBJEXT) \ + $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libPHOT)CLOUD_OPTICS.$(OBJEXT) \ + $(libSTENEX)noop_modules.$(OBJEXT) $(libGRID)PCGRID_DEFN.$(OBJEXT) \ + $(libPHOT)PHOT_MET_DATA.$(OBJEXT) $(libPHOT)PHOT_MOD.$(OBJEXT) \ + $(libPHOT)PHOTOLYSIS_ALBEDO.$(OBJEXT) $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) \ + $(libPHOT)SEAS_STRAT_O3_MIN.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) +$(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT $(ICL)/mpi/PE_COMM.EXT \ + $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ + $(libDEPV)LSM_MOD.$(OBJEXT) $(libSTENEX)noop_modules.$(OBJEXT) \ + $(libUTIL)UTILIO_DEFN.$(OBJEXT) diff --git a/src/model/Makefile.in b/src/model/Makefile.in index 0c12a88..d5864b4 100644 --- a/src/model/Makefile.in +++ b/src/model/Makefile.in @@ -188,7 +188,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) \ @@ -222,7 +221,6 @@ am_libCCTM_a_OBJECTS = $(AERO)/libCCTM_a-AERO_DATA.$(OBJEXT) \ $(UTIL)/libCCTM_a-subhdomain.$(OBJEXT) \ $(UTIL)/libCCTM_a-UTILIO_DEFN.$(OBJEXT) \ $(VDIFF)/libCCTM_a-aero_sedv.$(OBJEXT) \ - $(VDIFF)/libCCTM_a-ASX_DATA_MOD.$(OBJEXT) \ $(VDIFF)/libCCTM_a-conv_cgrid.$(OBJEXT) \ $(VDIFF)/libCCTM_a-matrix1.$(OBJEXT) \ $(VDIFF)/libCCTM_a-opddep.$(OBJEXT) \ @@ -237,7 +235,11 @@ am_libCCTM_a_OBJECTS = $(AERO)/libCCTM_a-AERO_DATA.$(OBJEXT) \ $(localCCTM)/libCCTM_a-o3totcol.$(OBJEXT) \ $(localCCTM)/libCCTM_a-vdiffacmx.$(OBJEXT) \ $(localCCTM)/libCCTM_a-PTMAP.$(OBJEXT) \ - $(localCCTM)/libCCTM_a-PT3D_DEFN.$(OBJEXT) + $(localCCTM)/libCCTM_a-PT3D_DEFN.$(OBJEXT) \ + $(localCCTM)/libCCTM_a-phot.$(OBJEXT) \ + $(localCCTM)/libCCTM_a-ASX_DATA_MOD.$(OBJEXT) \ + $(localCCTM)/libCCTM_a-centralized_io_util_module.$(OBJEXT) \ + libCCTM_a_OBJECTS = $(am_libCCTM_a_OBJECTS) AM_V_P = $(am__v_P_@AM_V@) am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) @@ -486,7 +488,7 @@ libCCTM_a_SOURCES = $(AERO)/AERO_DATA.F $(AERO)/aero_depv.F \ $(PA)/PA_DEFN.F $(PA)/pa_update.F $(PHOT)/AERO_PHOTDATA.F \ $(PHOT)/CLOUD_OPTICS.F $(PHOT)/complex_number_module.F90 \ $(PHOT)/CSQY_DATA.F $(PHOT)/OMI_1979_to_2015.dat \ - $(PHOT)/opphot.F $(PHOT)/phot.F $(PHOT)/PHOT_MET_DATA.F \ + $(PHOT)/opphot.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 $(PLRISE)/delta_zs.f \ @@ -504,13 +506,15 @@ libCCTM_a_SOURCES = $(AERO)/AERO_DATA.F $(AERO)/aero_depv.F \ $(STENEX)/noop_util_module.f $(UTIL)/bmatvec.F \ $(UTIL)/findex.f $(UTIL)/get_envlist.f $(UTIL)/setup_logdev.F \ $(UTIL)/subhdomain.F $(UTIL)/UTILIO_DEFN.F \ - $(VDIFF)/aero_sedv.F $(VDIFF)/ASX_DATA_MOD.F \ + $(VDIFF)/aero_sedv.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_DIAG.F \ $(VDIFF)/VDIFF_MAP.F $(VDIFF)/vdiffproc.F \ $(localCCTM)/o3totcol.f $(localCCTM)/vdiffacmx.F \ - $(localCCTM)/PTMAP.F $(localCCTM)/PT3D_DEFN.F + $(localCCTM)/PTMAP.F $(localCCTM)/PT3D_DEFN.F \ + $(localCCTM)/phot.F $(localCCTM)/ASX_DATA_MOD.F \ + $(localCCTM)/centralized_io_util_module.F # local version of CCTM source files localCCTM = $(builddir)/src @@ -883,8 +887,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) \ @@ -981,8 +983,6 @@ $(VDIFF)/$(DEPDIR)/$(am__dirstamp): @: > $(VDIFF)/$(DEPDIR)/$(am__dirstamp) $(VDIFF)/libCCTM_a-aero_sedv.$(OBJEXT): $(VDIFF)/$(am__dirstamp) \ $(VDIFF)/$(DEPDIR)/$(am__dirstamp) -$(VDIFF)/libCCTM_a-ASX_DATA_MOD.$(OBJEXT): $(VDIFF)/$(am__dirstamp) \ - $(VDIFF)/$(DEPDIR)/$(am__dirstamp) $(VDIFF)/libCCTM_a-conv_cgrid.$(OBJEXT): $(VDIFF)/$(am__dirstamp) \ $(VDIFF)/$(DEPDIR)/$(am__dirstamp) $(VDIFF)/libCCTM_a-matrix1.$(OBJEXT): $(VDIFF)/$(am__dirstamp) \ @@ -1022,6 +1022,14 @@ $(localCCTM)/libCCTM_a-PTMAP.$(OBJEXT): $(localCCTM)/$(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-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) + + libCCTM.a: $(libCCTM_a_OBJECTS) $(libCCTM_a_DEPENDENCIES) $(EXTRA_libCCTM_a_DEPENDENCIES) $(AM_V_at)-rm -f libCCTM.a @@ -1525,11 +1533,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 '$(localCCTM)/'`$(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` -$(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.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 '$(localCCTM)/'`$(localCCTM)/centralized_io_util_module.F + +$(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 @@ -1615,11 +1629,11 @@ $(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` -$(VDIFF)/libCCTM_a-ASX_DATA_MOD.o: $(VDIFF)/ASX_DATA_MOD.F - $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(VDIFF)/libCCTM_a-ASX_DATA_MOD.o `test -f '$(VDIFF)/ASX_DATA_MOD.F' || echo '$(srcdir)/'`$(VDIFF)/ASX_DATA_MOD.F +$(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 -$(VDIFF)/libCCTM_a-ASX_DATA_MOD.obj: $(VDIFF)/ASX_DATA_MOD.F - $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(VDIFF)/libCCTM_a-ASX_DATA_MOD.obj `if test -f '$(VDIFF)/ASX_DATA_MOD.F'; then $(CYGPATH_W) '$(VDIFF)/ASX_DATA_MOD.F'; else $(CYGPATH_W) '$(srcdir)/$(VDIFF)/ASX_DATA_MOD.F'; fi` +$(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 @@ -2164,7 +2178,7 @@ $(libAERO)AERO_DATA.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libAERO)aero_depv.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libAERO)AERO_DATA.$(OBJEXT) $(libAERO)AEROMET_DATA.$(OBJEXT) \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ $(libDEPV)MOSAIC_MOD.$(OBJEXT) $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) @@ -2176,7 +2190,7 @@ $(libAERO)aero_driver.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) $(libAERO)SOA_DEFN.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libAERO)AERO_EMIS.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(libAERO)AERO_DATA.$(OBJEXT) $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) \ + $(libAERO)AERO_DATA.$(OBJEXT) $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libEMIS)DUST_EMIS.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libAERO)PRECURSOR_DATA.$(OBJEXT) \ $(liblocalCCTM)PT3D_DEFN.$(OBJEXT) $(liblocalCCTM)PTMAP.$(OBJEXT) \ @@ -2193,7 +2207,7 @@ $(libAERO)aero_subs.$(OBJEXT) : $(ICL)/const/CONST.EXT $(AERO)/isrpia.inc \ $(libAERO)AOD_DEFN.$(OBJEXT) $(libAERO)PRECURSOR_DATA.$(OBJEXT) \ $(libAERO)SOA_DEFN.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libAERO)AOD_DEFN.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(libAERO)AERO_DATA.$(OBJEXT) $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) \ + $(libAERO)AERO_DATA.$(OBJEXT) $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libAERO)getpar.$(OBJEXT) : \ @@ -2222,11 +2236,11 @@ $(libAERO)SOA_DEFN.$(OBJEXT) : \ # biog $(libBIOG)beis3.$(OBJEXT) : \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BIOG_EMIS.$(OBJEXT) + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BIOG_EMIS.$(OBJEXT) $(libBIOG)czangle.$(OBJEXT) : $(ICL)/const/CONST.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libBIOG)hrno.$(OBJEXT) : \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BIOG_EMIS.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BIOG_EMIS.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ $(libSTENEX)noop_modules.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libBIOG)parsline.$(OBJEXT) : \ @@ -2243,7 +2257,7 @@ $(libCLOUD)hlconst.$(OBJEXT) : \ # depv $(libDEPV)ABFLUX_MOD.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ $(libDEPV)MOSAIC_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ @@ -2253,7 +2267,7 @@ $(libDEPV)cgrid_depv.$(OBJEXT) : \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)DEPV_DEFN.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libDEPV)DEPVVARS.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ $(libDEPV)MOSAIC_MOD.$(OBJEXT) $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) \ @@ -2262,13 +2276,13 @@ $(libDEPV)gas_depv_map.$(OBJEXT) : \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libDEPV)DEPVVARS.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)HGSIM.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libDEPV)LSM_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)MOSAIC_MOD.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libDEPV)LSM_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)opdepv_diag.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ @@ -2280,7 +2294,7 @@ $(libDEPV)opdepv_fst.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libDEPV)LSM_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)m3dry.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(libDEPV)ABFLUX_MOD.$(OBJEXT) $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) \ + $(libDEPV)ABFLUX_MOD.$(OBJEXT) $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) \ $(libDEPV)BIDI_MOD.$(OBJEXT) $(libDEPV)DEPVVARS.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libDEPV)HGSIM.$(OBJEXT) \ $(libDEPV)LSM_MOD.$(OBJEXT) $(libDEPV)MOSAIC_MOD.$(OBJEXT) \ @@ -2296,12 +2310,12 @@ $(libEMIS)BIOG_EMIS.$(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) $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) \ + $(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) \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BEIS_DEFN.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BEIS_DEFN.$(OBJEXT) \ $(libEMIS)BIOG_EMIS.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libDEPV)DEPV_DEFN.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libEMIS)LTNG_DEFN.$(OBJEXT) $(libEMIS)MGEMIS.$(OBJEXT) \ @@ -2314,7 +2328,7 @@ $(libEMIS)LTNG_DEFN.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libEMIS)LUS_DEFN.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libEMIS)MGEMIS.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(libAERO)AEROMET_DATA.$(OBJEXT) $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) \ + $(libAERO)AEROMET_DATA.$(OBJEXT) $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libGRID)PCGRID_DEFN.$(OBJEXT) \ $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) @@ -2327,7 +2341,7 @@ $(libEMIS)PTBILIN.$(OBJEXT) : \ $(libEMIS)UDTYPES.$(OBJEXT) $(libGRID)VGRD_DEFN.$(OBJEXT) $(libEMIS)SSEMIS.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libAERO)AERO_DATA.$(OBJEXT) $(libAERO)AEROMET_DATA.$(OBJEXT) \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libSTENEX)noop_modules.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libEMIS)STK_EMIS.$(OBJEXT) : \ @@ -2336,7 +2350,7 @@ $(libEMIS)STK_PRMS.$(OBJEXT) : \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libEMIS)UDTYPES.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libEMIS)tfabove.$(OBJEXT) : \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libEMIS)LUS_DEFN.$(OBJEXT) $(libEMIS)tfbelow.$(OBJEXT) : \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libEMIS)LUS_DEFN.$(OBJEXT) \ @@ -2432,13 +2446,6 @@ $(libPHOT)opphot.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libGRID)GRID_CONF.$(OBJEXT) $(libPHOT)PHOT_MET_DATA.$(OBJEXT) \ $(libPHOT)PHOT_MOD.$(OBJEXT) $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) -$(libPHOT)phot.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(libAERO)AERO_DATA.$(OBJEXT) $(libPHOT)AERO_PHOTDATA.$(OBJEXT) \ - $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libPHOT)CLOUD_OPTICS.$(OBJEXT) \ - $(libSTENEX)noop_modules.$(OBJEXT) $(libGRID)PCGRID_DEFN.$(OBJEXT) \ - $(libPHOT)PHOT_MET_DATA.$(OBJEXT) $(libPHOT)PHOT_MOD.$(OBJEXT) \ - $(libPHOT)PHOTOLYSIS_ALBEDO.$(OBJEXT) $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) \ - $(libPHOT)SEAS_STRAT_O3_MIN.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libPHOT)PHOT_MET_DATA.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ $(libPHOT)CLOUD_OPTICS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) @@ -2495,12 +2502,8 @@ $(libUTIL)subhdomain.$(OBJEXT) : \ # vdiff $(libVDIFF)aero_sedv.$(OBJEXT) : \ $(libAERO)AERO_DATA.$(OBJEXT) $(libAERO)AEROMET_DATA.$(OBJEXT) \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) -$(libVDIFF)ASX_DATA_MOD.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT $(ICL)/mpi/PE_COMM.EXT \ - $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ - $(libDEPV)LSM_MOD.$(OBJEXT) $(libSTENEX)noop_modules.$(OBJEXT) \ - $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libVDIFF)conv_cgrid.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) @@ -2520,7 +2523,7 @@ $(libVDIFF)rddepv.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libVDIFF)SEDIMENTATION.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) \ $(libVDIFF)VDIFF_DIAG.$(OBJEXT) $(libVDIFF)VDIFF_MAP.$(OBJEXT) $(libVDIFF)tri.$(OBJEXT) : \ @@ -2532,7 +2535,7 @@ $(libVDIFF)VDIFF_MAP.$(OBJEXT) : $(ICL)/emctrl/EMISPRM.EXT \ $(libAERO)AERO_EMIS.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libVDIFF)vdiffproc.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libDEPV)DEPV_DEFN.$(OBJEXT) \ $(libEMIS)EMIS_DEFN.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libDEPV)HGSIM.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ @@ -2544,7 +2547,7 @@ $(libVDIFF)vdiffproc.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(liblocalCCTM)o3totcol.$(OBJEXT) : \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(liblocalCCTM)vdiffacmx.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libDEPV)DEPV_DEFN.$(OBJEXT) $(libEMIS)EMIS_DEFN.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) \ $(libVDIFF)VDIFF_MAP.$(OBJEXT) @@ -2554,7 +2557,17 @@ $(liblocalCCTM)PT3D_DEFN.$(OBJEXT) : $(libAERO)AERO_DATA.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(liblocalCCTM)PTMAP.$(OBJEXT) $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) \ $(libEMIS)STK_EMIS.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) - +$(liblocalCCTM)phot.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ + $(libAERO)AERO_DATA.$(OBJEXT) $(libPHOT)AERO_PHOTDATA.$(OBJEXT) \ + $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libPHOT)CLOUD_OPTICS.$(OBJEXT) \ + $(libSTENEX)noop_modules.$(OBJEXT) $(libGRID)PCGRID_DEFN.$(OBJEXT) \ + $(libPHOT)PHOT_MET_DATA.$(OBJEXT) $(libPHOT)PHOT_MOD.$(OBJEXT) \ + $(libPHOT)PHOTOLYSIS_ALBEDO.$(OBJEXT) $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) \ + $(libPHOT)SEAS_STRAT_O3_MIN.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) +$(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT $(ICL)/mpi/PE_COMM.EXT \ + $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ + $(libDEPV)LSM_MOD.$(OBJEXT) $(libSTENEX)noop_modules.$(OBJEXT) \ + $(libUTIL)UTILIO_DEFN.$(OBJEXT) # Tell versions [3.59,3.63) of GNU make to not export all variables. # Otherwise a system limit (for SysV at least) may be exceeded. .NOEXPORT: From f1d72d18346a32a0809aa0b1f7a2e58a183d4e98 Mon Sep 17 00:00:00 2001 From: "Patrick.C.Campbell@noaa.gov" Date: Wed, 16 Feb 2022 21:59:34 +0000 Subject: [PATCH 05/90] Added new canopy variables to AQM shared components. --- src/shr/aqm_methods.F90 | 92 +++++++++++++++++++++++++++++++++++++++ src/shr/aqm_state_mod.F90 | 13 +++++- 2 files changed, 104 insertions(+), 1 deletion(-) diff --git a/src/shr/aqm_methods.F90 b/src/shr/aqm_methods.F90 index 656ce86..c8624b0 100644 --- a/src/shr/aqm_methods.F90 +++ b/src/shr/aqm_methods.F90 @@ -736,6 +736,98 @@ logical function interpx( fname, vname, pname, & buffer(k) = 0.01 * stateIn % zorl(c,r) end do end do + + ! canopy variables + case ("FCH") + !test forest canopy height set to 10 m + ! p2d => stateIn % cfch + k = 0 + do r = row0, row1 + do c = col0, col1 + k = k + 1 + buffer(k) = ( 0.0 * stateIn % zorl(c,r) ) + 10.0 + end do + end do + case ("FRT") + !test grid cell forest fraction to 0.5 + ! p2d => stateIn % cfrt + k = 0 + do r = row0, row1 + do c = col0, col1 + k = k + 1 + buffer(k) = ( 0.0 * stateIn % zorl(c,r) ) + 0.5 + end do + end do + case ("CLU") + !test forest clumping index set to 0.5 (spherical leaf distribution) + ! p2d => stateIn % cclu + k = 0 + do r = row0, row1 + do c = col0, col1 + k = k + 1 + buffer(k) = ( 0.0 * stateIn % zorl(c,r) ) + 0.5 !test set to 0.5 + end do + end do + case ("POPU") + !test pop. density set to 10000 people/10km2 + ! p2d => stateIn % cpopu + k = 0 + do r = row0, row1 + do c = col0, col1 + k = k + 1 + buffer(k) = ( 0.0 * stateIn % zorl(c,r) ) + 10000.0 + end do + end do + case ("LAIE") + !test new ECCC LAI set to 4 + ! p2d => stateIn % claie + k = 0 + do r = row0, row1 + do c = col0, col1 + k = k + 1 + buffer(k) = ( 0.0 * stateIn % zorl(c,r) ) + 4.0 + end do + end do + case ("C1R") + !test new ECCC cumulative LAI fraction 1 (FCH to 0.75FCH) set to 0.5 + ! p2d => stateIn % cc1r + k = 0 + do r = row0, row1 + do c = col0, col1 + k = k + 1 + buffer(k) = ( 0.0 * stateIn % zorl(c,r) ) + 0.5 + end do + end do + case ("C2R") + !test new ECCC cumulative LAI fraction 2 (FCH to 0.5FCH) set to 0.7 + ! p2d => stateIn % cc2r + k = 0 + do r = row0, row1 + do c = col0, col1 + k = k + 1 + buffer(k) = ( 0.0 * stateIn % zorl(c,r) ) + 0.7 + end do + end do + case ("C3R") + !test new ECCC cumulative LAI fraction 3 (FCH to 0.35FCH) set to 0.9 + ! p2d => stateIn % cc3r + k = 0 + do r = row0, row1 + do c = col0, col1 + k = k + 1 + buffer(k) = ( 0.0 * stateIn % zorl(c,r) ) + 0.9 + end do + end do + case ("C4R") + !test new ECCC cumulative LAI fraction 4 (FCH to 0.20FCH) set to 0.95 + ! p2d => stateIn % cc4r + k = 0 + do r = row0, row1 + do c = col0, col1 + k = k + 1 + buffer(k) = ( 0.0 * stateIn % zorl(c,r) ) + 0.95 + end do + end do case default ! return end select diff --git a/src/shr/aqm_state_mod.F90 b/src/shr/aqm_state_mod.F90 index fc2c194..958d601 100644 --- a/src/shr/aqm_state_mod.F90 +++ b/src/shr/aqm_state_mod.F90 @@ -45,9 +45,20 @@ 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() - + end type aqm_state_type public From c8a294c4d3663bfe97205649681a4d8c216986fd Mon Sep 17 00:00:00 2001 From: "Patrick.C.Campbell@noaa.gov" Date: Wed, 16 Feb 2022 22:14:24 +0000 Subject: [PATCH 06/90] Added placeholder new canopy variables to aqm cap for fv3. --- src/aqm_cap.F90 | 10 ++++++++ src/aqm_comp_mod.F90 | 55 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 65 insertions(+) diff --git a/src/aqm_cap.F90 b/src/aqm_cap.F90 index bfbee4a..d146465 100644 --- a/src/aqm_cap.F90 +++ b/src/aqm_cap.F90 @@ -13,6 +13,7 @@ module AQM ! -- import fields integer, parameter :: importFieldCount = 35 +! integer, parameter :: importFieldCount = 44 !with canopy character(len=*), dimension(importFieldCount), parameter :: & importFieldNames = (/ & "canopy_moisture_storage ", & @@ -50,6 +51,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 788fac9..75b182c 100644 --- a/src/aqm_comp_mod.F90 +++ b/src/aqm_comp_mod.F90 @@ -584,6 +584,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 From 5d73df1bb677c0e9b847188628126cea96e88dcf Mon Sep 17 00:00:00 2001 From: "Patrick.C.Campbell@noaa.gov" Date: Thu, 17 Feb 2022 15:13:49 +0000 Subject: [PATCH 07/90] Added conditional CANOPY_SHADE environment variable/logical. --- src/model/src/ASX_DATA_MOD.F | 26 +++++++++++++++++++++++++- src/model/src/phot.F | 28 +++++++++++++++++++++++++--- src/shr/aqm_config_mod.F90 | 1 + src/shr/aqm_methods.F90 | 4 ++++ 4 files changed, 55 insertions(+), 4 deletions(-) diff --git a/src/model/src/ASX_DATA_MOD.F b/src/model/src/ASX_DATA_MOD.F index 197be5f..251ceca 100755 --- a/src/model/src/ASX_DATA_MOD.F +++ b/src/model/src/ASX_DATA_MOD.F @@ -120,6 +120,13 @@ Module ASX_DATA_MOD 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) + +! Canopy in-line control + CHARACTER( 20 ), SAVE :: CTM_CANOPY_SHADE = 'CTM_CANOPY_SHADE ' ! env var for in-line + LOGICAL, SAVE :: CANOPY_SHADE ! flag in-lining canopy shading + PUBLIC CANOPY_SHADE + PRIVATE + !> Inline Canopy Processes Real, Allocatable :: FCH ( :,: ) ! Forest Canopy Height (m) Real, Allocatable :: FRT ( :,: ) ! Forest Fraction @@ -441,6 +448,20 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) C----------------------------------------------------------------------- +C In-line canopy shading option? (default = false) + + CANOPY_SHADE = ENVYN( 'CTM_CANOPY_SHADE', + & 'Flag for in-line canopy shading', + & .FALSE., IOS ) + + IF ( CANOPY_SHADE ) THEN + XMSG = 'Using in-line canopy shading option' + CALL M3MSG2( XMSG ) + ELSE + RETURN + END IF + + LOGDEV = INIT3() If( MET_INITIALIZED )Return @@ -563,6 +584,7 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) Grid_Data%WRES = 0.0 Grid_Data%BSLP = 0.0 + If ( CANOPY_SHADE ) Then ALLOCATE( Met_Data%FCH ( NCOLS,NROWS ), & Met_Data%FRT ( NCOLS,NROWS ), & Met_Data%CLU ( NCOLS,NROWS ), @@ -577,6 +599,7 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) XMSG = 'Failure allocating Canopy Shade variables' Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) End If + End If ALLOCATE( Mosaic_Data%USTAR ( NCOLS,NROWS,n_lufrac ), & Mosaic_Data%LAI ( NCOLS,NROWS,n_lufrac ), @@ -1054,6 +1077,7 @@ Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) End If C Canopy vars + If ( CANOPY_SHADE ) Then VNAME = 'FCH' If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2,1,1, @@ -1125,7 +1149,7 @@ Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) 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, diff --git a/src/model/src/phot.F b/src/model/src/phot.F index f6722cc..5a2c80b 100644 --- a/src/model/src/phot.F +++ b/src/model/src/phot.F @@ -293,6 +293,11 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) LOGICAL :: NEW_PROFILE ! Has atmospheric temperature and density profile changed? LOGICAL :: DARK ! Are this processor's cells in darkness? +! Canopy in-line control + CHARACTER( 20 ), SAVE :: CTM_CANOPY_SHADE = 'CTM_CANOPY_SHADE ' ! env var for in-line + LOGICAL, SAVE :: CANOPY_SHADE ! flag in-lining canopy shading + PUBLIC CANOPY_SHADE + PRIVATE ! Canopy arrays REAL, ALLOCATABLE :: RJ_CORR_C1R ( :, :) ! canopy shading correction to J-values (hc to 0.75*hc) REAL, ALLOCATABLE :: RJ_CORR_C2R ( :, :) ! canopy shading correction to J-values (hc to 0.50*hc) @@ -349,6 +354,19 @@ END SUBROUTINE O3TOTCOL IF ( FIRSTIME ) THEN +C In-line canopy shading option? (default = false) + + CANOPY_SHADE = ENVYN( 'CTM_CANOPY_SHADE', + & 'Flag for in-line canopy shading', + & .FALSE., IOS ) + + IF ( CANOPY_SHADE ) THEN + XMSG = 'Using in-line canopy shading option' + CALL M3MSG2( XMSG ) + ELSE + RETURN + END IF + FIRSTIME = .FALSE. LOGDEV = INIT3() @@ -397,10 +415,11 @@ END SUBROUTINE O3TOTCOL CALL INIT_CLOUD_OPTICS( ) !...Allocate and initialize new canopy arrays - ALLOCATE( RJ_CORRX ( MAXCAN ) ) - ALLOCATE( ZCANX ( MAXCAN ) ) + IF ( CANOPY_SHADE ) THEN + ALLOCATE( RJ_CORRX ( MAXCAN ) ) + ALLOCATE( ZCANX ( MAXCAN ) ) - ALLOCATE( RJ_CORR_C1R ( NCOLS, NROWS ), + ALLOCATE( RJ_CORR_C1R ( NCOLS, NROWS ), & RJ_CORR_C2R ( NCOLS, NROWS ), & RJ_CORR_C3R ( NCOLS, NROWS ), & RJ_CORR_C4R ( NCOLS, NROWS ), @@ -419,6 +438,7 @@ END SUBROUTINE O3TOTCOL RJ_CORR_C4R=0.0 RJ_CORR_BOT=0.0 RJ_CORR=0.0 + END IF !...Initialize Surface albedo method @@ -997,6 +1017,7 @@ END SUBROUTINE O3TOTCOL !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) !conditions for grid cells that do NOT have !a continuous forest canopy IF ( Met_Data%LAIE( COL,ROW ) .LT. 0.1 @@ -1102,6 +1123,7 @@ END SUBROUTINE O3TOTCOL ! RJ( COL,ROW, 1, : ) = ( RJ( COL,ROW, 1, : ) ! & + (RJ( COL,ROW, 1, : )*RJ_CORR( COL,ROW )) )/2.0 END IF !contigous canopy conditions + END IF !canopy shade IF ( JTIME_CHK ) THEN ! compute clear sky reflection and transmission coefficients IF ( ANY( CLOUDS ) ) THEN diff --git a/src/shr/aqm_config_mod.F90 b/src/shr/aqm_config_mod.F90 index 84fc163..5eb35e8 100644 --- a/src/shr/aqm_config_mod.F90 +++ b/src/shr/aqm_config_mod.F90 @@ -35,6 +35,7 @@ module aqm_config_mod logical :: init_conc = .false. logical :: run_aero = .false. logical :: verbose = .false. + logical :: canopy_yn = .false. type(aqm_species_type), pointer :: species => null() end type aqm_config_type diff --git a/src/shr/aqm_methods.F90 b/src/shr/aqm_methods.F90 index c8624b0..1115240 100644 --- a/src/shr/aqm_methods.F90 +++ b/src/shr/aqm_methods.F90 @@ -330,6 +330,10 @@ logical function envyn(name, description, defaultval, status) envyn = associated(em) case ('CTM_GRAV_SETL') envyn = .false. + case ('CTM_CANOPY_SHADE') + envyn = config % canopy_yn !default (false) +! Just hard code to true right now...wait for runtime capability + envyn = .true. case ('INITIAL_RUN') envyn = .true. case default From 4a5f99ec4dd9d04a1147b3cd3adaff039f497ea4 Mon Sep 17 00:00:00 2001 From: "Patrick.C.Campbell@noaa.gov" Date: Thu, 17 Feb 2022 16:04:26 +0000 Subject: [PATCH 08/90] Updated conditional canopy_yn environment and logicals. --- examples/aqm.rc | 4 ++++ src/shr/aqm_config_mod.F90 | 15 +++++++++++++++ src/shr/aqm_methods.F90 | 4 ++-- 3 files changed, 21 insertions(+), 2 deletions(-) diff --git a/examples/aqm.rc b/examples/aqm.rc index e7e018c..0a3af4a 100644 --- a/examples/aqm.rc +++ b/examples/aqm.rc @@ -34,6 +34,10 @@ omi_data: /scratch1/NCEPDEV/nems/Raffaele.Montuoro/dev/aqm/epa/data/omi_cmaq_ # - set to true for cold start init_concentrations: true +# Run inline canopy effects +# +canopy_yn: false + # # Run aerosol module # diff --git a/src/shr/aqm_config_mod.F90 b/src/shr/aqm_config_mod.F90 index 5eb35e8..27a01fd 100644 --- a/src/shr/aqm_config_mod.F90 +++ b/src/shr/aqm_config_mod.F90 @@ -175,6 +175,14 @@ subroutine aqm_config_read(model, config, rc) rcToReturn=rc)) & return ! bail out + 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 + ! -- microphysics tracer map call ESMF_ConfigGetAttribute(cf, config % mp_map, & label="mp_tracer_map:", rc=localrc) @@ -485,6 +493,13 @@ subroutine aqm_config_log(config, name, rc) call ESMF_LogWrite(trim(name) // ": config: read: ctm_wb_dust: false", & ESMF_LOGMSG_INFO, rc=localrc) end if + if (config % canopy_yn) then + call ESMF_LogWrite(trim(name) // ": config: read: canopy_yn: true", & + ESMF_LOGMSG_INFO, rc=localrc) + else + call ESMF_LogWrite(trim(name) // ": config: read: canopy_yn: false", & + ESMF_LOGMSG_INFO, rc=localrc) + end if if (config % run_aero) then call ESMF_LogWrite(trim(name) // ": config: read: run_aerosol: true", & ESMF_LOGMSG_INFO, rc=localrc) diff --git a/src/shr/aqm_methods.F90 b/src/shr/aqm_methods.F90 index 1115240..72733cd 100644 --- a/src/shr/aqm_methods.F90 +++ b/src/shr/aqm_methods.F90 @@ -332,8 +332,6 @@ logical function envyn(name, description, defaultval, status) envyn = .false. case ('CTM_CANOPY_SHADE') envyn = config % canopy_yn !default (false) -! Just hard code to true right now...wait for runtime capability - envyn = .true. case ('INITIAL_RUN') envyn = .true. case default @@ -742,6 +740,7 @@ logical function interpx( fname, vname, pname, & end do ! canopy variables + if (config % ctm_wb_dust) then case ("FCH") !test forest canopy height set to 10 m ! p2d => stateIn % cfch @@ -832,6 +831,7 @@ logical function interpx( fname, vname, pname, & buffer(k) = ( 0.0 * stateIn % zorl(c,r) ) + 0.95 end do end do + end if case default ! return end select From 8d6af39b63a9cf8bc6775c275a75ad26d81614d4 Mon Sep 17 00:00:00 2001 From: "Patrick.C.Campbell@noaa.gov" Date: Thu, 17 Feb 2022 17:43:32 +0000 Subject: [PATCH 09/90] Fixed bugs. --- src/model/Makefile.in | 4 ++-- src/model/src/ASX_DATA_MOD.F | 15 ++++++++------- src/model/src/phot.F | 4 ++-- src/shr/aqm_methods.F90 | 2 -- 4 files changed, 12 insertions(+), 13 deletions(-) diff --git a/src/model/Makefile.in b/src/model/Makefile.in index d5864b4..5ae221b 100644 --- a/src/model/Makefile.in +++ b/src/model/Makefile.in @@ -1540,10 +1540,10 @@ $(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 '$(localCCTM)/'`$(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 '$(localCCTM)/'`$(localCCTM)/centralized_io_util_module.F $(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` + $(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 diff --git a/src/model/src/ASX_DATA_MOD.F b/src/model/src/ASX_DATA_MOD.F index 251ceca..47e6904 100755 --- a/src/model/src/ASX_DATA_MOD.F +++ b/src/model/src/ASX_DATA_MOD.F @@ -121,12 +121,6 @@ Module ASX_DATA_MOD Real, Allocatable :: PBL ( :,: ) ! pbl height (m) Real, Allocatable :: NACL_EMIS( :,: ) ! NACL mass emission rate of particles with d <10 um (g/m2/s) -! Canopy in-line control - CHARACTER( 20 ), SAVE :: CTM_CANOPY_SHADE = 'CTM_CANOPY_SHADE ' ! env var for in-line - LOGICAL, SAVE :: CANOPY_SHADE ! flag in-lining canopy shading - PUBLIC CANOPY_SHADE - PRIVATE - !> Inline Canopy Processes Real, Allocatable :: FCH ( :,: ) ! Forest Canopy Height (m) Real, Allocatable :: FRT ( :,: ) ! Forest Fraction @@ -138,7 +132,6 @@ Module ASX_DATA_MOD Real, Allocatable :: C3R ( :,: ) ! cumulative LAI fraction hc to 0.35 * hc Real, Allocatable :: C4R ( :,: ) ! cumulative LAI fraction hc to 0.20 * hc - !> U and V wind components on the cross grid points Real, Allocatable :: UWIND ( :,:,: ) ! [m/s] Real, Allocatable :: VWIND ( :,:,: ) ! [m/s] @@ -400,6 +393,14 @@ Module ASX_DATA_MOD 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. +! Canopy in-line control + CHARACTER( 20 ), SAVE :: CTM_CANOPY_SHADE = 'CTM_CANOPY_SHADE '! env var for in-line + LOGICAL, SAVE :: CANOPY_SHADE ! flag in-lining canopy shading + PUBLIC CANOPY_SHADE + PRIVATE + + INTEGER IOS ! i/o and allocate memory status + CONTAINS C======================================================================= diff --git a/src/model/src/phot.F b/src/model/src/phot.F index 5a2c80b..122ea48 100644 --- a/src/model/src/phot.F +++ b/src/model/src/phot.F @@ -296,8 +296,6 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) ! Canopy in-line control CHARACTER( 20 ), SAVE :: CTM_CANOPY_SHADE = 'CTM_CANOPY_SHADE ' ! env var for in-line LOGICAL, SAVE :: CANOPY_SHADE ! flag in-lining canopy shading - PUBLIC CANOPY_SHADE - PRIVATE ! Canopy arrays REAL, ALLOCATABLE :: RJ_CORR_C1R ( :, :) ! canopy shading correction to J-values (hc to 0.75*hc) REAL, ALLOCATABLE :: RJ_CORR_C2R ( :, :) ! canopy shading correction to J-values (hc to 0.50*hc) @@ -341,6 +339,8 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) REAL, ALLOCATABLE, SAVE :: TAU_AERO ( :,:,:,: ) ! aerosol optical depth REAL, ALLOCATABLE, SAVE :: ACTINIC_FX( :,:,:,: ) ! net actinic flux [watts/m**2] + INTEGER IOS ! i/o and allocate memory status + INTERFACE SUBROUTINE O3TOTCOL ( LATITUDE, LONGITUDE, JDATE, OZONE ) INTEGER, INTENT( IN ) :: JDATE ! Julian day of the year (yyyyddd) diff --git a/src/shr/aqm_methods.F90 b/src/shr/aqm_methods.F90 index 72733cd..c23ee5b 100644 --- a/src/shr/aqm_methods.F90 +++ b/src/shr/aqm_methods.F90 @@ -740,7 +740,6 @@ logical function interpx( fname, vname, pname, & end do ! canopy variables - if (config % ctm_wb_dust) then case ("FCH") !test forest canopy height set to 10 m ! p2d => stateIn % cfch @@ -831,7 +830,6 @@ logical function interpx( fname, vname, pname, & buffer(k) = ( 0.0 * stateIn % zorl(c,r) ) + 0.95 end do end do - end if case default ! return end select From d906997600e5199bb70ee0a6f52a3f1500f67c20 Mon Sep 17 00:00:00 2001 From: "Patrick.C.Campbell@noaa.gov" Date: Thu, 17 Feb 2022 19:03:53 +0000 Subject: [PATCH 10/90] Fixed more bugs. --- src/model/src/ASX_DATA_MOD.F | 38 +++++++++++++++--------------------- src/model/src/phot.F | 4 ++-- 2 files changed, 18 insertions(+), 24 deletions(-) diff --git a/src/model/src/ASX_DATA_MOD.F b/src/model/src/ASX_DATA_MOD.F index 47e6904..f2f8769 100755 --- a/src/model/src/ASX_DATA_MOD.F +++ b/src/model/src/ASX_DATA_MOD.F @@ -287,6 +287,11 @@ Module ASX_DATA_MOD Real, Pointer, Private :: BUFF2D( :,: ) ! 2D temp var Real, Pointer, Private :: BUFF3D( :,:,: ) ! 3D temp var +! Canopy in-line 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 + 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/ @@ -393,14 +398,6 @@ Module ASX_DATA_MOD 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. -! Canopy in-line control - CHARACTER( 20 ), SAVE :: CTM_CANOPY_SHADE = 'CTM_CANOPY_SHADE '! env var for in-line - LOGICAL, SAVE :: CANOPY_SHADE ! flag in-lining canopy shading - PUBLIC CANOPY_SHADE - PRIVATE - - INTEGER IOS ! i/o and allocate memory status - CONTAINS C======================================================================= @@ -449,20 +446,6 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) C----------------------------------------------------------------------- -C In-line canopy shading option? (default = false) - - CANOPY_SHADE = ENVYN( 'CTM_CANOPY_SHADE', - & 'Flag for in-line canopy shading', - & .FALSE., IOS ) - - IF ( CANOPY_SHADE ) THEN - XMSG = 'Using in-line canopy shading option' - CALL M3MSG2( XMSG ) - ELSE - RETURN - END IF - - LOGDEV = INIT3() If( MET_INITIALIZED )Return @@ -585,6 +568,17 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) Grid_Data%WRES = 0.0 Grid_Data%BSLP = 0.0 + 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 ) + ELSE + RETURN + END IF + If ( CANOPY_SHADE ) Then ALLOCATE( Met_Data%FCH ( NCOLS,NROWS ), & Met_Data%FRT ( NCOLS,NROWS ), diff --git a/src/model/src/phot.F b/src/model/src/phot.F index 122ea48..7514734 100644 --- a/src/model/src/phot.F +++ b/src/model/src/phot.F @@ -339,7 +339,7 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) REAL, ALLOCATABLE, SAVE :: TAU_AERO ( :,:,:,: ) ! aerosol optical depth REAL, ALLOCATABLE, SAVE :: ACTINIC_FX( :,:,:,: ) ! net actinic flux [watts/m**2] - INTEGER IOS ! i/o and allocate memory status + INTEGER IOSX ! i/o and allocate memory status INTERFACE SUBROUTINE O3TOTCOL ( LATITUDE, LONGITUDE, JDATE, OZONE ) @@ -358,7 +358,7 @@ END SUBROUTINE O3TOTCOL CANOPY_SHADE = ENVYN( 'CTM_CANOPY_SHADE', & 'Flag for in-line canopy shading', - & .FALSE., IOS ) + & .FALSE., IOSX ) IF ( CANOPY_SHADE ) THEN XMSG = 'Using in-line canopy shading option' From bb85b5ef09d1d6d4ee71bb89cd167b9d19593d39 Mon Sep 17 00:00:00 2001 From: "Patrick.C.Campbell@noaa.gov" Date: Thu, 24 Feb 2022 15:53:44 +0000 Subject: [PATCH 11/90] Removed "RETURN" bug and added diagnostic prints. --- src/model/src/ASX_DATA_MOD.F | 1 - src/model/src/phot.F | 19 ++++++++++++------- 2 files changed, 12 insertions(+), 8 deletions(-) diff --git a/src/model/src/ASX_DATA_MOD.F b/src/model/src/ASX_DATA_MOD.F index f2f8769..31ec03e 100755 --- a/src/model/src/ASX_DATA_MOD.F +++ b/src/model/src/ASX_DATA_MOD.F @@ -576,7 +576,6 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) XMSG = 'Using in-line canopy shading option' CALL M3MSG2( XMSG ) ELSE - RETURN END IF If ( CANOPY_SHADE ) Then diff --git a/src/model/src/phot.F b/src/model/src/phot.F index 7514734..d31a893 100644 --- a/src/model/src/phot.F +++ b/src/model/src/phot.F @@ -364,7 +364,6 @@ END SUBROUTINE O3TOTCOL XMSG = 'Using in-line canopy shading option' CALL M3MSG2( XMSG ) ELSE - RETURN END IF FIRSTIME = .FALSE. @@ -1018,6 +1017,12 @@ END SUBROUTINE O3TOTCOL !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 @@ -1106,17 +1111,17 @@ END SUBROUTINE O3TOTCOL 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) + 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 ) + 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 From 07e3800d645b2d65358b8fe02e8a1648dfc86983 Mon Sep 17 00:00:00 2001 From: "Patrick.C.Campbell@noaa.gov" Date: Thu, 24 Feb 2022 16:40:40 +0000 Subject: [PATCH 12/90] Removed RETURN bug. --- src/model/src/ASX_DATA_MOD.F | 1 - src/model/src/phot.F | 1 - 2 files changed, 2 deletions(-) diff --git a/src/model/src/ASX_DATA_MOD.F b/src/model/src/ASX_DATA_MOD.F index 31ec03e..df72097 100755 --- a/src/model/src/ASX_DATA_MOD.F +++ b/src/model/src/ASX_DATA_MOD.F @@ -575,7 +575,6 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) IF ( CANOPY_SHADE ) THEN XMSG = 'Using in-line canopy shading option' CALL M3MSG2( XMSG ) - ELSE END IF If ( CANOPY_SHADE ) Then diff --git a/src/model/src/phot.F b/src/model/src/phot.F index d31a893..af05bc3 100644 --- a/src/model/src/phot.F +++ b/src/model/src/phot.F @@ -363,7 +363,6 @@ END SUBROUTINE O3TOTCOL IF ( CANOPY_SHADE ) THEN XMSG = 'Using in-line canopy shading option' CALL M3MSG2( XMSG ) - ELSE END IF FIRSTIME = .FALSE. From 685de08d2e8d234b13720b18a311b51bed92bc70 Mon Sep 17 00:00:00 2001 From: "Patrick.C.Campbell@noaa.gov" Date: Mon, 28 Feb 2022 22:44:20 +0000 Subject: [PATCH 13/90] Added debug statements --- src/shr/aqm_methods.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/shr/aqm_methods.F90 b/src/shr/aqm_methods.F90 index c23ee5b..ac63288 100644 --- a/src/shr/aqm_methods.F90 +++ b/src/shr/aqm_methods.F90 @@ -644,6 +644,7 @@ logical function interpx( fname, vname, pname, & file=__FILE__, line=__LINE__)) return select case (trim(vname)) + print*,'vname_diag_test = ', vname case ("HFX") p2d => stateIn % hfx case ("LAI") @@ -748,6 +749,7 @@ logical function interpx( fname, vname, pname, & do c = col0, col1 k = k + 1 buffer(k) = ( 0.0 * stateIn % zorl(c,r) ) + 10.0 + print*,'diag_fch_test = ', buffer(k) end do end do case ("FRT") From b00f1c810e38c3a40174f68eb1f2ceb9b995d025 Mon Sep 17 00:00:00 2001 From: "Patrick.C.Campbell@noaa.gov" Date: Tue, 1 Mar 2022 01:19:35 +0000 Subject: [PATCH 14/90] Removed debug prints and added canopy variables in DESC3. --- src/shr/aqm_methods.F90 | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/src/shr/aqm_methods.F90 b/src/shr/aqm_methods.F90 index ac63288..9621b3b 100644 --- a/src/shr/aqm_methods.F90 +++ b/src/shr/aqm_methods.F90 @@ -148,7 +148,7 @@ LOGICAL FUNCTION DESC3( FNAME ) ELSE IF ( TRIM( FNAME ) .EQ. TRIM( MET_CRO_2D ) ) THEN - NVARS3D = 31 + NVARS3D = 40 VNAME3D( 1:NVARS3D ) = & (/ 'PRSFC ', 'USTAR ', & 'WSTAR ', 'PBL ', & @@ -165,7 +165,12 @@ LOGICAL FUNCTION DESC3( FNAME ) 'SLTYP ', 'Q2 ', & 'SEAICE ', 'SOIM1 ', & 'SOIM2 ', 'SOIT1 ', & - 'SOIT2 ', 'LH ' /) + 'SOIT2 ', 'LH ', & + 'FCH ', 'FRT ', & + 'CLU ', 'POPU ', & + 'LAIE ', 'C1R ', & + 'C2R ', 'C3R ', & + 'C4R ' /) UNITS3D( 1:NVARS3D ) = & (/ 'Pascal ', 'M/S ', & 'M/S ', 'M ', & @@ -182,7 +187,12 @@ LOGICAL FUNCTION DESC3( FNAME ) '- ', 'KG/KG ', & 'FRACTION ', 'M**3/M**3 ', & 'M**3/M**3 ', 'K ', & - 'K ', 'WATTS/M**2 ' /) + 'K ', 'WATTS/M**2 ', & + 'M ', 'NO UNIT ', & + 'NO UNIT ', 'PEOPLE/KM**2 ', & + 'NO UNIT ', 'NO UNIT ', & + 'NO UNIT ', 'NO UNIT ', & + 'NO UNIT ' /) ELSE IF ( TRIM( FNAME ) .EQ. TRIM( MET_CRO_3D ) ) THEN @@ -644,7 +654,6 @@ logical function interpx( fname, vname, pname, & file=__FILE__, line=__LINE__)) return select case (trim(vname)) - print*,'vname_diag_test = ', vname case ("HFX") p2d => stateIn % hfx case ("LAI") @@ -749,7 +758,6 @@ logical function interpx( fname, vname, pname, & do c = col0, col1 k = k + 1 buffer(k) = ( 0.0 * stateIn % zorl(c,r) ) + 10.0 - print*,'diag_fch_test = ', buffer(k) end do end do case ("FRT") From 846e1dc80844b6552c455a6824ae9c479994e29e Mon Sep 17 00:00:00 2001 From: "Patrick.C.Campbell@noaa.gov" Date: Tue, 1 Mar 2022 03:05:08 +0000 Subject: [PATCH 15/90] Added some debug prints. --- src/model/src/ASX_DATA_MOD.F | 2 +- src/shr/aqm_methods.F90 | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/src/model/src/ASX_DATA_MOD.F b/src/model/src/ASX_DATA_MOD.F index df72097..26b1189 100755 --- a/src/model/src/ASX_DATA_MOD.F +++ b/src/model/src/ASX_DATA_MOD.F @@ -576,7 +576,7 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) XMSG = 'Using in-line canopy shading option' CALL M3MSG2( XMSG ) END IF - + WRITE(*,*) 'CANOPY_SHADE_Check = ', CANOPY_SHADE If ( CANOPY_SHADE ) Then ALLOCATE( Met_Data%FCH ( NCOLS,NROWS ), & Met_Data%FRT ( NCOLS,NROWS ), diff --git a/src/shr/aqm_methods.F90 b/src/shr/aqm_methods.F90 index 9621b3b..0040125 100644 --- a/src/shr/aqm_methods.F90 +++ b/src/shr/aqm_methods.F90 @@ -758,6 +758,7 @@ logical function interpx( fname, vname, pname, & do c = col0, col1 k = k + 1 buffer(k) = ( 0.0 * stateIn % zorl(c,r) ) + 10.0 + WRITE(*,*) 'FCH_Check = ', buffer(k) end do end do case ("FRT") From a816991c8143995cf4e334a196448adce7285237 Mon Sep 17 00:00:00 2001 From: "Patrick.C.Campbell@noaa.gov" Date: Wed, 2 Mar 2022 18:37:14 +0000 Subject: [PATCH 16/90] Updated debug statemetns --- src/model/src/ASX_DATA_MOD.F | 3 +-- src/model/src/phot.F | 5 +++-- src/shr/aqm_methods.F90 | 1 + 3 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/model/src/ASX_DATA_MOD.F b/src/model/src/ASX_DATA_MOD.F index 26b1189..7970b83 100755 --- a/src/model/src/ASX_DATA_MOD.F +++ b/src/model/src/ASX_DATA_MOD.F @@ -573,10 +573,9 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) & .FALSE., IOSX ) IF ( CANOPY_SHADE ) THEN - XMSG = 'Using in-line canopy shading option' + XMSG = 'Using in-line canopy shading option-ASX_DATA_MOD' CALL M3MSG2( XMSG ) END IF - WRITE(*,*) 'CANOPY_SHADE_Check = ', CANOPY_SHADE If ( CANOPY_SHADE ) Then ALLOCATE( Met_Data%FCH ( NCOLS,NROWS ), & Met_Data%FRT ( NCOLS,NROWS ), diff --git a/src/model/src/phot.F b/src/model/src/phot.F index af05bc3..b3be964 100644 --- a/src/model/src/phot.F +++ b/src/model/src/phot.F @@ -295,7 +295,8 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) ! Canopy in-line control CHARACTER( 20 ), SAVE :: CTM_CANOPY_SHADE = 'CTM_CANOPY_SHADE ' ! env var for in-line - LOGICAL, SAVE :: CANOPY_SHADE ! flag in-lining canopy shading + LOGICAL, PUBLIC, SAVE :: CANOPY_SHADE ! flag in-lining canopy shading + ! Canopy arrays REAL, ALLOCATABLE :: RJ_CORR_C1R ( :, :) ! canopy shading correction to J-values (hc to 0.75*hc) REAL, ALLOCATABLE :: RJ_CORR_C2R ( :, :) ! canopy shading correction to J-values (hc to 0.50*hc) @@ -361,7 +362,7 @@ END SUBROUTINE O3TOTCOL & .FALSE., IOSX ) IF ( CANOPY_SHADE ) THEN - XMSG = 'Using in-line canopy shading option' + XMSG = 'Using in-line canopy shading option-phot' CALL M3MSG2( XMSG ) END IF diff --git a/src/shr/aqm_methods.F90 b/src/shr/aqm_methods.F90 index 0040125..6c44dd5 100644 --- a/src/shr/aqm_methods.F90 +++ b/src/shr/aqm_methods.F90 @@ -746,6 +746,7 @@ logical function interpx( fname, vname, pname, & do c = col0, col1 k = k + 1 buffer(k) = 0.01 * stateIn % zorl(c,r) + WRITE(*,*) 'ZRUF_Check = ', buffer(k) end do end do From 8c5435819aa889722360e4511f31950c0f229852 Mon Sep 17 00:00:00 2001 From: "Patrick.C.Campbell@noaa.gov" Date: Wed, 2 Mar 2022 20:14:29 +0000 Subject: [PATCH 17/90] Fixed bug in declaration. --- src/model/src/phot.F | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/model/src/phot.F b/src/model/src/phot.F index b3be964..8bf6e52 100644 --- a/src/model/src/phot.F +++ b/src/model/src/phot.F @@ -295,7 +295,7 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) ! Canopy in-line 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 + LOGICAL, SAVE :: CANOPY_SHADE ! flag in-lining canopy shading ! Canopy arrays REAL, ALLOCATABLE :: RJ_CORR_C1R ( :, :) ! canopy shading correction to J-values (hc to 0.75*hc) @@ -353,8 +353,6 @@ END SUBROUTINE O3TOTCOL ! ---------------------------------------------------------------------- - IF ( FIRSTIME ) THEN - C In-line canopy shading option? (default = false) CANOPY_SHADE = ENVYN( 'CTM_CANOPY_SHADE', @@ -366,6 +364,8 @@ END SUBROUTINE O3TOTCOL CALL M3MSG2( XMSG ) END IF + IF ( FIRSTIME ) THEN + FIRSTIME = .FALSE. LOGDEV = INIT3() From 830986e81b4141082296d339a52e80bf5eae884c Mon Sep 17 00:00:00 2001 From: "Patrick.C.Campbell@noaa.gov" Date: Thu, 3 Mar 2022 01:46:14 +0000 Subject: [PATCH 18/90] Checking CANOPY_SHADE condition.. --- src/model/src/ASX_DATA_MOD.F | 10 +++++----- src/model/src/phot.F | 6 +++--- src/shr/aqm_methods.F90 | 1 - 3 files changed, 8 insertions(+), 9 deletions(-) diff --git a/src/model/src/ASX_DATA_MOD.F b/src/model/src/ASX_DATA_MOD.F index 7970b83..ac39066 100755 --- a/src/model/src/ASX_DATA_MOD.F +++ b/src/model/src/ASX_DATA_MOD.F @@ -573,10 +573,10 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) & .FALSE., IOSX ) IF ( CANOPY_SHADE ) THEN - XMSG = 'Using in-line canopy shading option-ASX_DATA_MOD' + XMSG = 'Using in-line canopy shading option-ASX_DATA_MOD.F' CALL M3MSG2( XMSG ) END IF - If ( CANOPY_SHADE ) Then +! If ( CANOPY_SHADE ) Then ALLOCATE( Met_Data%FCH ( NCOLS,NROWS ), & Met_Data%FRT ( NCOLS,NROWS ), & Met_Data%CLU ( NCOLS,NROWS ), @@ -591,7 +591,7 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) XMSG = 'Failure allocating Canopy Shade variables' Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) End If - End If +! End If ALLOCATE( Mosaic_Data%USTAR ( NCOLS,NROWS,n_lufrac ), & Mosaic_Data%LAI ( NCOLS,NROWS,n_lufrac ), @@ -1069,7 +1069,7 @@ Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) End If C Canopy vars - If ( CANOPY_SHADE ) Then +! If ( CANOPY_SHADE ) Then VNAME = 'FCH' If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2,1,1, @@ -1141,7 +1141,7 @@ Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) End If - End If +! End If C Soil vars VNAME = 'SOIM1' If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, diff --git a/src/model/src/phot.F b/src/model/src/phot.F index 8bf6e52..198f5c7 100644 --- a/src/model/src/phot.F +++ b/src/model/src/phot.F @@ -353,6 +353,8 @@ END SUBROUTINE O3TOTCOL ! ---------------------------------------------------------------------- + IF ( FIRSTIME ) THEN + C In-line canopy shading option? (default = false) CANOPY_SHADE = ENVYN( 'CTM_CANOPY_SHADE', @@ -360,12 +362,10 @@ END SUBROUTINE O3TOTCOL & .FALSE., IOSX ) IF ( CANOPY_SHADE ) THEN - XMSG = 'Using in-line canopy shading option-phot' + XMSG = 'Using in-line canopy shading option-phot.F' CALL M3MSG2( XMSG ) END IF - IF ( FIRSTIME ) THEN - FIRSTIME = .FALSE. LOGDEV = INIT3() diff --git a/src/shr/aqm_methods.F90 b/src/shr/aqm_methods.F90 index 6c44dd5..0040125 100644 --- a/src/shr/aqm_methods.F90 +++ b/src/shr/aqm_methods.F90 @@ -746,7 +746,6 @@ logical function interpx( fname, vname, pname, & do c = col0, col1 k = k + 1 buffer(k) = 0.01 * stateIn % zorl(c,r) - WRITE(*,*) 'ZRUF_Check = ', buffer(k) end do end do From cffa402f42362d957e6730b2617bbd3f9af6efdb Mon Sep 17 00:00:00 2001 From: "Patrick.C.Campbell@noaa.gov" Date: Thu, 3 Mar 2022 17:52:09 +0000 Subject: [PATCH 19/90] Updated Canopy debugs --- src/model/src/ASX_DATA_MOD.F | 18 +++++++++--------- src/shr/aqm_methods.F90 | 4 ++-- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src/model/src/ASX_DATA_MOD.F b/src/model/src/ASX_DATA_MOD.F index ac39066..0fcdd2c 100755 --- a/src/model/src/ASX_DATA_MOD.F +++ b/src/model/src/ASX_DATA_MOD.F @@ -289,7 +289,7 @@ Module ASX_DATA_MOD ! Canopy in-line 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 + LOGICAL, SAVE :: CANOPY_SHADE ! flag in-lining canopy shading 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/ @@ -568,14 +568,14 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) Grid_Data%WRES = 0.0 Grid_Data%BSLP = 0.0 - 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-ASX_DATA_MOD.F' - CALL M3MSG2( XMSG ) - END IF +! 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-ASX_DATA_MOD.F' +! CALL M3MSG2( XMSG ) +! END IF ! If ( CANOPY_SHADE ) Then ALLOCATE( Met_Data%FCH ( NCOLS,NROWS ), & Met_Data%FRT ( NCOLS,NROWS ), diff --git a/src/shr/aqm_methods.F90 b/src/shr/aqm_methods.F90 index 0040125..551851b 100644 --- a/src/shr/aqm_methods.F90 +++ b/src/shr/aqm_methods.F90 @@ -757,8 +757,8 @@ logical function interpx( fname, vname, pname, & do r = row0, row1 do c = col0, col1 k = k + 1 - buffer(k) = ( 0.0 * stateIn % zorl(c,r) ) + 10.0 - WRITE(*,*) 'FCH_Check = ', buffer(k) +! buffer(k) = ( 0.0 * stateIn % zorl(c,r) ) + 10.0 + buffer(k) = 10.0 end do end do case ("FRT") From 7d49ad1ebe4e736f4f2f759b8575639352aed032 Mon Sep 17 00:00:00 2001 From: "Patrick.C.Campbell@noaa.gov" Date: Thu, 3 Mar 2022 21:40:35 +0000 Subject: [PATCH 20/90] Fixed CANOPY_SHADE logic bug and added debug prints. --- src/model/src/ASX_DATA_MOD.F | 57 ++++++++++++++++++------------------ src/shr/aqm_methods.F90 | 5 ++-- 2 files changed, 31 insertions(+), 31 deletions(-) diff --git a/src/model/src/ASX_DATA_MOD.F b/src/model/src/ASX_DATA_MOD.F index 0fcdd2c..52acaf3 100755 --- a/src/model/src/ASX_DATA_MOD.F +++ b/src/model/src/ASX_DATA_MOD.F @@ -289,7 +289,7 @@ Module ASX_DATA_MOD ! Canopy in-line control CHARACTER( 20 ), SAVE :: CTM_CANOPY_SHADE = 'CTM_CANOPY_SHADE '! env var for in-line - LOGICAL, SAVE :: CANOPY_SHADE ! flag in-lining canopy shading + LOGICAL, PUBLIC, SAVE :: CANOPY_SHADE ! flag in-lining canopy shading 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/ @@ -568,31 +568,6 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) Grid_Data%WRES = 0.0 Grid_Data%BSLP = 0.0 -! 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-ASX_DATA_MOD.F' -! 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 Canopy Shade variables' - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If -! End If - ALLOCATE( Mosaic_Data%USTAR ( NCOLS,NROWS,n_lufrac ), & Mosaic_Data%LAI ( NCOLS,NROWS,n_lufrac ), & Mosaic_Data%DELTA ( NCOLS,NROWS,n_lufrac ), @@ -653,6 +628,32 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) ChemMos_Data%SubName = subname End If +!> 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-ASX_DATA_MOD.F' + 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 Canopy Shade variables' + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + End If + !> ccccccccccccccccccccc enable backward compatiblity ccccccccccccccccccccc If ( .Not. desc3( met_cro_2d ) ) Then @@ -1069,7 +1070,7 @@ Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) End If C Canopy vars -! If ( CANOPY_SHADE ) Then + If ( CANOPY_SHADE ) Then VNAME = 'FCH' If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2,1,1, @@ -1141,7 +1142,7 @@ Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) End If -! End If + End If C Soil vars VNAME = 'SOIM1' If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, diff --git a/src/shr/aqm_methods.F90 b/src/shr/aqm_methods.F90 index 551851b..4561829 100644 --- a/src/shr/aqm_methods.F90 +++ b/src/shr/aqm_methods.F90 @@ -757,8 +757,7 @@ logical function interpx( fname, vname, pname, & do r = row0, row1 do c = col0, col1 k = k + 1 -! buffer(k) = ( 0.0 * stateIn % zorl(c,r) ) + 10.0 - buffer(k) = 10.0 + buffer(k) = ( 0.0 * stateIn % zorl(c,r) ) + 10.0 end do end do case ("FRT") @@ -778,7 +777,7 @@ logical function interpx( fname, vname, pname, & do r = row0, row1 do c = col0, col1 k = k + 1 - buffer(k) = ( 0.0 * stateIn % zorl(c,r) ) + 0.5 !test set to 0.5 + buffer(k) = ( 0.0 * stateIn % zorl(c,r) ) + 0.5 end do end do case ("POPU") From c3bc815d636caca9204be30a02c8cf8cf28f053b Mon Sep 17 00:00:00 2001 From: "Patrick.C.Campbell@noaa.gov" Date: Fri, 4 Mar 2022 02:38:26 +0000 Subject: [PATCH 21/90] Removed extraneous debug prints. --- src/model/src/ASX_DATA_MOD.F | 8 ++++---- src/model/src/phot.F | 18 +++++++++--------- 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/src/model/src/ASX_DATA_MOD.F b/src/model/src/ASX_DATA_MOD.F index 52acaf3..49f851d 100755 --- a/src/model/src/ASX_DATA_MOD.F +++ b/src/model/src/ASX_DATA_MOD.F @@ -633,10 +633,10 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) & 'Flag for in-line canopy shading', & .FALSE., IOSX ) - IF ( CANOPY_SHADE ) THEN - XMSG = 'Using in-line canopy shading option-ASX_DATA_MOD.F' - CALL M3MSG2( XMSG ) - END IF +! 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 ), diff --git a/src/model/src/phot.F b/src/model/src/phot.F index 198f5c7..9f0c077 100644 --- a/src/model/src/phot.F +++ b/src/model/src/phot.F @@ -362,7 +362,7 @@ END SUBROUTINE O3TOTCOL & .FALSE., IOSX ) IF ( CANOPY_SHADE ) THEN - XMSG = 'Using in-line canopy shading option-phot.F' + XMSG = 'Using in-line canopy shading option' CALL M3MSG2( XMSG ) END IF @@ -1017,11 +1017,11 @@ END SUBROUTINE O3TOTCOL !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) +! 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 @@ -1119,9 +1119,9 @@ END SUBROUTINE O3TOTCOL !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 ) +! 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 From 2a26402768459d9c0949af0e62fca2e503387fa1 Mon Sep 17 00:00:00 2001 From: "Patrick.C.Campbell@noaa.gov" Date: Fri, 4 Mar 2022 04:42:18 +0000 Subject: [PATCH 22/90] Removed debug prints. --- src/model/src/phot.F | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/model/src/phot.F b/src/model/src/phot.F index 9f0c077..fe83f6d 100644 --- a/src/model/src/phot.F +++ b/src/model/src/phot.F @@ -1111,9 +1111,9 @@ END SUBROUTINE O3TOTCOL 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) +! 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 From 2ee012f2fea0a0e8170e57cf82e9c276f09ca7ca Mon Sep 17 00:00:00 2001 From: "Patrick.C.Campbell@noaa.gov" Date: Sat, 5 Mar 2022 14:15:04 +0000 Subject: [PATCH 23/90] Fixed allocation/save bug. --- src/model/src/phot.F | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/model/src/phot.F b/src/model/src/phot.F index fe83f6d..86ad888 100644 --- a/src/model/src/phot.F +++ b/src/model/src/phot.F @@ -298,14 +298,14 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) LOGICAL, SAVE :: CANOPY_SHADE ! flag in-lining canopy shading ! Canopy arrays - REAL, ALLOCATABLE :: RJ_CORR_C1R ( :, :) ! canopy shading correction to J-values (hc to 0.75*hc) - REAL, ALLOCATABLE :: RJ_CORR_C2R ( :, :) ! canopy shading correction to J-values (hc to 0.50*hc) - REAL, ALLOCATABLE :: RJ_CORR_C3R ( :, :) ! canopy shading correction to J-values (hc to 0.35*hc) - REAL, ALLOCATABLE :: RJ_CORR_C4R ( :, :) ! canopy shading correction to J-values (hc to 0.20*hc) - REAL, ALLOCATABLE :: RJ_CORR_BOT ( :, :) ! canopy shading correction to J-values (0.20*hc to bottom) - REAL, ALLOCATABLE :: RJ_CORR ( :, :) ! total/integrated canopy shading correction to J-values - REAL, ALLOCATABLE :: ZCANX ( : ) ! canopy heights[m] - REAL, ALLOCATABLE :: RJ_CORRX ( : ) ! canopy height dependent photolysis attenuation factor + REAL, ALLOCATABLE, SAVE :: RJ_CORR_C1R ( :, :) ! canopy shading correction to J-values (hc to 0.75*hc) + REAL, ALLOCATABLE, SAVE :: RJ_CORR_C2R ( :, :) ! canopy shading correction to J-values (hc to 0.50*hc) + REAL, ALLOCATABLE, SAVE :: RJ_CORR_C3R ( :, :) ! canopy shading correction to J-values (hc to 0.35*hc) + REAL, ALLOCATABLE, SAVE :: RJ_CORR_C4R ( :, :) ! canopy shading correction to J-values (hc to 0.20*hc) + REAL, ALLOCATABLE, SAVE :: RJ_CORR_BOT ( :, :) ! canopy shading correction to J-values (0.20*hc to bottom) + REAL, ALLOCATABLE, SAVE :: RJ_CORR ( :, :) ! 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 canopyvariables From 6cc3005187796ec3adf378064105931681203e05 Mon Sep 17 00:00:00 2001 From: Patrick Campbell Date: Mon, 21 Mar 2022 15:56:50 -0400 Subject: [PATCH 24/90] Update Makefile.in Fixed Makefile.in typo. --- src/model/Makefile.in | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/model/Makefile.in b/src/model/Makefile.in index 5ae221b..4d3ea17 100644 --- a/src/model/Makefile.in +++ b/src/model/Makefile.in @@ -238,8 +238,7 @@ am_libCCTM_a_OBJECTS = $(AERO)/libCCTM_a-AERO_DATA.$(OBJEXT) \ $(localCCTM)/libCCTM_a-PT3D_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-centralized_io_util_module.$(OBJEXT) libCCTM_a_OBJECTS = $(am_libCCTM_a_OBJECTS) AM_V_P = $(am__v_P_@AM_V@) am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) From 43c9948c8d2315f0986a486d7698d32ff3f6956a Mon Sep 17 00:00:00 2001 From: Patrick Campbell Date: Mon, 21 Mar 2022 17:39:46 -0400 Subject: [PATCH 25/90] Update Makefile.in --- src/model/Makefile.in | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/model/Makefile.in b/src/model/Makefile.in index 4d3ea17..09eebf2 100644 --- a/src/model/Makefile.in +++ b/src/model/Makefile.in @@ -1533,13 +1533,13 @@ $(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` $(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 '$(localCCTM)/'`$(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 '$(localCCTM)/'`$(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 $(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` From 0bef3bed9e47edd14171c4419c95c1bad39b886b Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Tue, 29 Mar 2022 18:07:38 +0000 Subject: [PATCH 26/90] Added new canopy file to read for AQM. --- examples/aqm.rc | 1 + 1 file changed, 1 insertion(+) diff --git a/examples/aqm.rc b/examples/aqm.rc index 0a3af4a..6cea1b3 100644 --- a/examples/aqm.rc +++ b/examples/aqm.rc @@ -37,6 +37,7 @@ init_concentrations: true # Run inline canopy effects # canopy_yn: false +canopy_file: /scratch2/NAGAPE/arl/Patrick.C.Campbell/canopy_geofiles/gfs.t12z.geo.08.canopy_regrid.nc # # Run aerosol module From 9b0939744e751e8cc5b9466f37f93db742d9a00e Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Tue, 29 Mar 2022 18:22:39 +0000 Subject: [PATCH 27/90] Updated aqm.rc example file. --- examples/aqm.rc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/examples/aqm.rc b/examples/aqm.rc index 6cea1b3..b7ec0f2 100644 --- a/examples/aqm.rc +++ b/examples/aqm.rc @@ -36,7 +36,7 @@ init_concentrations: true # Run inline canopy effects # -canopy_yn: false +canopy_yn: true canopy_file: /scratch2/NAGAPE/arl/Patrick.C.Campbell/canopy_geofiles/gfs.t12z.geo.08.canopy_regrid.nc # From 3daa4b6d9e88b9b67d19889c9dbc23570a05dfda Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Wed, 30 Mar 2022 01:24:59 +0000 Subject: [PATCH 28/90] Updated example aqm.rc for canopy settings and file. --- examples/aqm.rc | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/examples/aqm.rc b/examples/aqm.rc index b7ec0f2..6d805d6 100644 --- a/examples/aqm.rc +++ b/examples/aqm.rc @@ -34,11 +34,30 @@ omi_data: /scratch1/NCEPDEV/nems/Raffaele.Montuoro/dev/aqm/epa/data/omi_cmaq_ # - set to true for cold start init_concentrations: true -# Run inline canopy effects +# +# 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 unitless + CLU 1.00000 CLU unitless + POPU 1.00000 POPU 10000_people/10km2 + LAIE 1.00000 LAIE cm2/cm2 + C1R 1.00000 C1R cm2/cm2 + C2R 1.00000 C2R cm2/cm2 + C3R 1.00000 C3R cm2/cm2 + C4R 1.00000 C4R cm2/cm2 + # # Run aerosol module # From cc0d3e253ce48a5e04186c056cd7505926cbe5be Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Wed, 30 Mar 2022 03:20:26 +0000 Subject: [PATCH 29/90] Initial changes for reading canopy data in AQM. --- src/shr/aqm_methods.F90 | 144 ++++++++++++++++++++-------------------- 1 file changed, 72 insertions(+), 72 deletions(-) diff --git a/src/shr/aqm_methods.F90 b/src/shr/aqm_methods.F90 index a579595..7aa7787 100644 --- a/src/shr/aqm_methods.F90 +++ b/src/shr/aqm_methods.F90 @@ -751,95 +751,95 @@ logical function interpx( fname, vname, pname, & ! canopy variables case ("FCH") - !test forest canopy height set to 10 m ! p2d => stateIn % cfch - k = 0 - do r = row0, row1 - do c = col0, col1 - k = k + 1 - buffer(k) = ( 0.0 * stateIn % zorl(c,r) ) + 10.0 - end do - end do + 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 for " // vname, & + file=__FILE__, line=__LINE__)) return + else + buffer(1:lbuf) = 0. + end if case ("FRT") - !test grid cell forest fraction to 0.5 ! p2d => stateIn % cfrt - k = 0 - do r = row0, row1 - do c = col0, col1 - k = k + 1 - buffer(k) = ( 0.0 * stateIn % zorl(c,r) ) + 0.5 - end do - end do + 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 for " // vname, & + file=__FILE__, line=__LINE__)) return + else + buffer(1:lbuf) = 0. + end if case ("CLU") - !test forest clumping index set to 0.5 (spherical leaf distribution) ! p2d => stateIn % cclu - k = 0 - do r = row0, row1 - do c = col0, col1 - k = k + 1 - buffer(k) = ( 0.0 * stateIn % zorl(c,r) ) + 0.5 - end do - end do + 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 for " // vname, & + file=__FILE__, line=__LINE__)) return + else + buffer(1:lbuf) = 0. + end if case ("POPU") - !test pop. density set to 10000 people/10km2 ! p2d => stateIn % cpopu - k = 0 - do r = row0, row1 - do c = col0, col1 - k = k + 1 - buffer(k) = ( 0.0 * stateIn % zorl(c,r) ) + 10000.0 - end do - end do + 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 for " // vname, & + file=__FILE__, line=__LINE__)) return + else + buffer(1:lbuf) = 0. + end if case ("LAIE") - !test new ECCC LAI set to 4 ! p2d => stateIn % claie - k = 0 - do r = row0, row1 - do c = col0, col1 - k = k + 1 - buffer(k) = ( 0.0 * stateIn % zorl(c,r) ) + 4.0 - end do - end do + 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 for " // vname, & + file=__FILE__, line=__LINE__)) return + else + buffer(1:lbuf) = 0. + end if case ("C1R") - !test new ECCC cumulative LAI fraction 1 (FCH to 0.75FCH) set to 0.5 ! p2d => stateIn % cc1r - k = 0 - do r = row0, row1 - do c = col0, col1 - k = k + 1 - buffer(k) = ( 0.0 * stateIn % zorl(c,r) ) + 0.5 - end do - end do + 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 for " // vname, & + file=__FILE__, line=__LINE__)) return + else + buffer(1:lbuf) = 0. + end if case ("C2R") - !test new ECCC cumulative LAI fraction 2 (FCH to 0.5FCH) set to 0.7 ! p2d => stateIn % cc2r - k = 0 - do r = row0, row1 - do c = col0, col1 - k = k + 1 - buffer(k) = ( 0.0 * stateIn % zorl(c,r) ) + 0.7 - end do - end do + 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 for " // vname, & + file=__FILE__, line=__LINE__)) return + else + buffer(1:lbuf) = 0. + end if case ("C3R") - !test new ECCC cumulative LAI fraction 3 (FCH to 0.35FCH) set to 0.9 ! p2d => stateIn % cc3r - k = 0 - do r = row0, row1 - do c = col0, col1 - k = k + 1 - buffer(k) = ( 0.0 * stateIn % zorl(c,r) ) + 0.9 - end do - end do + 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 for " // vname, & + file=__FILE__, line=__LINE__)) return + else + buffer(1:lbuf) = 0. + end if case ("C4R") - !test new ECCC cumulative LAI fraction 4 (FCH to 0.20FCH) set to 0.95 ! p2d => stateIn % cc4r - k = 0 - do r = row0, row1 - do c = col0, col1 - k = k + 1 - buffer(k) = ( 0.0 * stateIn % zorl(c,r) ) + 0.95 - end do - end do + 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 for " // vname, & + file=__FILE__, line=__LINE__)) return + else + buffer(1:lbuf) = 0. + end if case default ! return end select From 035efa105202f50d234f9704c884d1ce0c625310 Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Wed, 30 Mar 2022 18:11:05 +0000 Subject: [PATCH 30/90] Updated aqm_emis_read and aqm.rc for canopy variables. --- examples/aqm.rc | 17 +++++++++-------- src/shr/aqm_emis_mod.F90 | 7 +++++++ 2 files changed, 16 insertions(+), 8 deletions(-) diff --git a/examples/aqm.rc b/examples/aqm.rc index 6d805d6..5066518 100644 --- a/examples/aqm.rc +++ b/examples/aqm.rc @@ -49,14 +49,15 @@ canopy_frequency: static canopy_species:: FCH 1.00000 FCH m - FRT 1.00000 FRT unitless - CLU 1.00000 CLU unitless + FRT 1.00000 FRT 1 + CLU 1.00000 CLU 1 POPU 1.00000 POPU 10000_people/10km2 - LAIE 1.00000 LAIE cm2/cm2 - C1R 1.00000 C1R cm2/cm2 - C2R 1.00000 C2R cm2/cm2 - C3R 1.00000 C3R cm2/cm2 - C4R 1.00000 C4R cm2/cm2 + 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 aerosol module @@ -89,7 +90,7 @@ ctm_pmdiag: true emission_sources: myemis # -# Emission type: anthropogenic, biogenic, gbbepx +# Emission type: anthropogenic, biogenic, gbbepx, canopy # myemis_type: anthropogenic diff --git a/src/shr/aqm_emis_mod.F90 b/src/shr/aqm_emis_mod.F90 index 5590ef1..0e36216 100644 --- a/src/shr/aqm_emis_mod.F90 +++ b/src/shr/aqm_emis_mod.F90 @@ -1160,6 +1160,13 @@ subroutine aqm_emis_read(etype, spcname, buffer, localDe, rc) if (present(rc)) rc = AQM_RC_FAILURE 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 From f427465049d86b4aabe1c1f9276bc5bdeeebf47a Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Mon, 4 Apr 2022 00:26:41 +0000 Subject: [PATCH 31/90] Updated bug to get aqm_get_config. --- src/shr/aqm_methods.F90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/shr/aqm_methods.F90 b/src/shr/aqm_methods.F90 index 7aa7787..696d74a 100644 --- a/src/shr/aqm_methods.F90 +++ b/src/shr/aqm_methods.F90 @@ -653,6 +653,11 @@ logical function interpx( fname, vname, pname, & 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 From 30bccdb876802863ba80eba51d15d70489df64ca Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Tue, 14 Jun 2022 16:12:07 +0000 Subject: [PATCH 32/90] Updated for local in-canopy modified codes. --- aqm_files.cmake | 3 +++ 1 file changed, 3 insertions(+) diff --git a/aqm_files.cmake b/aqm_files.cmake index c3f7420..b6c0d24 100644 --- a/aqm_files.cmake +++ b/aqm_files.cmake @@ -231,4 +231,7 @@ list(APPEND aqm_CCTM_files ${localCCTM}/vdiffacmx.F ${localCCTM}/PTMAP.F ${localCCTM}/PT3D_DEFN.F + ${localCCTM}/phot.F + ${localCCTM}/ASX_DATA_MOD.F + ${localCCTM}/centralized_io_util_module.F ) From 1c1f75895bfe54d4276a72172abbe0d9c9beb2ce Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Tue, 14 Jun 2022 16:27:13 +0000 Subject: [PATCH 33/90] Moved ASX_DATA_MOD to compile above Phot.F --- aqm_files.cmake | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/aqm_files.cmake b/aqm_files.cmake index b6c0d24..8493a22 100644 --- a/aqm_files.cmake +++ b/aqm_files.cmake @@ -231,7 +231,7 @@ list(APPEND aqm_CCTM_files ${localCCTM}/vdiffacmx.F ${localCCTM}/PTMAP.F ${localCCTM}/PT3D_DEFN.F - ${localCCTM}/phot.F ${localCCTM}/ASX_DATA_MOD.F + ${localCCTM}/phot.F ${localCCTM}/centralized_io_util_module.F ) From 4044777e08c133a9c672bd266bd36efb520e3034 Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Tue, 14 Jun 2022 16:37:43 +0000 Subject: [PATCH 34/90] Updated to remove default ASX_DATA_MOD and phot.F --- aqm_files.cmake | 2 -- 1 file changed, 2 deletions(-) diff --git a/aqm_files.cmake b/aqm_files.cmake index 8493a22..5798ed0 100644 --- a/aqm_files.cmake +++ b/aqm_files.cmake @@ -180,7 +180,6 @@ list(APPEND aqm_CCTM_files ${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 @@ -215,7 +214,6 @@ list(APPEND aqm_CCTM_files ${UTIL}/subhdomain.F ${UTIL}/UTILIO_DEFN.F ${VDIFF}/aero_sedv.F - ${VDIFF}/ASX_DATA_MOD.F ${VDIFF}/conv_cgrid.F ${VDIFF}/matrix1.F ${VDIFF}/opddep.F From 43588af77cf86ee9f24cc67437d625d0ebede984 Mon Sep 17 00:00:00 2001 From: bbakernoaa Date: Wed, 3 Aug 2022 14:09:23 +0000 Subject: [PATCH 35/90] updates --- aqm_files.cmake | 6 +- src/model/Makefile.am | 64 +- src/model/Makefile.in | 109 +- src/model/src/ASX_DATA_MOD.F | 1463 +++++++++++++++++++ src/model/src/ASX_DATA_MOD.F~ | 1459 +++++++++++++++++++ src/model/src/DUST_EMIS.F | 1525 ++++++++++++++++++++ src/model/src/centralized_io_util_module.F | 282 ++++ 7 files changed, 4828 insertions(+), 80 deletions(-) create mode 100755 src/model/src/ASX_DATA_MOD.F create mode 100755 src/model/src/ASX_DATA_MOD.F~ create mode 100644 src/model/src/DUST_EMIS.F create mode 100644 src/model/src/centralized_io_util_module.F diff --git a/aqm_files.cmake b/aqm_files.cmake index c3f7420..22bd6af 100644 --- a/aqm_files.cmake +++ b/aqm_files.cmake @@ -130,7 +130,6 @@ list(APPEND aqm_CCTM_files ${EMIS}/BEIS_DEFN.F ${EMIS}/BIOG_EMIS.F ${EMIS}/cropcal.F - ${EMIS}/DUST_EMIS.F ${EMIS}/EMIS_DEFN.F ${EMIS}/LTNG_DEFN.F ${EMIS}/LUS_DEFN.F @@ -215,7 +214,6 @@ list(APPEND aqm_CCTM_files ${UTIL}/subhdomain.F ${UTIL}/UTILIO_DEFN.F ${VDIFF}/aero_sedv.F - ${VDIFF}/ASX_DATA_MOD.F ${VDIFF}/conv_cgrid.F ${VDIFF}/matrix1.F ${VDIFF}/opddep.F @@ -231,4 +229,8 @@ list(APPEND aqm_CCTM_files ${localCCTM}/vdiffacmx.F ${localCCTM}/PTMAP.F ${localCCTM}/PT3D_DEFN.F + ${localCCTM}/ASX_DATA_MOD.F + ${localCCTM}/centralized_io_util_module.F + ${localCCTM}/DUST_EMIS.F ) + diff --git a/src/model/Makefile.am b/src/model/Makefile.am index 61c4887..909b66e 100644 --- a/src/model/Makefile.am +++ b/src/model/Makefile.am @@ -79,7 +79,6 @@ libCCTM_a_SOURCES += \ $(EMIS)/BEIS_DEFN.F \ $(EMIS)/BIOG_EMIS.F \ $(EMIS)/cropcal.F \ - $(EMIS)/DUST_EMIS.F \ $(EMIS)/EMIS_DEFN.F \ $(EMIS)/LTNG_DEFN.F \ $(EMIS)/LUS_DEFN.F \ @@ -223,7 +222,6 @@ VDIFF = $(CCTM)/vdiff/acm2 libVDIFF = $(VDIFF)/$(libCCTM)- libCCTM_a_SOURCES += \ $(VDIFF)/aero_sedv.F \ - $(VDIFF)/ASX_DATA_MOD.F \ $(VDIFF)/conv_cgrid.F \ $(VDIFF)/matrix1.F \ $(VDIFF)/opddep.F \ @@ -242,7 +240,11 @@ libCCTM_a_SOURCES += \ $(localCCTM)/o3totcol.f \ $(localCCTM)/vdiffacmx.F \ $(localCCTM)/PTMAP.F \ - $(localCCTM)/PT3D_DEFN.F + $(localCCTM)/PT3D_DEFN.F \ + $(localCCTM)/ASX_DATA_MOD.F \ + $(localCCTM)/centralized_io_util_module.F \ + $(localCCTM)/DUST_EMIS.F + libCCTM_a_CPPFLAGS = -DSUBST_FILES_ID=\"FILES_CTM.EXT\" @@ -289,7 +291,7 @@ $(libAERO)AERO_DATA.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libAERO)aero_depv.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libAERO)AERO_DATA.$(OBJEXT) $(libAERO)AEROMET_DATA.$(OBJEXT) \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ $(libDEPV)MOSAIC_MOD.$(OBJEXT) $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) @@ -301,8 +303,8 @@ $(libAERO)aero_driver.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) $(libAERO)SOA_DEFN.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libAERO)AERO_EMIS.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(libAERO)AERO_DATA.$(OBJEXT) $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) \ - $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libEMIS)DUST_EMIS.$(OBJEXT) \ + $(libAERO)AERO_DATA.$(OBJEXT) $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) \ + $(libSPCS)CGRID_SPCS.$(OBJEXT) $(liblocalCCTM)DUST_EMIS.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libAERO)PRECURSOR_DATA.$(OBJEXT) \ $(liblocalCCTM)PT3D_DEFN.$(OBJEXT) $(liblocalCCTM)PTMAP.$(OBJEXT) \ $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) $(libEMIS)SSEMIS.$(OBJEXT) \ @@ -318,7 +320,7 @@ $(libAERO)aero_subs.$(OBJEXT) : $(ICL)/const/CONST.EXT $(AERO)/isrpia.inc \ $(libAERO)AOD_DEFN.$(OBJEXT) $(libAERO)PRECURSOR_DATA.$(OBJEXT) \ $(libAERO)SOA_DEFN.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libAERO)AOD_DEFN.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(libAERO)AERO_DATA.$(OBJEXT) $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) \ + $(libAERO)AERO_DATA.$(OBJEXT) $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libAERO)getpar.$(OBJEXT) : \ @@ -347,11 +349,11 @@ $(libAERO)SOA_DEFN.$(OBJEXT) : \ # biog $(libBIOG)beis3.$(OBJEXT) : \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BIOG_EMIS.$(OBJEXT) + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BIOG_EMIS.$(OBJEXT) $(libBIOG)czangle.$(OBJEXT) : $(ICL)/const/CONST.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libBIOG)hrno.$(OBJEXT) : \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BIOG_EMIS.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BIOG_EMIS.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ $(libSTENEX)noop_modules.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libBIOG)parsline.$(OBJEXT) : \ @@ -368,7 +370,7 @@ $(libCLOUD)hlconst.$(OBJEXT) : \ # depv $(libDEPV)ABFLUX_MOD.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ $(libDEPV)MOSAIC_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ @@ -378,7 +380,7 @@ $(libDEPV)cgrid_depv.$(OBJEXT) : \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)DEPV_DEFN.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libDEPV)DEPVVARS.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ $(libDEPV)MOSAIC_MOD.$(OBJEXT) $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) \ @@ -387,13 +389,13 @@ $(libDEPV)gas_depv_map.$(OBJEXT) : \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libDEPV)DEPVVARS.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)HGSIM.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libDEPV)LSM_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)MOSAIC_MOD.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libDEPV)LSM_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)opdepv_diag.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ @@ -405,7 +407,7 @@ $(libDEPV)opdepv_fst.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libDEPV)LSM_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)m3dry.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(libDEPV)ABFLUX_MOD.$(OBJEXT) $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) \ + $(libDEPV)ABFLUX_MOD.$(OBJEXT) $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) \ $(libDEPV)BIDI_MOD.$(OBJEXT) $(libDEPV)DEPVVARS.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libDEPV)HGSIM.$(OBJEXT) \ $(libDEPV)LSM_MOD.$(OBJEXT) $(libDEPV)MOSAIC_MOD.$(OBJEXT) \ @@ -420,13 +422,9 @@ $(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) $(libVDIFF)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) \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BEIS_DEFN.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BEIS_DEFN.$(OBJEXT) \ $(libEMIS)BIOG_EMIS.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libDEPV)DEPV_DEFN.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libEMIS)LTNG_DEFN.$(OBJEXT) $(libEMIS)MGEMIS.$(OBJEXT) \ @@ -439,7 +437,7 @@ $(libEMIS)LTNG_DEFN.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libEMIS)LUS_DEFN.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libEMIS)MGEMIS.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(libAERO)AEROMET_DATA.$(OBJEXT) $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) \ + $(libAERO)AEROMET_DATA.$(OBJEXT) $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libGRID)PCGRID_DEFN.$(OBJEXT) \ $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) @@ -452,7 +450,7 @@ $(libEMIS)PTBILIN.$(OBJEXT) : \ $(libEMIS)UDTYPES.$(OBJEXT) $(libGRID)VGRD_DEFN.$(OBJEXT) $(libEMIS)SSEMIS.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libAERO)AERO_DATA.$(OBJEXT) $(libAERO)AEROMET_DATA.$(OBJEXT) \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libSTENEX)noop_modules.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libEMIS)STK_EMIS.$(OBJEXT) : \ @@ -461,7 +459,7 @@ $(libEMIS)STK_PRMS.$(OBJEXT) : \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libEMIS)UDTYPES.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libEMIS)tfabove.$(OBJEXT) : \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libEMIS)LUS_DEFN.$(OBJEXT) $(libEMIS)tfbelow.$(OBJEXT) : \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libEMIS)LUS_DEFN.$(OBJEXT) \ @@ -620,12 +618,8 @@ $(libUTIL)subhdomain.$(OBJEXT) : \ # vdiff $(libVDIFF)aero_sedv.$(OBJEXT) : \ $(libAERO)AERO_DATA.$(OBJEXT) $(libAERO)AEROMET_DATA.$(OBJEXT) \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) -$(libVDIFF)ASX_DATA_MOD.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT $(ICL)/mpi/PE_COMM.EXT \ - $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ - $(libDEPV)LSM_MOD.$(OBJEXT) $(libSTENEX)noop_modules.$(OBJEXT) \ - $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libVDIFF)conv_cgrid.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) @@ -645,7 +639,7 @@ $(libVDIFF)rddepv.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libVDIFF)SEDIMENTATION.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) \ $(libVDIFF)VDIFF_DIAG.$(OBJEXT) $(libVDIFF)VDIFF_MAP.$(OBJEXT) $(libVDIFF)tri.$(OBJEXT) : \ @@ -657,7 +651,7 @@ $(libVDIFF)VDIFF_MAP.$(OBJEXT) : $(ICL)/emctrl/EMISPRM.EXT \ $(libAERO)AERO_EMIS.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libVDIFF)vdiffproc.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libDEPV)DEPV_DEFN.$(OBJEXT) \ $(libEMIS)EMIS_DEFN.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libDEPV)HGSIM.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ @@ -669,7 +663,7 @@ $(libVDIFF)vdiffproc.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(liblocalCCTM)o3totcol.$(OBJEXT) : \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(liblocalCCTM)vdiffacmx.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libDEPV)DEPV_DEFN.$(OBJEXT) $(libEMIS)EMIS_DEFN.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) \ $(libVDIFF)VDIFF_MAP.$(OBJEXT) @@ -679,3 +673,11 @@ $(liblocalCCTM)PT3D_DEFN.$(OBJEXT) : $(libAERO)AERO_DATA.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(liblocalCCTM)PTMAP.$(OBJEXT) $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) \ $(libEMIS)STK_EMIS.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) +$(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT $(ICL)/mpi/PE_COMM.EXT \ + $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ + $(libDEPV)LSM_MOD.$(OBJEXT) $(libSTENEX)noop_modules.$(OBJEXT) \ + $(libUTIL)UTILIO_DEFN.$(OBJEXT) +$(liblocalCCTM)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) diff --git a/src/model/Makefile.in b/src/model/Makefile.in index 0c12a88..e6ef50a 100644 --- a/src/model/Makefile.in +++ b/src/model/Makefile.in @@ -143,7 +143,6 @@ am_libCCTM_a_OBJECTS = $(AERO)/libCCTM_a-AERO_DATA.$(OBJEXT) \ $(EMIS)/libCCTM_a-BEIS_DEFN.$(OBJEXT) \ $(EMIS)/libCCTM_a-BIOG_EMIS.$(OBJEXT) \ $(EMIS)/libCCTM_a-cropcal.$(OBJEXT) \ - $(EMIS)/libCCTM_a-DUST_EMIS.$(OBJEXT) \ $(EMIS)/libCCTM_a-EMIS_DEFN.$(OBJEXT) \ $(EMIS)/libCCTM_a-LTNG_DEFN.$(OBJEXT) \ $(EMIS)/libCCTM_a-LUS_DEFN.$(OBJEXT) \ @@ -222,7 +221,6 @@ am_libCCTM_a_OBJECTS = $(AERO)/libCCTM_a-AERO_DATA.$(OBJEXT) \ $(UTIL)/libCCTM_a-subhdomain.$(OBJEXT) \ $(UTIL)/libCCTM_a-UTILIO_DEFN.$(OBJEXT) \ $(VDIFF)/libCCTM_a-aero_sedv.$(OBJEXT) \ - $(VDIFF)/libCCTM_a-ASX_DATA_MOD.$(OBJEXT) \ $(VDIFF)/libCCTM_a-conv_cgrid.$(OBJEXT) \ $(VDIFF)/libCCTM_a-matrix1.$(OBJEXT) \ $(VDIFF)/libCCTM_a-opddep.$(OBJEXT) \ @@ -237,7 +235,10 @@ am_libCCTM_a_OBJECTS = $(AERO)/libCCTM_a-AERO_DATA.$(OBJEXT) \ $(localCCTM)/libCCTM_a-o3totcol.$(OBJEXT) \ $(localCCTM)/libCCTM_a-vdiffacmx.$(OBJEXT) \ $(localCCTM)/libCCTM_a-PTMAP.$(OBJEXT) \ - $(localCCTM)/libCCTM_a-PT3D_DEFN.$(OBJEXT) + $(localCCTM)/libCCTM_a-PT3D_DEFN.$(OBJEXT) \ + $(localCCTM)/libCCTM_a-ASX_DATA_MOD.$(OBJEXT) \ + $(localCCTM)/libCCTM_a-centralized_io_util_module.$(OBJEXT) \ + $(localCCTM)/libCCTM_a-DUST_EMIS.$(OBJEXT) libCCTM_a_OBJECTS = $(am_libCCTM_a_OBJECTS) AM_V_P = $(am__v_P_@AM_V@) am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) @@ -468,7 +469,7 @@ libCCTM_a_SOURCES = $(AERO)/AERO_DATA.F $(AERO)/aero_depv.F \ $(DEPV)/MOSAIC_MOD.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)/DUST_EMIS.F $(EMIS)/EMIS_DEFN.F $(EMIS)/LTNG_DEFN.F \ + $(EMIS)/EMIS_DEFN.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 \ @@ -504,13 +505,15 @@ libCCTM_a_SOURCES = $(AERO)/AERO_DATA.F $(AERO)/aero_depv.F \ $(STENEX)/noop_util_module.f $(UTIL)/bmatvec.F \ $(UTIL)/findex.f $(UTIL)/get_envlist.f $(UTIL)/setup_logdev.F \ $(UTIL)/subhdomain.F $(UTIL)/UTILIO_DEFN.F \ - $(VDIFF)/aero_sedv.F $(VDIFF)/ASX_DATA_MOD.F \ + $(VDIFF)/aero_sedv.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_DIAG.F \ $(VDIFF)/VDIFF_MAP.F $(VDIFF)/vdiffproc.F \ $(localCCTM)/o3totcol.f $(localCCTM)/vdiffacmx.F \ - $(localCCTM)/PTMAP.F $(localCCTM)/PT3D_DEFN.F + $(localCCTM)/PTMAP.F $(localCCTM)/PT3D_DEFN.F \ + $(localCCTM)/ASX_DATA_MOD.F \ + $(localCCTM)/centralized_io_util_module.F $(localCCTM)/DUST_EMIS.F # local version of CCTM source files localCCTM = $(builddir)/src @@ -757,8 +760,6 @@ $(EMIS)/libCCTM_a-BIOG_EMIS.$(OBJEXT): $(EMIS)/$(am__dirstamp) \ $(EMIS)/$(DEPDIR)/$(am__dirstamp) $(EMIS)/libCCTM_a-cropcal.$(OBJEXT): $(EMIS)/$(am__dirstamp) \ $(EMIS)/$(DEPDIR)/$(am__dirstamp) -$(EMIS)/libCCTM_a-DUST_EMIS.$(OBJEXT): $(EMIS)/$(am__dirstamp) \ - $(EMIS)/$(DEPDIR)/$(am__dirstamp) $(EMIS)/libCCTM_a-EMIS_DEFN.$(OBJEXT): $(EMIS)/$(am__dirstamp) \ $(EMIS)/$(DEPDIR)/$(am__dirstamp) $(EMIS)/libCCTM_a-LTNG_DEFN.$(OBJEXT): $(EMIS)/$(am__dirstamp) \ @@ -981,8 +982,6 @@ $(VDIFF)/$(DEPDIR)/$(am__dirstamp): @: > $(VDIFF)/$(DEPDIR)/$(am__dirstamp) $(VDIFF)/libCCTM_a-aero_sedv.$(OBJEXT): $(VDIFF)/$(am__dirstamp) \ $(VDIFF)/$(DEPDIR)/$(am__dirstamp) -$(VDIFF)/libCCTM_a-ASX_DATA_MOD.$(OBJEXT): $(VDIFF)/$(am__dirstamp) \ - $(VDIFF)/$(DEPDIR)/$(am__dirstamp) $(VDIFF)/libCCTM_a-conv_cgrid.$(OBJEXT): $(VDIFF)/$(am__dirstamp) \ $(VDIFF)/$(DEPDIR)/$(am__dirstamp) $(VDIFF)/libCCTM_a-matrix1.$(OBJEXT): $(VDIFF)/$(am__dirstamp) \ @@ -1022,6 +1021,12 @@ $(localCCTM)/libCCTM_a-PTMAP.$(OBJEXT): $(localCCTM)/$(am__dirstamp) \ $(localCCTM)/libCCTM_a-PT3D_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): $(localCCTM)/$(am__dirstamp) \ + $(localCCTM)/$(DEPDIR)/$(am__dirstamp) libCCTM.a: $(libCCTM_a_OBJECTS) $(libCCTM_a_DEPENDENCIES) $(EXTRA_libCCTM_a_DEPENDENCIES) $(AM_V_at)-rm -f libCCTM.a @@ -1273,11 +1278,13 @@ $(EMIS)/libCCTM_a-cropcal.o: $(EMIS)/cropcal.F $(EMIS)/libCCTM_a-cropcal.obj: $(EMIS)/cropcal.F $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(EMIS)/libCCTM_a-cropcal.obj `if test -f '$(EMIS)/cropcal.F'; then $(CYGPATH_W) '$(EMIS)/cropcal.F'; else $(CYGPATH_W) '$(srcdir)/$(EMIS)/cropcal.F'; fi` -$(EMIS)/libCCTM_a-DUST_EMIS.o: $(EMIS)/DUST_EMIS.F - $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(EMIS)/libCCTM_a-DUST_EMIS.o `test -f '$(EMIS)/DUST_EMIS.F' || echo '$(srcdir)/'`$(EMIS)/DUST_EMIS.F +$(localCCTM)/libCCTM_a-DUST_EMIS.o: $(localCCTM)/DUST_EMIS.F + $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(localCCTM)/libCCTM_a-DUST_EMIS.o `test -f '$(local +CCTM)/DUST_EMIS.F' || echo '$(srcdir)/'`$(localCCTM)/DUST_EMIS.F -$(EMIS)/libCCTM_a-DUST_EMIS.obj: $(EMIS)/DUST_EMIS.F - $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(EMIS)/libCCTM_a-DUST_EMIS.obj `if test -f '$(EMIS)/DUST_EMIS.F'; then $(CYGPATH_W) '$(EMIS)/DUST_EMIS.F'; else $(CYGPATH_W) '$(srcdir)/$(EMIS)/DUST_EMIS.F'; fi` +$(localCCTM)/libCCTM_a-DUST_EMIS.obj: $(localCCTM)/DUST_EMIS.F + $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(localCCTM)/libCCTM_a-DUST_EMIS.obj `if test -f '$( +localCCTM)/DUST_EMIS.F'; then $(CYGPATH_W) '$(localCCTM)/DUST_EMIS.F'; else $(CYGPATH_W) '$(srcdir)/$(localCCTM)/DUST_EMIS.F'; fi` $(EMIS)/libCCTM_a-EMIS_DEFN.o: $(EMIS)/EMIS_DEFN.F $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(EMIS)/libCCTM_a-EMIS_DEFN.o `test -f '$(EMIS)/EMIS_DEFN.F' || echo '$(srcdir)/'`$(EMIS)/EMIS_DEFN.F @@ -1615,11 +1622,20 @@ $(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` -$(VDIFF)/libCCTM_a-ASX_DATA_MOD.o: $(VDIFF)/ASX_DATA_MOD.F - $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(VDIFF)/libCCTM_a-ASX_DATA_MOD.o `test -f '$(VDIFF)/ASX_DATA_MOD.F' || echo '$(srcdir)/'`$(VDIFF)/ASX_DATA_MOD.F ++$(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 ++ ++$(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.ob +j `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` -$(VDIFF)/libCCTM_a-ASX_DATA_MOD.obj: $(VDIFF)/ASX_DATA_MOD.F - $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(VDIFF)/libCCTM_a-ASX_DATA_MOD.obj `if test -f '$(VDIFF)/ASX_DATA_MOD.F'; then $(CYGPATH_W) '$(VDIFF)/ASX_DATA_MOD.F'; else $(CYGPATH_W) '$(srcdir)/$(VDIFF)/ASX_DATA_MOD.F'; fi` +$(liblocalCCTM)/libCCTM_a-ASX_DATA_MOD.o: $(liblocalCCTM)/ASX_DATA_MOD.F + $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(liblocalCCTM)/libCCTM_a-ASX_DATA_MOD.o `test -f '$(liblocalCCTM)/ASX_DATA_MOD.F' || echo '$(srcdir)/'`$(liblocalCCTM)/ASX_DATA_MOD.F + +$(liblocalCCTM)/libCCTM_a-ASX_DATA_MOD.obj: $(liblocalCCTM)/ASX_DATA_MOD.F + $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(liblocalCCTM)/libCCTM_a-ASX_DATA_MOD.obj `if test -f '$(liblocalCCTM)/ASX_DATA_MOD.F'; then $(CYGPATH_W) '$(liblocalCCTM)/ASX_DATA_MOD.F'; else $(CYGPATH_W) '$(srcdir)/$(liblocalCCTM)/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 @@ -2164,7 +2180,7 @@ $(libAERO)AERO_DATA.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libAERO)aero_depv.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libAERO)AERO_DATA.$(OBJEXT) $(libAERO)AEROMET_DATA.$(OBJEXT) \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ $(libDEPV)MOSAIC_MOD.$(OBJEXT) $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) @@ -2176,8 +2192,8 @@ $(libAERO)aero_driver.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) $(libAERO)SOA_DEFN.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libAERO)AERO_EMIS.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(libAERO)AERO_DATA.$(OBJEXT) $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) \ - $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libEMIS)DUST_EMIS.$(OBJEXT) \ + $(libAERO)AERO_DATA.$(OBJEXT) $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) \ + $(libSPCS)CGRID_SPCS.$(OBJEXT) $(liblocalCCTM)DUST_EMIS.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libAERO)PRECURSOR_DATA.$(OBJEXT) \ $(liblocalCCTM)PT3D_DEFN.$(OBJEXT) $(liblocalCCTM)PTMAP.$(OBJEXT) \ $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) $(libEMIS)SSEMIS.$(OBJEXT) \ @@ -2193,7 +2209,7 @@ $(libAERO)aero_subs.$(OBJEXT) : $(ICL)/const/CONST.EXT $(AERO)/isrpia.inc \ $(libAERO)AOD_DEFN.$(OBJEXT) $(libAERO)PRECURSOR_DATA.$(OBJEXT) \ $(libAERO)SOA_DEFN.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libAERO)AOD_DEFN.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(libAERO)AERO_DATA.$(OBJEXT) $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) \ + $(libAERO)AERO_DATA.$(OBJEXT) $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libAERO)getpar.$(OBJEXT) : \ @@ -2222,11 +2238,11 @@ $(libAERO)SOA_DEFN.$(OBJEXT) : \ # biog $(libBIOG)beis3.$(OBJEXT) : \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BIOG_EMIS.$(OBJEXT) + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BIOG_EMIS.$(OBJEXT) $(libBIOG)czangle.$(OBJEXT) : $(ICL)/const/CONST.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libBIOG)hrno.$(OBJEXT) : \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BIOG_EMIS.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BIOG_EMIS.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ $(libSTENEX)noop_modules.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libBIOG)parsline.$(OBJEXT) : \ @@ -2243,7 +2259,7 @@ $(libCLOUD)hlconst.$(OBJEXT) : \ # depv $(libDEPV)ABFLUX_MOD.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ $(libDEPV)MOSAIC_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ @@ -2253,7 +2269,7 @@ $(libDEPV)cgrid_depv.$(OBJEXT) : \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)DEPV_DEFN.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libDEPV)DEPVVARS.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ $(libDEPV)MOSAIC_MOD.$(OBJEXT) $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) \ @@ -2262,13 +2278,13 @@ $(libDEPV)gas_depv_map.$(OBJEXT) : \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libDEPV)DEPVVARS.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)HGSIM.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libDEPV)LSM_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)MOSAIC_MOD.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libDEPV)LSM_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)opdepv_diag.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ @@ -2280,7 +2296,7 @@ $(libDEPV)opdepv_fst.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libDEPV)LSM_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)m3dry.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(libDEPV)ABFLUX_MOD.$(OBJEXT) $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) \ + $(libDEPV)ABFLUX_MOD.$(OBJEXT) $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) \ $(libDEPV)BIDI_MOD.$(OBJEXT) $(libDEPV)DEPVVARS.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libDEPV)HGSIM.$(OBJEXT) \ $(libDEPV)LSM_MOD.$(OBJEXT) $(libDEPV)MOSAIC_MOD.$(OBJEXT) \ @@ -2295,13 +2311,9 @@ $(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) $(libVDIFF)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) \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BEIS_DEFN.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BEIS_DEFN.$(OBJEXT) \ $(libEMIS)BIOG_EMIS.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libDEPV)DEPV_DEFN.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libEMIS)LTNG_DEFN.$(OBJEXT) $(libEMIS)MGEMIS.$(OBJEXT) \ @@ -2314,7 +2326,7 @@ $(libEMIS)LTNG_DEFN.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libEMIS)LUS_DEFN.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libEMIS)MGEMIS.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(libAERO)AEROMET_DATA.$(OBJEXT) $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) \ + $(libAERO)AEROMET_DATA.$(OBJEXT) $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libGRID)PCGRID_DEFN.$(OBJEXT) \ $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) @@ -2327,7 +2339,7 @@ $(libEMIS)PTBILIN.$(OBJEXT) : \ $(libEMIS)UDTYPES.$(OBJEXT) $(libGRID)VGRD_DEFN.$(OBJEXT) $(libEMIS)SSEMIS.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libAERO)AERO_DATA.$(OBJEXT) $(libAERO)AEROMET_DATA.$(OBJEXT) \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libSTENEX)noop_modules.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libEMIS)STK_EMIS.$(OBJEXT) : \ @@ -2336,7 +2348,7 @@ $(libEMIS)STK_PRMS.$(OBJEXT) : \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libEMIS)UDTYPES.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libEMIS)tfabove.$(OBJEXT) : \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libEMIS)LUS_DEFN.$(OBJEXT) $(libEMIS)tfbelow.$(OBJEXT) : \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libEMIS)LUS_DEFN.$(OBJEXT) \ @@ -2495,12 +2507,8 @@ $(libUTIL)subhdomain.$(OBJEXT) : \ # vdiff $(libVDIFF)aero_sedv.$(OBJEXT) : \ $(libAERO)AERO_DATA.$(OBJEXT) $(libAERO)AEROMET_DATA.$(OBJEXT) \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) -$(libVDIFF)ASX_DATA_MOD.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT $(ICL)/mpi/PE_COMM.EXT \ - $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ - $(libDEPV)LSM_MOD.$(OBJEXT) $(libSTENEX)noop_modules.$(OBJEXT) \ - $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libVDIFF)conv_cgrid.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) @@ -2520,7 +2528,7 @@ $(libVDIFF)rddepv.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libVDIFF)SEDIMENTATION.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) \ $(libVDIFF)VDIFF_DIAG.$(OBJEXT) $(libVDIFF)VDIFF_MAP.$(OBJEXT) $(libVDIFF)tri.$(OBJEXT) : \ @@ -2532,7 +2540,7 @@ $(libVDIFF)VDIFF_MAP.$(OBJEXT) : $(ICL)/emctrl/EMISPRM.EXT \ $(libAERO)AERO_EMIS.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libVDIFF)vdiffproc.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libDEPV)DEPV_DEFN.$(OBJEXT) \ $(libEMIS)EMIS_DEFN.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libDEPV)HGSIM.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ @@ -2544,7 +2552,7 @@ $(libVDIFF)vdiffproc.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(liblocalCCTM)o3totcol.$(OBJEXT) : \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(liblocalCCTM)vdiffacmx.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ + $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libDEPV)DEPV_DEFN.$(OBJEXT) $(libEMIS)EMIS_DEFN.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) \ $(libVDIFF)VDIFF_MAP.$(OBJEXT) @@ -2554,7 +2562,14 @@ $(liblocalCCTM)PT3D_DEFN.$(OBJEXT) : $(libAERO)AERO_DATA.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(liblocalCCTM)PTMAP.$(OBJEXT) $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) \ $(libEMIS)STK_EMIS.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) - +$(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT $(ICL)/mpi/PE_COMM.EXT \ + $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ + $(libDEPV)LSM_MOD.$(OBJEXT) $(libSTENEX)noop_modules.$(OBJEXT) \ + $(libUTIL)UTILIO_DEFN.$(OBJEXT) +$(liblocalCCTM)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) # Tell versions [3.59,3.63) of GNU make to not export all variables. # Otherwise a system limit (for SysV at least) may be exceeded. .NOEXPORT: diff --git a/src/model/src/ASX_DATA_MOD.F b/src/model/src/ASX_DATA_MOD.F new file mode 100755 index 0000000..160183f --- /dev/null +++ b/src/model/src/ASX_DATA_MOD.F @@ -0,0 +1,1463 @@ +!------------------------------------------------------------------------! +! The Community Multiscale Air Quality (CMAQ) system software is in ! +! continuous development by various groups and is based on information ! +! from these groups: Federal Government employees, contractors working ! +! within a United States Government contract, and non-Federal sources ! +! including research institutions. These groups give the Government ! +! permission to use, prepare derivative works of, and distribute copies ! +! of their work in the CMAQ system to the public and to permit others ! +! to do so. The United States Environmental Protection Agency ! +! therefore grants similar permission to use the CMAQ system software, ! +! but users are requested to provide copies of derivative works or ! +! products designed to operate in the CMAQ system to the United States ! +! Government without restrictions as to use by others. Software ! +! that is used with the CMAQ system but distributed under the GNU ! +! General Public License or the GNU Lesser General Public License is ! +! subject to their copyright restrictions. ! +!------------------------------------------------------------------------! + +C::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: + Module ASX_DATA_MOD + +C----------------------------------------------------------------------- +C Function: User-defined types + +C Revision History: +C 19 Aug 2014 J.Bash: initial implementation +C 17 July 2015 H.Foroutan: Updated the calculation of MOL, MOLI, HOL, and WSTAR +C 25 Aug 2015 H. Pye: Added IEPOX, HACET surrogates +C modified PROPNN and H2O2 +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 +C---------Notes +C * Updates based on literature review 7/96 JEP +C # Diff and H based on Wesely (1988) same as RADM +C + Estimated by JEP 2/97 +C @ Updated by JEP 9/01 +C ~ Added by YW 1/02. Dif0 based on Massman (1998). Henry's Law constant +C is defined here as: h=cg/ca, where cg is the concentration of a species +C in gas-phase, and ca is its aqueous-phase concentration. The smaller h, +C the larger solubility. Henry's Law constant in another definition (KH): +C KH = ca/pg [M/atm], KH = KH0 * exp(-DKH/R(1/T-1/T0)), where KH0 and -DKH +C values are from Rolf Sander (1999). h=1/(KH*R*T). +C ** Update by DBS based on estimates by JEP 1/03 +C ^^ From Bill Massman, personal communication 4/03 +C ## Diffusivity calculated by SPARC, reactivity = other aldehydes +C ++ Dif0 in Massman is diffusivity at temperature 0C and 1 atm (101.325kPa), so +C chemicals that were not in Massman's paper need to be adjusted. We assume +C JEP's original values were for 25C and 1 atm. +C % Added by G. Sarwar (10/04) +C $ Added by R. Bullock (02/05) HG diffusivity is from Massman (1999). +C HGIIGAS diffusivity calculated from the HG value and a mol. wt. scaling +C factor of MW**(-2/3) from EPA/600/3-87/015. ORD, Athens, GA. HGIIGAS +C mol.wt. used is that of HgCl2. Reactivity of HG is 1/20th of NO and NO2 +C values based on general atmospheric lifetimes of each species. Reactivity +C of HGIIGAS is based on HNO3 surrogate. +C @@ Mesophyll resistances for NO, NO2, and CO added by J. Pleim (07/07) based +C on values in Pleim, Venkatram, and Yamartino, 1984: ADOM/TADAP Model +C Development Program, Volume 4, The Dry Deposition Module. ERT, Inc., +C Concord, MA (peer reviewed). +C ~~ Reactivity for PAN changed from 4.0 to 16.0 by J. Pleim (07/07) based on +C comparisons with Turnipseed et al., JGR, 2006. +C %% Species ICL1 and ICL2 are removed, not used in CB05. G. Sarwar (07/07) +C <> Hazardous Air Pollutants that are believed to undergo significant dry +C deposition. Hydrazine and triethylamine reactivities are based on analogies +C to NH3. Maleic anhydride reactivity is assumed similar to aldehydes. +C Toluene diisocyanate and hexamethylene diisocyanate reactivities are +C assumed to be similar to SO2. Diffusivities are calculated with standard +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------------------------------------------------------------------------------- + + Use GRID_CONF ! horizontal & vertical domain specifications + Use LSM_MOD ! Land surface data + Use DEPVVARS, Only: ltotg + + Implicit None + + Include SUBST_CONST ! constants + + Type :: MET_Type +!> 2-D meteorological fields: + Real, Allocatable :: RDEPVHT ( :,: ) ! air dens / dep vel ht + 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 :: RC ( :,: ) ! convective precipitation [cm] + Real, Allocatable :: RN ( :,: ) ! non-convective precipitation [mc] + 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] + Real, Allocatable :: SNOCOV ( :,: ) ! Snow cover [1=yes, 0=no] + Real, Allocatable :: TEMP2 ( :,: ) ! two meter temperature [K] + Real, Allocatable :: TEMPG ( :,: ) ! skin temperature [K] + Real, Allocatable :: TSEASFC ( :,: ) ! SST [K] + Real, Allocatable :: USTAR ( :,: ) ! surface friction velocity [m/s] + Real, Allocatable :: VEG ( :,: ) ! fractional vegetation coverage [ratio] + Real, Allocatable :: LAI ( :,: ) ! grid cell leaf area index [m**2/m**2] + Real, Allocatable :: WR ( :,: ) ! precip intercepted by canopy [m] + Real, Allocatable :: WSPD10 ( :,: ) ! 10-m wind speed [m/s] + Real, Allocatable :: WSTAR ( :,: ) ! convective velocity scale [m/s] + Real, Allocatable :: Z0 ( :,: ) ! roughness length [m] + Real, Allocatable :: SOIM1 ( :,: ) ! 1 cm soil moisture [m**3/m**3] + Real, Allocatable :: SOIM2 ( :,: ) ! 1 m soil moisture [m**3/m**3] + Real, Allocatable :: SOIT1 ( :,: ) ! 1 cm soil temperature [K] + Real, Allocatable :: SOIT2 ( :,: ) ! 1 m soil temperature [K] + Real, Allocatable :: SEAICE ( :,: ) ! Sea ice coverage [%] + Real, Allocatable :: MOL ( :,: ) ! Monin-Obukhov length [m] + Real, Allocatable :: MOLI ( :,: ) ! inverse of Monin-Obukhov length [m] + Real, Allocatable :: HOL ( :,: ) ! PBL over Obukhov length + Real, Allocatable :: XPBL ( :,: ) ! PBL sigma height + 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) + +!> 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 + +!> 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 :: QV ( :,:,: ) ! water vapor mixing ratio + Real, Allocatable :: QC ( :,:,: ) ! cloud water mixing ratio + Real, Allocatable :: THETAV ( :,:,: ) ! potential temp + Real, Allocatable :: TA ( :,:,: ) ! temperature (K) + Real, Allocatable :: ZH ( :,:,: ) ! mid-layer height above ground [m] + Real, Allocatable :: ZF ( :,:,: ) ! layer height [m] + Real, Allocatable :: DZF ( :,:,: ) ! layer surface thickness + Real, Allocatable :: DENS ( :,:,: ) ! air density + Real, Allocatable :: RJACM ( :,:,: ) ! reciprocal mid-layer Jacobian + Real, Allocatable :: RJACF ( :,:,: ) ! reciprocal full-layer Jacobian + Real, Allocatable :: RRHOJ ( :,:,: ) ! reciprocal density X Jacobian + End Type MET_Type + + Type :: GRID_Type +!> Grid infomation: +!> Vertical information + Real, Allocatable :: DX3F ( : ) ! sigma layer surface thickness ! vdiffacmx.F + Real, Allocatable :: RDX3F ( : ) ! reciprocal sigma layer thickness ! EMIS_DEFN.F, sedi.F, vdiffacmx.F, vdiffproc.F + Real, Allocatable :: RDX3M ( : ) ! reciprocal sigma midlayer thickness ! vdiffproc.F +!> Horizontal Information: + Real, Allocatable :: RMSFX4 ( :,: ) ! inverse map scale factor ** 4 + 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 :: PURB ( :,: ) ! percent urban [%] + Integer, Allocatable :: SLTYP ( :,: ) ! soil type [category] + Real, Allocatable :: WSAT ( :,: ) ! soil wilting point + 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 :: RHOB ( :,: ) ! soil bulk density + 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 + + Integer, Save :: n_spc_m3dry = ltotg ! from DEPVVARS module +!> M3 asx constants + Real, Parameter :: a0 = 8.0 ! [dim'less] + Real, Parameter :: d3 = 1.38564e-2 ! [dim'less] + Real, Parameter :: dwat = 0.2178 ! [cm^2/s] at 273.15K + Real, Parameter :: hplus_ap = 1.0e-6 ! pH=6.0 leaf apoplast solution Ph (Massad et al 2008) + Real, Parameter :: hplus_def = 1.0e-5 ! pH=5.0 + Real, Parameter :: hplus_east = 1.0e-5 ! pH=5.0 + Real, Parameter :: hplus_h2o = 7.94328e-9 ! 10.0**(-8.1) + Real, Parameter :: hplus_west = 3.16228e-6 ! 10.0**(-5.5) + Real, Parameter :: kvis = 0.132 ! [cm^2 / s] at 273.15K + Real, Parameter :: pr = 0.709 ! [dim'less] + Real, Parameter :: rcut0 = 3000.0 ! [s/m] + Real, Parameter :: rcw0 = 125000.0 ! acc'd'g to Padro and + Real, Parameter :: resist_max = 1.0e30 ! maximum resistance + 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 :: 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 + Real, Parameter :: twothirds = 2.0 / 3.0 + Real, Parameter :: betah = 5.0 ! WRF 3.6 px uses Dyer + Real, Parameter :: gamah = 16.0 + Real, Parameter :: pr0 = 0.95 + Real, Parameter :: karman = 0.40 + Real, Parameter :: f3min = 0.25 + Real, Parameter :: ftmin = 0.0000001 ! m/s + Real, Parameter :: nscat = 16.0 + Real, Parameter :: rsmax = 5000.0 ! s/m + + Real :: ar ( ltotg ) ! reactivity relative to HNO3 + Real :: dif0 ( ltotg ) ! molecular diffusivity [cm2/s] + Real :: lebas ( ltotg ) ! Le Bas molar volume [cm3/mol ] + Real :: meso ( ltotg ) ! Exception for species that + ! react with cell walls. fo in + ! Wesely 1989 eq 6. + 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. + + Public :: INIT_MET + + Logical, Private, Save :: ifsst = .false. + Logical, Private, Save :: ifq2 = .false. + Logical, Private, Save :: rinv = .True. + Logical, Private, Save :: iflh = .false. + + Integer, Private :: C, R, L, S ! loop induction variables + Integer, Private :: SPC + Character( 16 ), Private, Save :: vname_rc, vname_rn, vname_uc, vname_vc + Real, Private, Save :: P0 ! reference pressure (100000.0 Pa) for Potential Temperature, note that in meteorology they do not use the SI 1 ATM. + + Integer, Private, Save :: LOGDEV + Integer, Private, Save :: GXOFF, GYOFF ! global origin offset from file + Integer, Private, Save :: STRTCOLMC3, ENDCOLMC3, STRTROWMC3, ENDROWMC3 ! MET_CRO_3D + Integer, Private, Save :: STRTCOLMD3, ENDCOLMD3, STRTROWMD3, ENDROWMD3 ! MET_DOT_3D + Integer, Private, Save :: STRTCOLMC2, ENDCOLMC2, STRTROWMC2, ENDROWMC2 ! MET_CRO_2D + Integer, Private, Save :: STRTCOL_O1, ENDCOL_O1, STRTROW_O1, ENDROW_O1 ! OCEAN_1 + + Real, Pointer, Private :: BUFF1D( : ) ! 1D temp var number of layers + Real, Pointer, Private :: BUFF2D( :,: ) ! 2D temp var + Real, Pointer, Private :: BUFF3D( :,:,: ) ! 3D temp var + +! FENGSHA option control + CHARACTER( 20 ), SAVE :: CTM_FENGSHA = 'CTM_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. + + CONTAINS + +C======================================================================= + Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) + +C----------------------------------------------------------------------- +C 30 Mar 01 J.Young: dyn alloc - Use HGRD_DEFN; replace INTERP3 with INTERPX; +C allocatable RDEPVHT, RJACM, RRHOJ +C 14 Nov 03 J.Young: add reciprocal vertical Jacobian product for full and +C mid-layer +C Tanya took JACOBF out of METCRO3D! Improvise +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----------------------------------------------------------------------- + + Use UTILIO_DEFN + + 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' + Character( 16 ) :: VNAME + CHARACTER( 16 ) :: UNITSCK + 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 + ALLOCATE ( BUFF1D( NLAYS ), + & BUFF2D( NCOLS,NROWS ), + & BUFF3D( NCOLS,NROWS,NLAYS ), STAT = ALLOCSTAT ) + If ( ALLOCSTAT .Ne. 0 ) Then + XMSG = 'Failure allocating Buffers' + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + + BUFF1D = 0.0 + BUFF2D = 0.0 + BUFF3D = 0.0 + +!> Allocate shared arrays +!> Met_Data + ALLOCATE( Met_Data%RDEPVHT ( NCOLS,NROWS ), + & Met_Data%DENS1 ( NCOLS,NROWS ), + & Met_Data%PRSFC ( NCOLS,NROWS ), + & Met_Data%Q2 ( NCOLS,NROWS ), + & Met_Data%QSS_GRND ( NCOLS,NROWS ), + & Met_Data%RH ( NCOLS,NROWS ), + & Met_Data%RA ( NCOLS,NROWS ), + & Met_Data%RS ( NCOLS,NROWS ), + & Met_Data%RC ( NCOLS,NROWS ), + & Met_Data%RN ( NCOLS,NROWS ), + & Met_Data%RGRND ( NCOLS,NROWS ), + & Met_Data%HFX ( NCOLS,NROWS ), + & Met_Data%LH ( NCOLS,NROWS ), + & Met_Data%SNOCOV ( NCOLS,NROWS ), + & Met_Data%TEMP2 ( NCOLS,NROWS ), + & Met_Data%TEMPG ( NCOLS,NROWS ), + & Met_Data%TSEASFC ( NCOLS,NROWS ), + & Met_Data%USTAR ( NCOLS,NROWS ), + & Met_Data%VEG ( NCOLS,NROWS ), + & Met_Data%LAI ( NCOLS,NROWS ), + & Met_Data%WR ( NCOLS,NROWS ), + & Met_Data%WSPD10 ( NCOLS,NROWS ), + & Met_Data%WSTAR ( NCOLS,NROWS ), + & Met_Data%Z0 ( NCOLS,NROWS ), + & Met_Data%SOIM1 ( NCOLS,NROWS ), + & Met_Data%SOIT1 ( NCOLS,NROWS ), + & Met_Data%SEAICE ( NCOLS,NROWS ), + & Met_Data%MOL ( NCOLS,NROWS ), + & Met_Data%MOLI ( NCOLS,NROWS ), + & Met_Data%HOL ( NCOLS,NROWS ), + & Met_Data%XPBL ( NCOLS,NROWS ), + & Met_Data%LPBL ( NCOLS,NROWS ), + & Met_Data%CONVCT ( NCOLS,NROWS ), + & Met_Data%PBL ( NCOLS,NROWS ), + & Met_Data%NACL_EMIS( NCOLS,NROWS ), + & Met_Data%UWIND ( NCOLS+1,NROWS+1,NLAYS ), + & Met_Data%VWIND ( NCOLS+1,NROWS+1,NLAYS ), + & Met_Data%KZMIN ( NCOLS,NROWS,NLAYS ), + & Met_Data%PRES ( NCOLS,NROWS,NLAYS ), + & Met_Data%QV ( NCOLS,NROWS,NLAYS ), + & Met_Data%QC ( NCOLS,NROWS,NLAYS ), + & Met_Data%THETAV ( NCOLS,NROWS,NLAYS ), + & Met_Data%TA ( NCOLS,NROWS,NLAYS ), + & Met_Data%ZH ( NCOLS,NROWS,NLAYS ), + & Met_Data%ZF ( NCOLS,NROWS,NLAYS ), + & Met_Data%DZF ( NCOLS,NROWS,NLAYS ), + & Met_Data%DENS ( NCOLS,NROWS,NLAYS ), + & Met_Data%RJACM ( NCOLS,NROWS,NLAYS ), + & Met_Data%RJACF ( NCOLS,NROWS,NLAYS ), + & Met_Data%RRHOJ ( NCOLS,NROWS,NLAYS ), + & STAT = ALLOCSTAT ) + If ( ALLOCSTAT .Ne. 0 ) Then + XMSG = 'Failure allocating met vars' + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + + ALLOCATE( Grid_Data%DX3F ( NLAYS ), + & Grid_Data%RDX3F ( NLAYS ), + & Grid_Data%RDX3M ( NLAYS ), + & Grid_Data%RMSFX4 ( NCOLS,NROWS ), + & Grid_Data%LON ( NCOLS,NROWS ), + & Grid_Data%LAT ( NCOLS,NROWS ), + & Grid_Data%LWMASK ( NCOLS,NROWS ), + & Grid_Data%OCEAN ( NCOLS,NROWS ), + & Grid_Data%SZONE ( NCOLS,NROWS ), + & Grid_Data%PURB ( NCOLS,NROWS ), + & Grid_Data%SLTYP ( NCOLS,NROWS ), + & Grid_Data%NAME ( n_lufrac ), + & Grid_Data%LU_Type ( n_lufrac ), + & STAT = ALLOCSTAT ) + If ( ALLOCSTAT .Ne. 0 ) Then + XMSG = 'Failure allocating grid vars' + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + Grid_Data%NAME = name_lu + Grid_Data%LU_Type = cat_lu + + If ( ABFLUX .Or. HGBIDI .Or. MOSAIC ) Then + ALLOCATE( Met_Data%SOIM2 ( NCOLS,NROWS ), + & Met_Data%SOIT2 ( NCOLS,NROWS ), + & STAT = ALLOCSTAT ) + If ( ALLOCSTAT .Ne. 0 ) Then + XMSG = 'Failure allocating mosaic met vars' + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + + ALLOCATE( Grid_Data%WSAT ( NCOLS,NROWS ), + & Grid_Data%WWLT ( NCOLS,NROWS ), + & Grid_Data%BSLP ( NCOLS,NROWS ), + & Grid_Data%WRES ( NCOLS,NROWS ), + & Grid_Data%WFC ( NCOLS,NROWS ), + & Grid_Data%LUFRAC ( NCOLS,NROWS,n_lufrac ), + & STAT = ALLOCSTAT ) + If ( ALLOCSTAT .Ne. 0 ) Then + XMSG = 'Failure allocating mosaic 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 + + 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 ), + & STAT = ALLOCSTAT ) + If ( ALLOCSTAT .Ne. 0 ) Then + XMSG = 'Failure allocating chemistry dependent mosaic vars' + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + ChemMos_Data%Rb = resist_max + ChemMos_Data%Rst = resist_max + ChemMos_Data%Rcut = resist_max + ChemMos_Data%Rgc = resist_max + ChemMos_Data%Rgb = resist_max + ChemMos_Data%Rwat = resist_max + ChemMos_Data%CZ0 = 0.0 + ChemMos_Data%Cleaf = 0.0 + ChemMos_Data%Cstom = 0.0 + ChemMos_Data%Ccut = 0.0 + ChemMos_Data%Csoil = 0.0 + ChemMos_Data%NAME = name_lu + ChemMos_Data%LU_Type = cat_lu + ChemMos_Data%SubName = subname + End If + +!> ccccccccccccccccccccc Fengsha option!ccccccccccccccccccccc + FENGSHA = ENVYN( 'CTM_FENGSHA', + & 'Flag for in-line fengsha ', + & .FALSE., IOSX ) + + If ( FENGSHA ) Then + ALLOCATE( Met_Data%CLAYF ( NCOLS,NROWS ), + & Met_Data%SANDF ( NCOLS,NROWS ), + & Met_Data%DRAG ( NCOLS,NROWS ), + & Met_Data%UTHR ( NCOLS,NROWS ), + & STAT = ALLOCSTAT ) + If ( ALLOCSTAT .Ne. 0 ) Then + XMSG = 'Failure allocating Fengsha variables' + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + End If + +!> ccccccccccccccccccccc enable backward compatiblity ccccccccccccccccccccc + + If ( .Not. desc3( met_cro_2d ) ) Then + xmsg = 'Could not get ' // MET_CRO_2D // ' file description' + Call m3exit( pname, JDATE, JTIME, xmsg, xstat2 ) + End If + + SPC = INDEX1( 'RA', NVARS3D, VNAME3D ) + If (SPC .Gt. 0) rinv = .FALSE. ! Ra and Rst are in units s/m + + SPC = INDEX1( 'WR', NVARS3D, VNAME3D ) + If (SPC .Gt. 0) ifwr = .True. ! canopy wetness is in METCRO2D + + SPC = INDEX1( 'Q2', NVARS3D, VNAME3D ) + If (SPC .Gt. 0) ifq2 = .True. ! two meter mixing ratio in METCRO2D + + SPC = INDEX1( 'TSEASFC', NVARS3D, VNAME3D ) + If (SPC .Gt. 0) ifsst = .True. ! two meter SST in METCRO2D + + SPC = INDEX1( 'LH', NVARS3D, VNAME3D ) + If (SPC .Gt. 0) iflh = .True. ! LH in METCRO2D + + SPC = INDEX1( 'RCA', NVARS3D, VNAME3D ) + If (SPC .Gt. 0) Then + vname_rc = 'RCA' + Else + vname_rc = 'RC' + End If + + SPC = INDEX1( 'RNA', NVARS3D, VNAME3D ) + If (SPC .Gt. 0) 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 + vname_uc = 'UWINDC' + CSTAGUV = .TRUE. + Else + vname_uc = 'UWIND' + CSTAGUV = .FALSE. + End If + + SPC = INDEX1( 'VWINDC', NVARS3D, VNAME3D ) + If (SPC .Gt. 0) 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 ) ) + End Do + Do L = 1, NLAYS - 1 + Grid_Data%RDX3M( L ) = 1.0 / ( X3M( L+1 ) - X3M( 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 + + 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 + + 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 + + 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 + + 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%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 + + 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 ) ) + Grid_Data%WWLT( C,R ) = WWLT( Grid_Data%SLTYP( C,R ) ) + Grid_Data%WFC ( C,R ) = WFC ( Grid_Data%SLTYP( C,R ) ) + 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 + + MET_INITIALIZED = .true. + + Return + End Subroutine INIT_MET + +C======================================================================= + Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) + +C----------------------------------------------------------------------- +C 30 Mar 01 J.Young: dyn alloc - Use HGRD_DEFN; replace INTERP3 with INTERPX; +C allocatable RDEPVHT, RJACM, RRHOJ +C 14 Nov 03 J.Young: add reciprocal vertical Jacobian product for full and +C mid-layer +C Tanya took JACOBF out of METCRO3D! Improvise +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----------------------------------------------------------------------- + + USE GRID_CONF ! horizontal & vertical domain specifications + Use UTILIO_DEFN +#ifdef parallel + USE SE_MODULES ! stenex (using SE_COMM_MODULE) +#else + USE NOOP_MODULES ! stenex (using NOOP_COMM_MODULE) +#endif + + Implicit None + + 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] + Real, Parameter :: KZMAXL = 500.0 ! upper limit for min Kz [m] + Real, Parameter :: KZ0UT = 1.0 ! minimum eddy diffusivity [m**2/sec] KZ0 + Real, Parameter :: KZL = 0.01 ! lowest KZ + Real, Parameter :: KZU = 1.0 ! 2.0 ! highest KZ + Real, Parameter :: EPS = 1.0E-08 ! small number for temperature difference + +C Local variables: + 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 + + Character( 16 ) :: PNAME = 'GET_MET' + Character( 16 ) :: VNAME + CharactER( 30 ) :: MSG1 = ' Error interpolating variable ' + Character( 96 ) :: XMSG = ' ' + +C----------------------------------------------------------------------- +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 + + 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 + + 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 + + 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 + + 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 + + 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 + + Met_Data%RRHOJ = 1.0 / Met_Data%RRHOJ + + VNAME = 'TA' + IF ( .NOT. INTERPX( MET_CRO_3D, VNAME, PNAME, + & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, + & JDATE, JTIME, Met_Data%TA ) ) THEN + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D + CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + VNAME = 'QV' + IF ( .NOT. INTERPX( MET_CRO_3D, VNAME, PNAME, + & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, + & JDATE, JTIME, Met_Data%QV ) ) THEN + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D + CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + VNAME = 'QC' + IF ( .NOT. INTERPX( MET_CRO_3D, VNAME, PNAME, + & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, + & JDATE, JTIME, Met_Data%QC ) ) THEN + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D + CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + +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 + + 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 + + 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 + If ( FENGSHA ) Then + write(*,*) 'Read clayfrac' + VNAME = 'CLAYF' + write(*,*) VNAME, PNAME + write(*,*) JDATE, JTIME + write(*,*) STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2 + 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 + write(*,*) 'read sandfrac' + 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 + + write(*,*) 'read drag' + 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 + write(*,*) 'Read uthr' + VNAME = 'UTHR' + If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, + & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2,1,1, + & JDATE, JTIME, Met_Data%UTHR ) ) Then + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + End If +C Soil vars + VNAME = 'SOIM1' + If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, + & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, + & JDATE, JTIME, Met_Data%SOIM1 ) ) Then + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + + If ( ABFLUX .Or. HGBIDI .Or. MOSAIC ) Then + VNAME = 'SOIM2' + If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, + & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, + & JDATE, JTIME, Met_Data%SOIM2 ) ) Then + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + + 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 + + VNAME = 'SOIT1' + If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, + & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, + & JDATE, JTIME, Met_Data%SOIT1 ) ) Then + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + + 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 ) + End If + +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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + 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 + 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 + + 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 + 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 + 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 + + Where( Met_Data%RA .Gt. cond_min ) + Met_Data%RA = 1.0/Met_Data%RA + Elsewhere + 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 + + Where( Met_Data%RS .Gt. cond_min ) + Met_Data%RS = 1.0 / Met_Data%RS + Elsewhere + Met_Data%RS = resist_max + End Where + + 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 + + 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 + + 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 + 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 ) ) + Elsewhere + Es_Grnd = 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 ) + + Es_Air => BUFF2D + Where( Met_Data%TEMP2 .Lt. stdtemp ) + Es_Air = vp0 *Exp( 22.514 - ( 6.15e3 / Met_Data%TEMP2 ) ) + Elsewhere + Es_Air = 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 + End Where + Nullify( Es_Air ) + +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 + + 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 + +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 ) + CALL SUBST_COMM ( Met_Data%VWIND, DSPL_N1_E0_S0_W0, DRCN_N ) + +C-------------------------------- Calculated Variables -------------------------------- + Met_Data%DZF = Met_Data%ZF - EOSHIFT(Met_Data%ZF, Shift = -1, Boundary = 0.0, Dim = 3) + + Met_Data%RDEPVHT = 1.0 / Met_Data%ZF( :,:,1 ) + + IF ( MINKZ ) THEN + Met_Data%KZMIN = KZL + DO L = 1, NLAYS + Where( Met_Data%ZF( :,:,L ) .LE. KZMAXL ) + Met_Data%KZMIN( :,:,L ) = KZL + ( KZU - KZL ) * 0.01 * Grid_data%PURB + End Where + End Do + ELSE + 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 ) + +C------ Updating MOL, then WSTAR, MOLI, HOL + DO R = 1, MY_NROWS + DO C = 1, MY_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 ) ) + TMPVTCON = 1.0 + 0.608 * Met_Data%QV( C,R,1 ) ! Conversion factor for virtual temperature + TST = -TMPFX / Met_Data%USTAR( C,R ) + IF ( Met_Data%TA( C,R,1 ) .GT. STDTEMP ) THEN + LV = LV0 - ( 0.00237 * ( Met_Data%TA( C,R,1 ) - STDTEMP ) ) * 1.0E6 + ELSE + LV = 2.83E6 ! Latent heat of sublimation at 0C from Stull (1988) (J/KG) + END IF + QST = -( Met_Data%LH( C,R ) / LV ) + & / ( Met_Data%USTAR( C,R ) * Met_Data%DENS( C,R,1 ) ) + TSTV = TST * TMPVTCON + Met_Data%THETAV( C,R,1 ) * 0.608 * QST + IF ( ABS( TSTV ) .LT. 1.0E-6 ) THEN + TSTV = SIGN( 1.0E-6, TSTV ) + END IF + Met_Data%MOL( C,R ) = Met_Data%THETAV( C,R,1 ) + & * Met_Data%USTAR( C,R ) ** 2 / ( karman * GRAV * TSTV ) + IF ( Met_Data%MOL( C,R ) .LT. 0.0 ) THEN + Met_Data%WSTAR( C,R ) = Met_Data%USTAR( C,R ) * ( Met_Data%PBL( C,R ) + & / ( karman * ABS( Met_Data%MOL( C,R ) ) ) ) ** 0.333333 + ELSE + Met_Data%WSTAR( C,R ) = 0.0 + END IF + + END DO + END DO + + Met_Data%MOLI = 1.0 / Met_Data%MOL + Met_Data%HOL = Met_Data%PBL / Met_Data%MOL +C------ + + Met_Data%CONVCT = .FALSE. + DO R = 1, MY_NROWS + DO C = 1, MY_NCOLS + DO L = 1, NLAYS + IF ( Met_Data%PBL( C,R ) .LT. Met_Data%ZF( C,R,L ) ) THEN + LP = L; EXIT + END IF + END DO + + Met_Data%LPBL( C,R ) = LP + If ( LP .Eq. 1 ) Then + FINT = ( Met_Data%PBL( C,R ) ) + & / ( Met_Data%ZF( C,R,LP ) ) + Met_Data%XPBL( C,R ) = FINT * ( X3FACE_GD( LP ) - X3FACE_GD( LP-1 ) ) + & + X3FACE_GD( LP-1 ) + Else + FINT = ( Met_Data%PBL( C,R ) - Met_Data%ZF( C,R,LP-1 ) ) + & / ( Met_Data%ZF( C,R,LP ) - Met_Data%ZF( C,R,LP-1 ) ) + Met_Data%XPBL( C,R ) = FINT * ( X3FACE_GD( LP ) - X3FACE_GD( LP-1 ) ) + & + X3FACE_GD( LP-1 ) + End If + END DO + END DO + Where( Met_Data%THETAV( :,:,1 ) - Met_Data%THETAV( :,:,2 ) .Gt. EPS .And. + & Met_Data%HOL .Lt. -0.02 .And. Met_Data%LPBL .Gt. 3 ) + Met_Data%CONVCT = .True. + End Where + + Return + End Subroutine GET_MET + + End Module ASX_DATA_MOD diff --git a/src/model/src/ASX_DATA_MOD.F~ b/src/model/src/ASX_DATA_MOD.F~ new file mode 100755 index 0000000..0e7b79e --- /dev/null +++ b/src/model/src/ASX_DATA_MOD.F~ @@ -0,0 +1,1459 @@ +!------------------------------------------------------------------------! +! The Community Multiscale Air Quality (CMAQ) system software is in ! +! continuous development by various groups and is based on information ! +! from these groups: Federal Government employees, contractors working ! +! within a United States Government contract, and non-Federal sources ! +! including research institutions. These groups give the Government ! +! permission to use, prepare derivative works of, and distribute copies ! +! of their work in the CMAQ system to the public and to permit others ! +! to do so. The United States Environmental Protection Agency ! +! therefore grants similar permission to use the CMAQ system software, ! +! but users are requested to provide copies of derivative works or ! +! products designed to operate in the CMAQ system to the United States ! +! Government without restrictions as to use by others. Software ! +! that is used with the CMAQ system but distributed under the GNU ! +! General Public License or the GNU Lesser General Public License is ! +! subject to their copyright restrictions. ! +!------------------------------------------------------------------------! + +C::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: + Module ASX_DATA_MOD + +C----------------------------------------------------------------------- +C Function: User-defined types + +C Revision History: +C 19 Aug 2014 J.Bash: initial implementation +C 17 July 2015 H.Foroutan: Updated the calculation of MOL, MOLI, HOL, and WSTAR +C 25 Aug 2015 H. Pye: Added IEPOX, HACET surrogates +C modified PROPNN and H2O2 +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 +C---------Notes +C * Updates based on literature review 7/96 JEP +C # Diff and H based on Wesely (1988) same as RADM +C + Estimated by JEP 2/97 +C @ Updated by JEP 9/01 +C ~ Added by YW 1/02. Dif0 based on Massman (1998). Henry's Law constant +C is defined here as: h=cg/ca, where cg is the concentration of a species +C in gas-phase, and ca is its aqueous-phase concentration. The smaller h, +C the larger solubility. Henry's Law constant in another definition (KH): +C KH = ca/pg [M/atm], KH = KH0 * exp(-DKH/R(1/T-1/T0)), where KH0 and -DKH +C values are from Rolf Sander (1999). h=1/(KH*R*T). +C ** Update by DBS based on estimates by JEP 1/03 +C ^^ From Bill Massman, personal communication 4/03 +C ## Diffusivity calculated by SPARC, reactivity = other aldehydes +C ++ Dif0 in Massman is diffusivity at temperature 0C and 1 atm (101.325kPa), so +C chemicals that were not in Massman's paper need to be adjusted. We assume +C JEP's original values were for 25C and 1 atm. +C % Added by G. Sarwar (10/04) +C $ Added by R. Bullock (02/05) HG diffusivity is from Massman (1999). +C HGIIGAS diffusivity calculated from the HG value and a mol. wt. scaling +C factor of MW**(-2/3) from EPA/600/3-87/015. ORD, Athens, GA. HGIIGAS +C mol.wt. used is that of HgCl2. Reactivity of HG is 1/20th of NO and NO2 +C values based on general atmospheric lifetimes of each species. Reactivity +C of HGIIGAS is based on HNO3 surrogate. +C @@ Mesophyll resistances for NO, NO2, and CO added by J. Pleim (07/07) based +C on values in Pleim, Venkatram, and Yamartino, 1984: ADOM/TADAP Model +C Development Program, Volume 4, The Dry Deposition Module. ERT, Inc., +C Concord, MA (peer reviewed). +C ~~ Reactivity for PAN changed from 4.0 to 16.0 by J. Pleim (07/07) based on +C comparisons with Turnipseed et al., JGR, 2006. +C %% Species ICL1 and ICL2 are removed, not used in CB05. G. Sarwar (07/07) +C <> Hazardous Air Pollutants that are believed to undergo significant dry +C deposition. Hydrazine and triethylamine reactivities are based on analogies +C to NH3. Maleic anhydride reactivity is assumed similar to aldehydes. +C Toluene diisocyanate and hexamethylene diisocyanate reactivities are +C assumed to be similar to SO2. Diffusivities are calculated with standard +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------------------------------------------------------------------------------- + + Use GRID_CONF ! horizontal & vertical domain specifications + Use LSM_MOD ! Land surface data + Use DEPVVARS, Only: ltotg + + Implicit None + + Include SUBST_CONST ! constants + + Type :: MET_Type +!> 2-D meteorological fields: + Real, Allocatable :: RDEPVHT ( :,: ) ! air dens / dep vel ht + 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 :: RC ( :,: ) ! convective precipitation [cm] + Real, Allocatable :: RN ( :,: ) ! non-convective precipitation [mc] + 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] + Real, Allocatable :: SNOCOV ( :,: ) ! Snow cover [1=yes, 0=no] + Real, Allocatable :: TEMP2 ( :,: ) ! two meter temperature [K] + Real, Allocatable :: TEMPG ( :,: ) ! skin temperature [K] + Real, Allocatable :: TSEASFC ( :,: ) ! SST [K] + Real, Allocatable :: USTAR ( :,: ) ! surface friction velocity [m/s] + Real, Allocatable :: VEG ( :,: ) ! fractional vegetation coverage [ratio] + Real, Allocatable :: LAI ( :,: ) ! grid cell leaf area index [m**2/m**2] + Real, Allocatable :: WR ( :,: ) ! precip intercepted by canopy [m] + Real, Allocatable :: WSPD10 ( :,: ) ! 10-m wind speed [m/s] + Real, Allocatable :: WSTAR ( :,: ) ! convective velocity scale [m/s] + Real, Allocatable :: Z0 ( :,: ) ! roughness length [m] + Real, Allocatable :: SOIM1 ( :,: ) ! 1 cm soil moisture [m**3/m**3] + Real, Allocatable :: SOIM2 ( :,: ) ! 1 m soil moisture [m**3/m**3] + Real, Allocatable :: SOIT1 ( :,: ) ! 1 cm soil temperature [K] + Real, Allocatable :: SOIT2 ( :,: ) ! 1 m soil temperature [K] + Real, Allocatable :: SEAICE ( :,: ) ! Sea ice coverage [%] + Real, Allocatable :: MOL ( :,: ) ! Monin-Obukhov length [m] + Real, Allocatable :: MOLI ( :,: ) ! inverse of Monin-Obukhov length [m] + Real, Allocatable :: HOL ( :,: ) ! PBL over Obukhov length + Real, Allocatable :: XPBL ( :,: ) ! PBL sigma height + 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) + +!> 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 + +!> 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 :: QV ( :,:,: ) ! water vapor mixing ratio + Real, Allocatable :: QC ( :,:,: ) ! cloud water mixing ratio + Real, Allocatable :: THETAV ( :,:,: ) ! potential temp + Real, Allocatable :: TA ( :,:,: ) ! temperature (K) + Real, Allocatable :: ZH ( :,:,: ) ! mid-layer height above ground [m] + Real, Allocatable :: ZF ( :,:,: ) ! layer height [m] + Real, Allocatable :: DZF ( :,:,: ) ! layer surface thickness + Real, Allocatable :: DENS ( :,:,: ) ! air density + Real, Allocatable :: RJACM ( :,:,: ) ! reciprocal mid-layer Jacobian + Real, Allocatable :: RJACF ( :,:,: ) ! reciprocal full-layer Jacobian + Real, Allocatable :: RRHOJ ( :,:,: ) ! reciprocal density X Jacobian + End Type MET_Type + + Type :: GRID_Type +!> Grid infomation: +!> Vertical information + Real, Allocatable :: DX3F ( : ) ! sigma layer surface thickness ! vdiffacmx.F + Real, Allocatable :: RDX3F ( : ) ! reciprocal sigma layer thickness ! EMIS_DEFN.F, sedi.F, vdiffacmx.F, vdiffproc.F + Real, Allocatable :: RDX3M ( : ) ! reciprocal sigma midlayer thickness ! vdiffproc.F +!> Horizontal Information: + Real, Allocatable :: RMSFX4 ( :,: ) ! inverse map scale factor ** 4 + 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 :: PURB ( :,: ) ! percent urban [%] + Integer, Allocatable :: SLTYP ( :,: ) ! soil type [category] + Real, Allocatable :: WSAT ( :,: ) ! soil wilting point + 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 :: RHOB ( :,: ) ! soil bulk density + 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 + + Integer, Save :: n_spc_m3dry = ltotg ! from DEPVVARS module +!> M3 asx constants + Real, Parameter :: a0 = 8.0 ! [dim'less] + Real, Parameter :: d3 = 1.38564e-2 ! [dim'less] + Real, Parameter :: dwat = 0.2178 ! [cm^2/s] at 273.15K + Real, Parameter :: hplus_ap = 1.0e-6 ! pH=6.0 leaf apoplast solution Ph (Massad et al 2008) + Real, Parameter :: hplus_def = 1.0e-5 ! pH=5.0 + Real, Parameter :: hplus_east = 1.0e-5 ! pH=5.0 + Real, Parameter :: hplus_h2o = 7.94328e-9 ! 10.0**(-8.1) + Real, Parameter :: hplus_west = 3.16228e-6 ! 10.0**(-5.5) + Real, Parameter :: kvis = 0.132 ! [cm^2 / s] at 273.15K + Real, Parameter :: pr = 0.709 ! [dim'less] + Real, Parameter :: rcut0 = 3000.0 ! [s/m] + Real, Parameter :: rcw0 = 125000.0 ! acc'd'g to Padro and + Real, Parameter :: resist_max = 1.0e30 ! maximum resistance + 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 :: 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 + Real, Parameter :: twothirds = 2.0 / 3.0 + Real, Parameter :: betah = 5.0 ! WRF 3.6 px uses Dyer + Real, Parameter :: gamah = 16.0 + Real, Parameter :: pr0 = 0.95 + Real, Parameter :: karman = 0.40 + Real, Parameter :: f3min = 0.25 + Real, Parameter :: ftmin = 0.0000001 ! m/s + Real, Parameter :: nscat = 16.0 + Real, Parameter :: rsmax = 5000.0 ! s/m + + Real :: ar ( ltotg ) ! reactivity relative to HNO3 + Real :: dif0 ( ltotg ) ! molecular diffusivity [cm2/s] + Real :: lebas ( ltotg ) ! Le Bas molar volume [cm3/mol ] + Real :: meso ( ltotg ) ! Exception for species that + ! react with cell walls. fo in + ! Wesely 1989 eq 6. + 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. + + Public :: INIT_MET + + Logical, Private, Save :: ifsst = .false. + Logical, Private, Save :: ifq2 = .false. + Logical, Private, Save :: rinv = .True. + Logical, Private, Save :: iflh = .false. + + Integer, Private :: C, R, L, S ! loop induction variables + Integer, Private :: SPC + Character( 16 ), Private, Save :: vname_rc, vname_rn, vname_uc, vname_vc + Real, Private, Save :: P0 ! reference pressure (100000.0 Pa) for Potential Temperature, note that in meteorology they do not use the SI 1 ATM. + + Integer, Private, Save :: LOGDEV + Integer, Private, Save :: GXOFF, GYOFF ! global origin offset from file + Integer, Private, Save :: STRTCOLMC3, ENDCOLMC3, STRTROWMC3, ENDROWMC3 ! MET_CRO_3D + Integer, Private, Save :: STRTCOLMD3, ENDCOLMD3, STRTROWMD3, ENDROWMD3 ! MET_DOT_3D + Integer, Private, Save :: STRTCOLMC2, ENDCOLMC2, STRTROWMC2, ENDROWMC2 ! MET_CRO_2D + Integer, Private, Save :: STRTCOL_O1, ENDCOL_O1, STRTROW_O1, ENDROW_O1 ! OCEAN_1 + + Real, Pointer, Private :: BUFF1D( : ) ! 1D temp var number of layers + Real, Pointer, Private :: BUFF2D( :,: ) ! 2D temp var + Real, Pointer, Private :: BUFF3D( :,:,: ) ! 3D temp var + +! FENGSHA option control + CHARACTER( 20 ), SAVE :: CTM_FENGSHA = 'CTM_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. + + CONTAINS + +C======================================================================= + Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) + +C----------------------------------------------------------------------- +C 30 Mar 01 J.Young: dyn alloc - Use HGRD_DEFN; replace INTERP3 with INTERPX; +C allocatable RDEPVHT, RJACM, RRHOJ +C 14 Nov 03 J.Young: add reciprocal vertical Jacobian product for full and +C mid-layer +C Tanya took JACOBF out of METCRO3D! Improvise +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----------------------------------------------------------------------- + + Use UTILIO_DEFN + + 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' + Character( 16 ) :: VNAME + CHARACTER( 16 ) :: UNITSCK + 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 + ALLOCATE ( BUFF1D( NLAYS ), + & BUFF2D( NCOLS,NROWS ), + & BUFF3D( NCOLS,NROWS,NLAYS ), STAT = ALLOCSTAT ) + If ( ALLOCSTAT .Ne. 0 ) Then + XMSG = 'Failure allocating Buffers' + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + + BUFF1D = 0.0 + BUFF2D = 0.0 + BUFF3D = 0.0 + +!> Allocate shared arrays +!> Met_Data + ALLOCATE( Met_Data%RDEPVHT ( NCOLS,NROWS ), + & Met_Data%DENS1 ( NCOLS,NROWS ), + & Met_Data%PRSFC ( NCOLS,NROWS ), + & Met_Data%Q2 ( NCOLS,NROWS ), + & Met_Data%QSS_GRND ( NCOLS,NROWS ), + & Met_Data%RH ( NCOLS,NROWS ), + & Met_Data%RA ( NCOLS,NROWS ), + & Met_Data%RS ( NCOLS,NROWS ), + & Met_Data%RC ( NCOLS,NROWS ), + & Met_Data%RN ( NCOLS,NROWS ), + & Met_Data%RGRND ( NCOLS,NROWS ), + & Met_Data%HFX ( NCOLS,NROWS ), + & Met_Data%LH ( NCOLS,NROWS ), + & Met_Data%SNOCOV ( NCOLS,NROWS ), + & Met_Data%TEMP2 ( NCOLS,NROWS ), + & Met_Data%TEMPG ( NCOLS,NROWS ), + & Met_Data%TSEASFC ( NCOLS,NROWS ), + & Met_Data%USTAR ( NCOLS,NROWS ), + & Met_Data%VEG ( NCOLS,NROWS ), + & Met_Data%LAI ( NCOLS,NROWS ), + & Met_Data%WR ( NCOLS,NROWS ), + & Met_Data%WSPD10 ( NCOLS,NROWS ), + & Met_Data%WSTAR ( NCOLS,NROWS ), + & Met_Data%Z0 ( NCOLS,NROWS ), + & Met_Data%SOIM1 ( NCOLS,NROWS ), + & Met_Data%SOIT1 ( NCOLS,NROWS ), + & Met_Data%SEAICE ( NCOLS,NROWS ), + & Met_Data%MOL ( NCOLS,NROWS ), + & Met_Data%MOLI ( NCOLS,NROWS ), + & Met_Data%HOL ( NCOLS,NROWS ), + & Met_Data%XPBL ( NCOLS,NROWS ), + & Met_Data%LPBL ( NCOLS,NROWS ), + & Met_Data%CONVCT ( NCOLS,NROWS ), + & Met_Data%PBL ( NCOLS,NROWS ), + & Met_Data%NACL_EMIS( NCOLS,NROWS ), + & Met_Data%UWIND ( NCOLS+1,NROWS+1,NLAYS ), + & Met_Data%VWIND ( NCOLS+1,NROWS+1,NLAYS ), + & Met_Data%KZMIN ( NCOLS,NROWS,NLAYS ), + & Met_Data%PRES ( NCOLS,NROWS,NLAYS ), + & Met_Data%QV ( NCOLS,NROWS,NLAYS ), + & Met_Data%QC ( NCOLS,NROWS,NLAYS ), + & Met_Data%THETAV ( NCOLS,NROWS,NLAYS ), + & Met_Data%TA ( NCOLS,NROWS,NLAYS ), + & Met_Data%ZH ( NCOLS,NROWS,NLAYS ), + & Met_Data%ZF ( NCOLS,NROWS,NLAYS ), + & Met_Data%DZF ( NCOLS,NROWS,NLAYS ), + & Met_Data%DENS ( NCOLS,NROWS,NLAYS ), + & Met_Data%RJACM ( NCOLS,NROWS,NLAYS ), + & Met_Data%RJACF ( NCOLS,NROWS,NLAYS ), + & Met_Data%RRHOJ ( NCOLS,NROWS,NLAYS ), + & STAT = ALLOCSTAT ) + If ( ALLOCSTAT .Ne. 0 ) Then + XMSG = 'Failure allocating met vars' + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + + ALLOCATE( Grid_Data%DX3F ( NLAYS ), + & Grid_Data%RDX3F ( NLAYS ), + & Grid_Data%RDX3M ( NLAYS ), + & Grid_Data%RMSFX4 ( NCOLS,NROWS ), + & Grid_Data%LON ( NCOLS,NROWS ), + & Grid_Data%LAT ( NCOLS,NROWS ), + & Grid_Data%LWMASK ( NCOLS,NROWS ), + & Grid_Data%OCEAN ( NCOLS,NROWS ), + & Grid_Data%SZONE ( NCOLS,NROWS ), + & Grid_Data%PURB ( NCOLS,NROWS ), + & Grid_Data%SLTYP ( NCOLS,NROWS ), + & Grid_Data%NAME ( n_lufrac ), + & Grid_Data%LU_Type ( n_lufrac ), + & STAT = ALLOCSTAT ) + If ( ALLOCSTAT .Ne. 0 ) Then + XMSG = 'Failure allocating grid vars' + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + Grid_Data%NAME = name_lu + Grid_Data%LU_Type = cat_lu + + If ( ABFLUX .Or. HGBIDI .Or. MOSAIC ) Then + ALLOCATE( Met_Data%SOIM2 ( NCOLS,NROWS ), + & Met_Data%SOIT2 ( NCOLS,NROWS ), + & STAT = ALLOCSTAT ) + If ( ALLOCSTAT .Ne. 0 ) Then + XMSG = 'Failure allocating mosaic met vars' + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + + ALLOCATE( Grid_Data%WSAT ( NCOLS,NROWS ), + & Grid_Data%WWLT ( NCOLS,NROWS ), + & Grid_Data%BSLP ( NCOLS,NROWS ), + & Grid_Data%WRES ( NCOLS,NROWS ), + & Grid_Data%WFC ( NCOLS,NROWS ), + & Grid_Data%LUFRAC ( NCOLS,NROWS,n_lufrac ), + & STAT = ALLOCSTAT ) + If ( ALLOCSTAT .Ne. 0 ) Then + XMSG = 'Failure allocating mosaic 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 + + 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 ), + & STAT = ALLOCSTAT ) + If ( ALLOCSTAT .Ne. 0 ) Then + XMSG = 'Failure allocating chemistry dependent mosaic vars' + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + ChemMos_Data%Rb = resist_max + ChemMos_Data%Rst = resist_max + ChemMos_Data%Rcut = resist_max + ChemMos_Data%Rgc = resist_max + ChemMos_Data%Rgb = resist_max + ChemMos_Data%Rwat = resist_max + ChemMos_Data%CZ0 = 0.0 + ChemMos_Data%Cleaf = 0.0 + ChemMos_Data%Cstom = 0.0 + ChemMos_Data%Ccut = 0.0 + ChemMos_Data%Csoil = 0.0 + ChemMos_Data%NAME = name_lu + ChemMos_Data%LU_Type = cat_lu + ChemMos_Data%SubName = subname + End If + +!> ccccccccccccccccccccc Fengsha option!ccccccccccccccccccccc + FENGSHA = ENVYN( 'CTM_FENGSHA', + & 'Flag for in-line fengsha ', + & .FALSE., IOSX ) + + If ( FENGSHA ) Then + ALLOCATE( Met_Data%CLAYF ( NCOLS,NROWS ), + & Met_Data%SANDF ( NCOLS,NROWS ), + & Met_Data%DRAG ( NCOLS,NROWS ), + & Met_Data%UTHR ( NCOLS,NROWS ), + & STAT = ALLOCSTAT ) + If ( ALLOCSTAT .Ne. 0 ) Then + XMSG = 'Failure allocating Fengsha variables' + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + End If + +!> ccccccccccccccccccccc enable backward compatiblity ccccccccccccccccccccc + + If ( .Not. desc3( met_cro_2d ) ) Then + xmsg = 'Could not get ' // MET_CRO_2D // ' file description' + Call m3exit( pname, JDATE, JTIME, xmsg, xstat2 ) + End If + + SPC = INDEX1( 'RA', NVARS3D, VNAME3D ) + If (SPC .Gt. 0) rinv = .FALSE. ! Ra and Rst are in units s/m + + SPC = INDEX1( 'WR', NVARS3D, VNAME3D ) + If (SPC .Gt. 0) ifwr = .True. ! canopy wetness is in METCRO2D + + SPC = INDEX1( 'Q2', NVARS3D, VNAME3D ) + If (SPC .Gt. 0) ifq2 = .True. ! two meter mixing ratio in METCRO2D + + SPC = INDEX1( 'TSEASFC', NVARS3D, VNAME3D ) + If (SPC .Gt. 0) ifsst = .True. ! two meter SST in METCRO2D + + SPC = INDEX1( 'LH', NVARS3D, VNAME3D ) + If (SPC .Gt. 0) iflh = .True. ! LH in METCRO2D + + SPC = INDEX1( 'RCA', NVARS3D, VNAME3D ) + If (SPC .Gt. 0) Then + vname_rc = 'RCA' + Else + vname_rc = 'RC' + End If + + SPC = INDEX1( 'RNA', NVARS3D, VNAME3D ) + If (SPC .Gt. 0) 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 + vname_uc = 'UWINDC' + CSTAGUV = .TRUE. + Else + vname_uc = 'UWIND' + CSTAGUV = .FALSE. + End If + + SPC = INDEX1( 'VWINDC', NVARS3D, VNAME3D ) + If (SPC .Gt. 0) 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 ) ) + End Do + Do L = 1, NLAYS - 1 + Grid_Data%RDX3M( L ) = 1.0 / ( X3M( L+1 ) - X3M( 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 + + 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 + + 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 + + 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 + + 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%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 + + 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 ) ) + Grid_Data%WWLT( C,R ) = WWLT( Grid_Data%SLTYP( C,R ) ) + Grid_Data%WFC ( C,R ) = WFC ( Grid_Data%SLTYP( C,R ) ) + 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 + + MET_INITIALIZED = .true. + + Return + End Subroutine INIT_MET + +C======================================================================= + Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) + +C----------------------------------------------------------------------- +C 30 Mar 01 J.Young: dyn alloc - Use HGRD_DEFN; replace INTERP3 with INTERPX; +C allocatable RDEPVHT, RJACM, RRHOJ +C 14 Nov 03 J.Young: add reciprocal vertical Jacobian product for full and +C mid-layer +C Tanya took JACOBF out of METCRO3D! Improvise +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----------------------------------------------------------------------- + + USE GRID_CONF ! horizontal & vertical domain specifications + Use UTILIO_DEFN +#ifdef parallel + USE SE_MODULES ! stenex (using SE_COMM_MODULE) +#else + USE NOOP_MODULES ! stenex (using NOOP_COMM_MODULE) +#endif + + Implicit None + + 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] + Real, Parameter :: KZMAXL = 500.0 ! upper limit for min Kz [m] + Real, Parameter :: KZ0UT = 1.0 ! minimum eddy diffusivity [m**2/sec] KZ0 + Real, Parameter :: KZL = 0.01 ! lowest KZ + Real, Parameter :: KZU = 1.0 ! 2.0 ! highest KZ + Real, Parameter :: EPS = 1.0E-08 ! small number for temperature difference + +C Local variables: + 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 + + Character( 16 ) :: PNAME = 'GET_MET' + Character( 16 ) :: VNAME + CharactER( 30 ) :: MSG1 = ' Error interpolating variable ' + Character( 96 ) :: XMSG = ' ' + +C----------------------------------------------------------------------- +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 + + 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 + + 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 + + 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 + + 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 + + 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 + + Met_Data%RRHOJ = 1.0 / Met_Data%RRHOJ + + VNAME = 'TA' + IF ( .NOT. INTERPX( MET_CRO_3D, VNAME, PNAME, + & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, + & JDATE, JTIME, Met_Data%TA ) ) THEN + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D + CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + VNAME = 'QV' + IF ( .NOT. INTERPX( MET_CRO_3D, VNAME, PNAME, + & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, + & JDATE, JTIME, Met_Data%QV ) ) THEN + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D + CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + VNAME = 'QC' + IF ( .NOT. INTERPX( MET_CRO_3D, VNAME, PNAME, + & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, + & JDATE, JTIME, Met_Data%QC ) ) THEN + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D + CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + +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 + + 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 + + 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 + write(*,*) 'Read clayfrac' + 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 + write(*,*) 'read sandfrac' + VNAME = 'SANDF' + If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, + & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2,1,1, + & JDATE, JTIME, Met_Data%SANDF ) ) Then + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + + VNAME = 'DRAG' + If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, + & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2,1,1, + & JDATE, JTIME, Met_Data%DRAG ) ) Then + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + + VNAME = 'UTHR' + If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, + & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2,1,1, + & JDATE, JTIME, Met_Data%UTHR ) ) Then + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + End If +C Soil vars + VNAME = 'SOIM1' + If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, + & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, + & JDATE, JTIME, Met_Data%SOIM1 ) ) Then + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + + If ( ABFLUX .Or. HGBIDI .Or. MOSAIC ) Then + VNAME = 'SOIM2' + If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, + & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, + & JDATE, JTIME, Met_Data%SOIM2 ) ) Then + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + + 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 + + VNAME = 'SOIT1' + If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, + & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, + & JDATE, JTIME, Met_Data%SOIT1 ) ) Then + XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + + 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 ) + End If + +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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + 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 + 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 + + 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 + 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 + 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 + + Where( Met_Data%RA .Gt. cond_min ) + Met_Data%RA = 1.0/Met_Data%RA + Elsewhere + 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 + + Where( Met_Data%RS .Gt. cond_min ) + Met_Data%RS = 1.0 / Met_Data%RS + Elsewhere + Met_Data%RS = resist_max + End Where + + 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 + + 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 + + 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 + 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 ) ) + Elsewhere + Es_Grnd = 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 ) + + Es_Air => BUFF2D + Where( Met_Data%TEMP2 .Lt. stdtemp ) + Es_Air = vp0 *Exp( 22.514 - ( 6.15e3 / Met_Data%TEMP2 ) ) + Elsewhere + Es_Air = 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 + End Where + Nullify( Es_Air ) + +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 + + 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 + +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 ) + CALL SUBST_COMM ( Met_Data%VWIND, DSPL_N1_E0_S0_W0, DRCN_N ) + +C-------------------------------- Calculated Variables -------------------------------- + Met_Data%DZF = Met_Data%ZF - EOSHIFT(Met_Data%ZF, Shift = -1, Boundary = 0.0, Dim = 3) + + Met_Data%RDEPVHT = 1.0 / Met_Data%ZF( :,:,1 ) + + IF ( MINKZ ) THEN + Met_Data%KZMIN = KZL + DO L = 1, NLAYS + Where( Met_Data%ZF( :,:,L ) .LE. KZMAXL ) + Met_Data%KZMIN( :,:,L ) = KZL + ( KZU - KZL ) * 0.01 * Grid_data%PURB + End Where + End Do + ELSE + 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 ) + +C------ Updating MOL, then WSTAR, MOLI, HOL + DO R = 1, MY_NROWS + DO C = 1, MY_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 ) ) + TMPVTCON = 1.0 + 0.608 * Met_Data%QV( C,R,1 ) ! Conversion factor for virtual temperature + TST = -TMPFX / Met_Data%USTAR( C,R ) + IF ( Met_Data%TA( C,R,1 ) .GT. STDTEMP ) THEN + LV = LV0 - ( 0.00237 * ( Met_Data%TA( C,R,1 ) - STDTEMP ) ) * 1.0E6 + ELSE + LV = 2.83E6 ! Latent heat of sublimation at 0C from Stull (1988) (J/KG) + END IF + QST = -( Met_Data%LH( C,R ) / LV ) + & / ( Met_Data%USTAR( C,R ) * Met_Data%DENS( C,R,1 ) ) + TSTV = TST * TMPVTCON + Met_Data%THETAV( C,R,1 ) * 0.608 * QST + IF ( ABS( TSTV ) .LT. 1.0E-6 ) THEN + TSTV = SIGN( 1.0E-6, TSTV ) + END IF + Met_Data%MOL( C,R ) = Met_Data%THETAV( C,R,1 ) + & * Met_Data%USTAR( C,R ) ** 2 / ( karman * GRAV * TSTV ) + IF ( Met_Data%MOL( C,R ) .LT. 0.0 ) THEN + Met_Data%WSTAR( C,R ) = Met_Data%USTAR( C,R ) * ( Met_Data%PBL( C,R ) + & / ( karman * ABS( Met_Data%MOL( C,R ) ) ) ) ** 0.333333 + ELSE + Met_Data%WSTAR( C,R ) = 0.0 + END IF + + END DO + END DO + + Met_Data%MOLI = 1.0 / Met_Data%MOL + Met_Data%HOL = Met_Data%PBL / Met_Data%MOL +C------ + + Met_Data%CONVCT = .FALSE. + DO R = 1, MY_NROWS + DO C = 1, MY_NCOLS + DO L = 1, NLAYS + IF ( Met_Data%PBL( C,R ) .LT. Met_Data%ZF( C,R,L ) ) THEN + LP = L; EXIT + END IF + END DO + + Met_Data%LPBL( C,R ) = LP + If ( LP .Eq. 1 ) Then + FINT = ( Met_Data%PBL( C,R ) ) + & / ( Met_Data%ZF( C,R,LP ) ) + Met_Data%XPBL( C,R ) = FINT * ( X3FACE_GD( LP ) - X3FACE_GD( LP-1 ) ) + & + X3FACE_GD( LP-1 ) + Else + FINT = ( Met_Data%PBL( C,R ) - Met_Data%ZF( C,R,LP-1 ) ) + & / ( Met_Data%ZF( C,R,LP ) - Met_Data%ZF( C,R,LP-1 ) ) + Met_Data%XPBL( C,R ) = FINT * ( X3FACE_GD( LP ) - X3FACE_GD( LP-1 ) ) + & + X3FACE_GD( LP-1 ) + End If + END DO + END DO + Where( Met_Data%THETAV( :,:,1 ) - Met_Data%THETAV( :,:,2 ) .Gt. EPS .And. + & Met_Data%HOL .Lt. -0.02 .And. Met_Data%LPBL .Gt. 3 ) + Met_Data%CONVCT = .True. + End Where + + Return + End Subroutine GET_MET + + End Module ASX_DATA_MOD diff --git a/src/model/src/DUST_EMIS.F b/src/model/src/DUST_EMIS.F new file mode 100644 index 0000000..3fb64c8 --- /dev/null +++ b/src/model/src/DUST_EMIS.F @@ -0,0 +1,1525 @@ + +!------------------------------------------------------------------------! +! The Community Multiscale Air Quality (CMAQ) system software is in ! +! continuous development by various groups and is based on information ! +! from these groups: Federal Government employees, contractors working ! +! within a United States Government contract, and non-Federal sources ! +! including research institutions. These groups give the Government ! +! permission to use, prepare derivative works of, and distribute copies ! +! of their work in the CMAQ system to the public and to permit others ! +! to do so. The United States Environmental Protection Agency ! +! therefore grants similar permission to use the CMAQ system software, ! +! but users are requested to provide copies of derivative works or ! +! products designed to operate in the CMAQ system to the United States ! +! Government without restrictions as to use by others. Software ! +! that is used with the CMAQ system but distributed under the GNU ! +! General Public License or the GNU Lesser General Public License is ! +! subject to their copyright restrictions. ! +!------------------------------------------------------------------------! + + +C 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 + +C----------------------------------------------------------------------- +C Description: +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 + +C Revision History: +C 16 Dec 10 J.Young: Adapting Daniel Tong`s work on windblown dust +C 21 Apr 11 S.Roselle: replaced I/O API include files with UTILIO_DEFN +C 11 May 11 D.Wong: incorporated twoway model implementation +C 8 Jul 11 J.Young: unified string lengths in character lists for compiler compatibility +C 11 Nov 11 J.Young: generalizing land use/cover +C 8 Jun 12 J.Young: remove full character blank padding for GNU Fortran (GCC) 4.1.2 +C 13 Jul 12 J.Young: following Daniel Tong: changed clayc, siltc, sandc units from mass +C fraction to %; adjusted F/G (vertical to horizontal flux) ratio +C to be continuous for clay content > 20% +C 30 Sep 13 J.Young: corrected diag file units description; added snow cover adjustment; +C adjusted F/G (vertical to horizontal flux) ratio to be continuous +C for clay content > 0.2; convert volumetric soil moisture to +C gravimetric water content; corrected soil moisture factor (fmoit); +C use lwmask>0 rather than sltyp>0 (non-existent) for over water test +C 15 Sep 15 H.Foroutan: revised threshold friction velocity parameterization +C 20 Oct 15 H.Foroutan: Updated the calculation of the threshold velocity(U*t), which is +C now based on dust particle size, following Shao and Lu [JGR,2000]. +C Implemented a dynamic vegetation fraction based on the MODIS FPAR. +C Introduced a new parametrization for surface roughness (z0) +C applicable to dust emission schemes, and accordingly calculated +C the friction velocity (U*) at the surface using 10m wind speed +C and the new (microspcopic) surface roughness. +C Surface roughness adjusted for estimated annual vegetation height. +C Included drag partitioning coefficient. Updated the calculation of +C the vertical-to-horizontal flux based on Lu and Shao [JGR,1999]. +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----------------------------------------------------------------------- + use lus_defn + use aero_data + + 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, + & dust_emis_init, get_dust_emis + private + + real, allocatable, save :: dust_em( :,: ) ! total dust emissions [g/m**3/s] + +C updated values of mass fraction for "freshly emitted dust" +C based on Kok [PNAS, 2011] and Nabat et al. [ACP, 2012] + real, parameter :: fracmj = 0.07 ! mass fraction assigned to accum mode + real, parameter :: fracmk = 0.93 ! mass fraction assigned to coarse mode + +C diam`s from fracmj,fracmk-weighted 2 2-bin averages of geom means +C 2 J-mode bins: 0.1-1.0, 1.0-2.5 um +C 2 K-mode bins: 2.5-5.0, 5.0-10.0 um + real, parameter :: dgvj = 1.3914 ! geom mean diam of accum mode [um] + real, parameter :: dgvk = 5.2590 ! geom mean diam of coarse mode [um] + real, parameter :: sigj = 2.0000 ! geom std deviation of accum mode flux + real, parameter :: sigk = 2.0000 ! geom std deviation of coarse mode flux + +C Local Variables: + +C Factors for converting 3rd moment emission rates into number and 2nd moment +C emission rates. (Diameters in [um] changed to [m] ) See Equations 7b and 7c +C of Binkowski & Roselle (2003) + real :: l2sgj ! [ln( sigj )] ** 2 + real :: l2sgk ! [ln( sigk )] ** 2 + real, save :: factnumj ! = exp( 4.5 * l2sgj ) / dgvj ** 3 * 1.0e18 + real, save :: factnumk ! = exp( 4.5 * l2sgk ) / dgvk ** 3 * 1.0e18 + real, save :: factm2j ! = exp( 0.5 * l2sgj ) / dgvj * 1.0e6 + real, save :: factm2k ! = exp( 0.5 * l2sgk ) / dgvk * 1.0e6 + 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 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, save :: ndust_diag ! number of diagnostic output vars + real, allocatable, save :: diagv( : ) ! diagnostic output variables + real, allocatable, save :: dustbf( :,:,: ) ! diagnostic accumulate buffer + +#ifdef verbose_wbdust + real, allocatable, save :: sdiagv( : ) ! global sum of each diag output var +#endif + + type diag_type + character( 16 ) :: var + character( 16 ) :: units + character( 80 ) :: desc + end type diag_type + + type( diag_type ), allocatable, save :: diagnm( : ) + type( diag_type ), allocatable, save :: vdiagnm_emis( : ) + type( diag_type ), allocatable, save :: vdiagnm_frac( : ) + type( diag_type ), allocatable, save :: vdiagnm_ustar( : ) + type( diag_type ), allocatable, save :: vdiagnm_kvh( : ) + type( diag_type ), allocatable, save :: vdiagnm_rough( : ) + + character( 10 ) :: truncnm + character( 16 ) :: vnm + + 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 ')/) + +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======================================================================= + function dust_emis_init( jdate, jtime, tstep ) result( success ) + +C Revision History. +C Aug 12, 15 D. Wong: Replaced MYPE with IO_PE_INCLUSIVE for parallel I/O +C implementation + + use hgrd_defn ! horizontal domain specifications + use aero_data ! aerosol species definitions + use asx_data_mod ! meteorology data + use utilio_defn + +C Arguments: + integer, intent( in ) :: jdate ! current model date, coded YYYYDDD + integer, intent( in ) :: jtime ! current model time, coded HHMMSS + integer, intent( in ) :: tstep ! output time step + logical 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 + + logical :: erode_agland = .true. ! default + integer status + integer c, r, i, j, k, l, n + integer idiag + integer n_mass_emissions + + integer gxoff, gyoff ! global origin offset from file + integer, save :: strtcol, endcol, strtrow, endrow + integer jdatemod + + 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 ) + if ( status .ne. 0 ) then + xmsg = '*** Failure allocating DUSTOUTM, DUSTOUTN, or DUSTOUTS' + call m3warn ( pname, jdate, jtime, xmsg ) + success = .false.; return + end if + +C Allocate emissions array + allocate( dust_em( ncols,nrows ), stat = status ) + if ( status .ne. 0 ) then + xmsg = '*** Failure allocating DUST_EM' + call m3warn( pname, jdate, jtime, xmsg ) + success = .false.; return + end if + +C Allocate private arrays + allocate( agland( ncols,nrows ), + & wmax ( ncols,nrows ), + & sd_ep ( ncols,nrows ), + & fpar ( ncols,nrows ), + & tfb ( ncols,nrows ), stat = status ) + if ( status .ne. 0 ) then + xmsg = '*** Failure allocating AGLAND, WMAX, FPAR, SD_EP, or TFB' + 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 + xmsg = 'Failure initializing land use module' + 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) + allocate( vdiagnm_emis ( n_dlcat ), + & vdiagnm_frac ( n_dlcat ), + & vdiagnm_kvh ( n_dlcat ), + & vdiagnm_rough( n_dlcat ), + & vdiagnm_ustar( n_dlcat ), stat = status ) + if ( status .ne. 0 ) then + xmsg = '*** Failure allocating VDIAGNM_*' + call m3warn( pname, jdate, jtime, xmsg ) + success = .false.; return + end if + vdiagnm_emis = diag_type( ' ', ' ', ' ' ) ! array assignment + vdiagnm_frac = diag_type( ' ', ' ', ' ' ) ! array assignment + vdiagnm_ustar = diag_type( ' ', ' ', ' ' ) ! array assignment + 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 + + ndust_diag = fndust_diag + 5 * n_dlcat + n_mass_emissions + + do i = 1, n_dlcat + truncnm = vnmld( i )%desc ! char( 10 ) +C... replace embedded spaces (within 16 chars) with "_" +C... replace embedded dashes (within 16 chars) with "_" + l = len_trim( truncnm ) + do k = 1, l + if ( truncnm( k:k ) .eq. " " .or. + & truncnm( k:k ) .eq. "-" ) truncnm( k:k ) = "_" + end do + vnm = trim( truncnm ) // '_Emis' ! char( 16 ) + vdiagnm_emis( i ) = diag_type( vnm, 'g/m**2/s', vnmld( i )%desc ) + vnm = trim( truncnm ) // '_Frac' ! char( 16 ) + vdiagnm_frac( i ) = diag_type( vnm, 'percent', vnmld( i )%desc ) + vnm = trim( truncnm ) // '_Ustr' ! char( 16 ) + vdiagnm_ustar( i ) = diag_type( vnm, 'm/s', vnmld( i )%desc ) + vnm = trim( truncnm ) // '_Kvh' ! char( 16 ) + vdiagnm_kvh( i ) = diag_type( vnm, '1/m', vnmld( i )%desc ) + vnm = trim( truncnm ) // '_Rough' ! char( 16 ) + vdiagnm_rough( i ) = diag_type( vnm, ' ', vnmld( i )%desc ) + end do + +C Allocate diagnostic emissions arrays + allocate( diagnm( ndust_diag ), ! diag_type + & diagv ( ndust_diag ), + & dustbf( ndust_diag,ncols,nrows ), stat = status ) + if ( status .ne. 0 ) then + xmsg = '*** Failure allocating DIAGNM, DIAGV or DUSTBF' + call m3warn( pname, jdate, jtime, xmsg ) + success = .false.; return + end if + +#ifdef verbose_wbdust + allocate( sdiagv( ndust_diag ), stat = status ) + if ( status .ne. 0 ) then + xmsg = '*** Failure allocating SDIAGV' + call m3warn( pname, jdate, jtime, xmsg ) + success = .false.; return + end if +#endif + +C Build the complete diagnostic name array n for MODIS NOAH + do i = 1, n_dlcat ! 4 + diagnm( i ) = vdiagnm_emis( i ) + end do + n = n_dlcat + 1 + diagnm( n ) = fdiagnm( 1 ) ! Cropland_Emis + n = n + 1 + diagnm( n ) = fdiagnm( 2 ) ! Desertland_Emis + + do i = 1, n_dlcat + diagnm( i+n ) = vdiagnm_frac( i ) + end do + n = n + n_dlcat + 1 + diagnm( n ) = fdiagnm( 3 ) ! Cropland_Frac + n = n + 1 + diagnm( n ) = fdiagnm( 4 ) ! Desertland_Frac + + do i = 1, n_dlcat + diagnm( i+n ) = vdiagnm_ustar( i ) + end do + n = n + n_dlcat + 1 + diagnm( n ) = fdiagnm( 5 ) ! Cropland_Ustar + + do i = 1, n_dlcat + diagnm( i+n ) = vdiagnm_kvh( i ) + end do + n = n + n_dlcat + 1 + diagnm( n ) = fdiagnm( 6 ) ! Cropland_Kvh + + do i = 1, n_dlcat + diagnm( i+n ) = vdiagnm_rough( i ) + end do + n = n + n_dlcat + 1 + diagnm( n ) = fdiagnm( 7 ) ! Cropland_Rough + + n = n - 7 ! add remaining variables in fdiagnm + do i = 8, fndust_diag + idiag = i+n + diagnm( idiag ) = fdiagnm( i ) + end do + +C...append diagnostic variables with mass emissions species + do j = 2, n_mode + 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 + 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 + 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 ) + & // ' emissions for ' + & // Trim( dust_spc( i )%description ) + end do + end do + +! remove unused space in diagnm by deallocated and reallocating to idiag value + allocate( diagnm_swap( ndust_diag ), stat = status ) + if ( status .ne. 0 ) then + xmsg = '*** Failure allocating DIAGNM_SWAP' + call m3warn( pname, jdate, jtime, xmsg ) + success = .false.; return + end if + diagnm_swap = diagnm + + deallocate( diagnm ) + + ndust_diag = idiag + allocate( diagnm( ndust_diag ), stat = status ) + if ( status .ne. 0 ) then + xmsg = '*** Failure reallocating DIAGNM' + call m3warn( pname, jdate, jtime, xmsg ) + success = .false.; return + end if + 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 ) + + 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 + +C Get transport factor within canopy and 4 land use type percents + call tfbelow ( jdate, jtime, tfb ) + + l2sgj = log( sigj ) * log( sigj ) + l2sgk = log( sigk ) * log( sigk ) + +C Factors for converting 3rd moment emission rates into number and 2nd moment +C emission rates. (Diameters in [um] changed to [m] ) See Equations 7b and 7c +C of Binkowski & Roselle (2003) + factnumj = 1.0e18 * exp( 4.5 * l2sgj ) / dgvj ** 3 + factnumk = 1.0e18 * exp( 4.5 * l2sgk ) / dgvk ** 3 + factm2j = 1.0e06 * exp( 0.5 * l2sgj ) / dgvj + factm2k = 1.0e06 * exp( 0.5 * l2sgk ) / dgvk + 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 + + end function dust_emis_init + +C======================================================================= + subroutine opdust_emis ( jdate, jtime, tstep, ndust_var, dust_var ) + +C 27 Dec 10 J.Young: initial + + use grid_conf ! horizontal & vertical domain specifications + use utilio_defn + + implicit none + + include SUBST_FILES_ID ! file name parameters + +C Arguments: + integer, intent( in ) :: jdate ! current model date, coded YYYYDDD + integer, intent( in ) :: jtime ! current model time, coded HHMMSS + integer, intent( in ) :: tstep ! output time step + integer, intent( in ) :: ndust_var + type( diag_type ), intent( in ) :: dust_var( : ) + +C Local variables: + character( 16 ) :: pname = 'OPDUST_EMIS' + character( 96 ) :: xmsg = ' ' + + integer v, l ! loop induction variables + +C----------------------------------------------------------------------- + +C Try to open existing file for update + if ( .not. open3( ctm_dust_emis_1, fsrdwr3, pname ) ) then + xmsg = 'Could not open CTM_DUST_EMIS_1 for update - ' + & // 'try to open new' + call m3mesg( xmsg ) + +C Set output file characteristics based on COORD.EXT and open diagnostic file + ftype3d = grdded3 + sdate3d = jdate + stime3d = jtime + tstep3d = tstep + call nextime( sdate3d, stime3d, tstep3d ) ! start the next hour + + nvars3d = ndust_var + ncols3d = gl_ncols + nrows3d = gl_nrows + nlays3d = 1 + nthik3d = 1 + gdtyp3d = gdtyp_gd + p_alp3d = p_alp_gd + p_bet3d = p_bet_gd + p_gam3d = p_gam_gd + xorig3d = xorig_gd + yorig3d = yorig_gd + xcent3d = xcent_gd + ycent3d = ycent_gd + xcell3d = xcell_gd + ycell3d = ycell_gd + vgtyp3d = vgtyp_gd + vgtop3d = vgtop_gd +! vgtpun3d = vgtpun_gd ! currently, not defined + do l = 1, nlays3d + 1 + vglvs3d( l ) = vglvs_gd( l ) + end do + gdnam3d = grid_name ! from HGRD_DEFN + + do v = 1, nvars3d + vtype3d( v ) = m3real + vname3d( v ) = dust_var( v )%var + units3d( v ) = dust_var( v )%units + vdesc3d( v ) = dust_var( v )%desc + end do + + fdesc3d( 1 ) = 'windblown dust parameters, variables, and' + fdesc3d( 2 ) = 'hourly layer-1 windblown dust emission rates' + do l = 3, mxdesc3 + fdesc3d( l ) = ' ' + end do + +C Open windblown dust emissions diagnostic file + if ( .not. open3( ctm_dust_emis_1, fsnew3, pname ) ) then + xmsg = 'Could not create the CTM_DUST_EMIS_1 file' + call m3exit( pname, sdate3d, stime3d, xmsg, xstat1 ) + end if + + end if + + return + + end subroutine opdust_emis + +C======================================================================= + subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt ) + + use grid_conf ! horizontal & vertical domain specifications + use asx_data_mod ! meteorology data + use aero_data + use utilio_defn + +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 + real, intent( in ) :: rjacm( ncols,nrows ) ! reciprocal Jacobian [1/m] + real, intent( in ) :: cellhgt ! grid-cell height [sigma] + +C Includes: + include SUBST_FILES_ID ! file name parameters + +C External Functions: + +C Parameters: + integer, parameter :: ndp = 4 ! number of soil texture type particle sizes: + ! 1 Coarse sand + ! 2 Fine-medium sand + ! 3 Silt + ! 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 + real, parameter :: betav = 202.0 + real, parameter :: sigv_mv = sigv * mv ! = 0.232 + real, parameter :: betav_mv = betav * mv ! = 32.32 + real, parameter :: mb = 0.5 + real, parameter :: sigb = 1.0 + real, parameter :: betab = 90.0 + real, parameter :: sigb_mb = sigb * mb ! = 0.5 + real, parameter :: betab_mb = betab * mb ! = 45.0 + + real, parameter :: alpha = 0.7 + + character( 16 ) :: pname = 'GET_DUST_EMIS' + character( 16 ) :: vname + character( 96 ) :: xmsg + integer status + integer c, r, j, m, n, v + + integer, save :: wstep = 0 ! local write counter + integer :: mdate, mtime ! diagnostic file write date&time + + ! 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 + real :: lai ( ncols,nrows ) ! leaf area index + + real, allocatable, save :: ustr ( :,:,: ) ! U* [m/s] + real, allocatable, save :: qam ( :,:,: ) ! emis for landuse type [g/m**2/s] + 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 :: 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] + real :: m3k ! 3rd moment coarse mode (K) emis rates [m3/m3/s] + real :: fruf2 ! surface roughness factor squared + + character( 16 ), save :: rc_name, rn_name ! new names: RC -> RCA, RN -> RNA + logical, save :: firstime = .true. + + real :: lambda, vegheight + real :: z0 + real :: lambdav ! vegetation roughness density - Shao et. al [Aus. J. Soil Res., 1996] + real :: flxfac1, flxfac2 ! combined soli type mapping factors + real :: hflux, vflux ! horizontal and vertical dust flux + real :: jday + integer :: emap( n_dlcat+1 ) + +C---FENGSHA FLAG + +C CHARACTER( 20 ), SAVE :: CTM_FENGHSA = 'CTM_FENGSHA ' ! env var for in-line +C LOGICAL, SAVE :: FENGSHA ! flag in-lining canopy shading + +C---Height for veg elements + real :: hv( 4 ) + +C---Roughness density for solid elements +C from Darmenova et al. [JGR,2009] and Xi and Sokolik [JGR,2015] + real :: lambdab( 4 ) = + & (/ 0.03, ! shrubland + & 0.04, ! shrubgrass + & 0.0001, ! barrenland + & 0.15 /) ! cropland + +C---Compound for computational efficiency + real :: hb_lambdab( 4 ) = + & (/ 6.0e-04, ! shrubland + & 8.0e-04, ! shrubgrass + & 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) +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 converted to gravimetric [kg/kg] + real :: soilml1( nsltyp ) = + & (/ 0.242, ! Sand + & 0.257, ! Loamy Sand + & 0.286, ! Sandy Loam + & 0.350, ! Silt Loam + & 0.350, ! Silt + & 0.307, ! Loam + & 0.277, ! Sandy Clay Loam + & 0.350, ! Silty Clay Loam + & 0.332, ! Clay Loam + & 0.284, ! Sandy Clay + & 0.357, ! Silty Clay + & 0.344, ! Clay + & 0.363 /) ! Other + +C---Soil texture: the amount of +C 1: Coarse sand, 2: Fine-medium sand, 3: Silt, 4: Clay +C in each soil type [Kg/Kg]. from Menut et al. [JGR,2013] + real :: soiltxt( nsltyp,ndp ) = reshape ( + & (/ 0.46, 0.46, 0.05, 0.03, ! Sand + & 0.41, 0.41, 0.18, 0.00, ! Loamy Sand + & 0.29, 0.29, 0.32, 0.10, ! Sandy Loam + & 0.00, 0.17, 0.70, 0.13, ! Silt Loam + & 0.00, 0.10, 0.85, 0.05, ! Silt + & 0.00, 0.43, 0.39, 0.18, ! Loam + & 0.29, 0.29, 0.15, 0.27, ! Sandy Clay Loam + & 0.00, 0.10, 0.56, 0.34, ! Silty Clay Loam + & 0.00, 0.32, 0.34, 0.34, ! Clay Loam + & 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 /), ! 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 ) = + & (/ 690.0E-6, ! Coarse sand + & 210.0E-6, ! Fine-medium sand + & 125.0E-6, ! Silt + & 2.0E-6 /) ! Clay + + + interface + subroutine tfabove ( tfa ) + real, intent( out ) :: tfa( :,: ) + end subroutine tfabove + end interface + +#ifdef verbose_wbdust + integer dryhit + integer dusthit +#endif + +C----------------------------------------------------------------------- + + if ( firstime ) then + +! FENGHSA = ENVYN( 'CTM_FENGSHA', +! & 'Flag for fengsha dust emission module', +! & .FALSE., IOSX ) + IF ( FENGSHA ) THEN + XMSG = 'Using Fengsha dust emission module ' + CALL M3MSG2( XMSG ) + END IF + + firstime = .false. + 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 + +C---Calculate transport factor above the canopy + call tfabove ( tfa ) + +C---Get Julian day number in year + jday = float( mod( jdate,1000 ) ) + +C---Vegetation height dynamically changed based on the month of the year +C Veg. heights in [m] for 1: Shrubland 2: shrubgrass 3: barrenland 4: Cropland +C following the idea of Xi and Sokolik [JGR,2015] + if ( jday .gt. 59 .and. jday .le. 90 ) then ! Mar + hv = (/ 0.15 , 0.05 , 0.10 , 0.05 /) + else if ( jday .gt. 90 .and. jday .le. 120 ) then ! Apr + hv = (/ 0.15 , 0.10 , 0.10 , 0.05 /) + else if ( jday .gt. 120 .and. jday .le. 151 ) then ! May + hv = (/ 0.12 , 0.20 , 0.10 , 0.10 /) + else if ( jday .gt. 151 .and. jday .le. 181 ) then ! Jun + hv = (/ 0.12 , 0.15 , 0.10 , 0.30 /) + else if ( jday .gt. 181 .and. jday .le. 212 ) then ! Jul + hv = (/ 0.10 , 0.12 , 0.10 , 0.50 /) + else if ( jday .gt. 212 .and. jday .le. 243 ) then ! Aug + hv = (/ 0.10 , 0.12 , 0.10 , 0.50 /) + else if ( jday .gt. 243 .and. jday .le. 273 ) then ! Sep + hv = (/ 0.10 , 0.10 , 0.10 , 0.30 /) + else if ( jday .gt. 273 .and. jday .le. 304 ) then ! Oct + hv = (/ 0.05 , 0.08 , 0.10 , 0.10 /) + else ! Nov-Feb + hv = (/ 0.05 , 0.05 , 0.05 , 0.05 /) + end if + +#ifdef verbose_wbdust + dryhit = 0 + dusthit = 0 +#endif + +C Initialize windblown dust diagnostics output buffer + if ( dustem_diag .and. wstep .eq. 0 ) then + dustbf = 0.0 ! array assignment +#ifdef verbose_wbdust + sdiagv = 0.0 ! array assignment +#endif + end if + +C set erodible landuse map + do m = 1, n_dlcat + emap( m ) = dmap( m ) ! dmap maps to one of the 3 BELD3 desert types + end do + emap( n_dlcat+1 ) = 4 + +C --------- ###### Start Main Loop ###### --------- + + do r = 1, my_nrows + do c = 1, my_ncols + dust_em( c,r ) = 0.0 + soimt( c,r ) = 0.0 + fmoit( c,r ) = 0.0 ! for diagnostic output visualization + vegfrac( c,r ) = 0.0 + do m = 1, n_dlcat+1 + ustr( c,r,m ) = 0.0 ! for diagnostic output visualization + qam ( c,r,m ) = 0.0 + elus( c,r,m ) = 0.0 + fruf( c,r,m ) = 0.0 + kvh ( c,r,m ) = 0.0 + end do + + 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 ) + vegfree = 1.0 - vegfrac( c,r ) + lambdav = -0.35 * log( vegfree ) ! Shao et al. [Aus. J. Soil Res.,1996] + +C---Dust possiblity only if 1. not over water +C 2. rain < 1/100 in. (1 in. = 2.540 cm) +C 3. not snow-covered +C 4. if soimt <= limit +C 5. desert type or ag landuse +C 6. erodible landuse +C 7. friction velocity > threshold + +!----------------------------------------------------------- +!---------------------- FENGSHA Option --------------------- +!----------------------------------------------------------- + + if ( ( FENGSHA.eq. .true.) .and. ( Grid_Data%lwmask( c,r ) .gt. 0.0 ) .and. + & ( Met_Data%rn( c,r ) + Met_Data%rc( c,r ) .le. 0.0254 ) .and. ! rn, rc = [cm] + & ( Met_Data%snocov( c,r ) .lt. 0.001 ) .and. + & ( Met_Data%drag(c,r) .gt. 0.0 ) ) then ! less than 0.1% snow coverage + +C Calculate maximum amount of the water absorbed +C w` = 0.0014(%clay)**2 + 0.17(%clay) - w` in % +C Fecan et al. [1999,Annales Geophys.,17,144-157] + wmax ( c,r ) = (100.*Met_Data%clayf( c,r )) * + & (100.*Met_Data%clayf( c,r )) * + & .0014d0 + 0.17d0 * (100.*Met_Data%clayf( c,r )) + + soimt( c,r ) = dust_volumetric_to_gravimetric( Met_Data%soim1( c,r ), Met_Data%clayf( c,r ), Met_Data%sandf( c,r )) + +C---Soil moisture effect on U*t + if ( soimt( c,r ) .le. 0.01 * wmax( c,r ) ) then ! wmax in [%] + fmoit( c,r ) = 1.0 + else + fmoit( c,r ) = sqrt( 1.0 + 1.2 * ( 100.0 * soimt( c,r ) - wmax( c,r ) ) ** 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 + kvh( c,r,1 ) = 10. ** (0.134 * (Met_Data%clayf( c,r )*100.) - 6.0) + else + kvh(c,r,1) = 4.0e-4 + endif +C Horizontal Flux + hflux = dust_hflux_fengsha( Met_Data%USTAR( c,r ), + & fmoit( c,r), + & Met_Data%drag( c,r ), + & Met_Data%uthr( c,r ), + & 1.0, ! ssm = 1 + & Met_Data%dens1( c,r ) ) + vflux = hflux * kvh( c,r,1 ) ! [g/m**2/s] + + qam (c,r,1) = qam(c,r,1) + vflux * rlay1hgt * alpha + + dust_em( c,r ) = dust_em( c,r ) + qam(c,r,1) * tfa(c,r) * tfb(c,r) + + +!-------------------------------------------------------------------- +!--------------------- END OF FENGSHA ------------------------------- +!-------------------------------------------------------------------- + + else if ( ( Grid_Data%lwmask( c,r ) .gt. 0.0 ) .and. + & ( Met_Data%rn( c,r ) + Met_Data%rc( c,r ) .le. 0.0254 ) .and. ! rn, rc = [cm] + & ( 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 ) ! [%] + +! 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 ) ) ) ) + + if ( soimt( c,r ) .le. soilml1( j ) ) then +C---Dust possiblity 4 + +#ifdef verbose_wbdust + dryhit = dryhit + 1 +#endif + +C---Soil moisture effect on U*t + if ( soimt( c,r ) .le. 0.01 * wmax( c,r ) ) then ! wmax in [%] + fmoit( c,r ) = 1.0 + else + fmoit( c,r ) = sqrt( 1.0 + 1.21 + & * ( 100.0 * soimt( c,r ) - wmax( c,r ) ) ** 0.68 ) + 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 ) + +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] + select case ( j ) + case( 1, 2 ) ! sand + ! pp = 5000.0 + ! calpha = 0.001 + ! pfrac = 0.06 + ! flxfac1 = calpha * 9.81 * pfrac * 500.0 / pp + flxfac1 = 5.886e-05 + ! flxfac2 = 2.09 * sqrt( 2650.0 / pp ) + flxfac2 = 1.5215430 + case( 3, 4, 6, 8, 9 ) ! loam + ! pp = 10000.0 + ! calpha = 0.0006 + ! pfrac = 0.18 + ! flxfac1 = calpha * 9.81 * pfrac * 500.0 / pp + flxfac1 = 5.2974e-05 + ! flxfac2 = 2.09 * sqrt( 2650.0 / pp ) + flxfac2 = 1.0758933 + case( 7 ) ! sandy clay loam + ! pp = 10000.0 + ! calpha = 0.0006 + ! pfrac = 0.32 + ! flxfac1 = calpha * 9.81 * pfrac * 500.0 / pp + flxfac1 = 9.4176e-05 + ! flxfac2 = 2.09 * sqrt( 2650.0 / pp ) + flxfac2 = 1.0758933 + case( 5, 10, 11, 12 ) ! clay + ! pp = 30000.0 + ! calpha = 0.0002 + ! pfrac = 0.72 + ! flxfac1 = calpha * 9.81 * pfrac * 500.0 / pp + flxfac1 = 2.3544e-05 + ! flxfac2 = 2.09 * sqrt( 2650.0 / pp ) + flxfac2 = 0.1964303 + case default ! others -- no dust + ! pp = 100000.0 + ! calpha = 1.0 + ! pfrac = 0.0 + ! flxfac1 = calpha * 9.81 * pfrac * 500.0 / pp + flxfac1 = 0.0 + ! flxfac2 = 2.09 * sqrt( 2650.0 / pp ) + flxfac2 = 0.3402273 + end select + + 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 ---- + + do m = 1, n_dlcat+1 ! desert type & crop landuse categories + + if ( elus( c,r,m ) .gt. 100.0 .or. elus( c,r,m ) .lt. 0.0 ) then + write( xmsg,2009 ) elus( c,r,m ), c, r, m + call m3exit( pname, jdate, jtime, xmsg, xstat1 ) + end if + + if ( elus( c,r,m ) .gt. 0.0 ) then + + n = emap( m ) + lambda = lambdab( n ) + lambdav + vegheight = ( hb_lambdab( n ) + hv( n ) * lambdav ) / lambda + +C---New parametrization for surface roughness by H. Foroutan - Oct. 2015 + if ( lambda .le. 0.2 ) then + z0 = 0.96 * ( lambda ** 1.07 ) * vegheight + else + z0 = 0.083 * ( lambda ** ( -0.46 ) ) * vegheight + end if + +C---Calculate friction velocity (U*) at the surafce applicable to dust emission + ustr( c,r,m ) = karman * Met_Data%WSPD10( c,r ) / log ( 10.0 / z0 ) + +C---Roughness effect on U*t (Drag partitioning) +C Xi and Sokolik [JGR,2015] + fruf2 = ( 1.0 - sigv_mv * lambdav ) + & * ( 1.0 + betav_mv * lambdav ) + & * ( 1.0 - sigb_mb * lambdab( n ) / vegfree ) + & * ( 1.0 + betab_mb * lambdab( n ) / vegfree ) + + if( fruf2 .gt. 1.0 ) then + + fruf( c,r,m ) = sqrt( fruf2 ) + else + fruf( c,r,m ) = 10.0 + end if + +C---Vert-to-Horiz dust flux ratio : Kang et al. [JGR, 2011] : Eq. (12) +! 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 ) ) + hflux = dust_hflux( ndp, dp, + & soiltxt( j,: ), + & fmoit( c,r ), + & fruf( c,r,m ), + & ustr( c,r,m ), + & sd_ep( c,r ), + & Met_Data%dens1( c,r ) ) + vflux = hflux * kvh( c,r,m ) ! [g/m**2/s] + qam( c,r,m ) = qam( c,r,m ) + vflux * rlay1hgt + & * ( elus( c,r,m ) * 0.01 ) ! [g/m**3/s] + end if ! if erodible land + + if ( elus( c,r,m ) .eq. 0.0 .and. qam( c,r,m ) .ne. 0.0 ) then + xmsg = 'Erodible land use = 0, but emissions .ne. 0' + call m3exit( pname, jdate, jtime, xmsg, xstat1 ) + end if + + dust_em( c,r ) = dust_em( c,r ) + qam( c,r,m ) + + end do ! m landuse + +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 + + end do ! c + end do ! r + +C --------- ###### End Main Loop ##### --------- + +#ifdef verbose_wbdust + write( logdev,'( /5x, a, 1x, 2i8 )' ) 'dry hit count, + & out of total cells:', + & dryhit, (c-1)*(r-1) +#endif + + do r = 1, my_nrows + do c = 1, my_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 + + do n = 2, n_mode + do v = 1, ndust_spc + dustoutm( v,n,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 ) ) + +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 + +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 + +#ifdef verbose_wbdust + if ( m3j .ne. 0.0 ) dusthit = dusthit + 1 +#endif + + if ( dustem_diag ) then + do m = 1, n_dlcat+1 + diagv( m ) = qam( c,r,m ) ! g/m**3/s + end do + n = n_dlcat + 2 + diagv( n ) = dust_em( c,r ) ! g/m**3/s + + sumdfr = 0.0 + do m = 1, n_dlcat+1 + diagv( m+n ) = elus( c,r,m ) + sumdfr = sumdfr + elus( c,r,m ) + end do + n = n + n_dlcat + 2 + diagv( n ) = sumdfr + + do m = 1, n_dlcat+1 + diagv( m+n ) = ustr( c,r,m ) + end do + n = n + n_dlcat + 1 + + do m = 1, n_dlcat+1 + diagv( m+n ) = kvh( c,r,m ) + end do + n = n + n_dlcat + 1 + + do m = 1, n_dlcat+1 + diagv( m+n ) = fruf( c,r,m ) + end do + n = n + n_dlcat + 1 + + diagv( n+1 ) = fmoit( c,r ) ! 'Soil_Moist_Fac ' + diagv( n+2 ) = sd_ep( c,r ) ! 'Soil_Erode_Pot ' + diagv( n+3 ) = wmax ( c,r ) ! 'Mx_Adsrb_H2O_Frc' + 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 + +! accum and coarse mode number density emissions + diagv( n+1 ) = dustoutn( 2,c,r ) + diagv( n+2 ) = dustoutn( 3,c,r ) +! accum and coarse mode surface area density emissions + diagv( n+3 ) = dustouts( 2,c,r ) + diagv( n+4 ) = dustouts( 3,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 + m = m + 1 + diagv( m+n ) = dustoutm( v,2,c,r ) + end if + end do + + do v = 1, ndust_spc + if ( trim( dust_spc( v )%name( 3 ) ) .ne. ' ' ) then ! coarse mode mass emissions + m = m + 1 + diagv( m+n ) = dustoutm( v,3,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 + dustbf( v,c,r ) = dustbf( v,c,r ) + diagv( v ) + & * float( time2sec( tstep( 2 ) ) ) +#ifdef verbose_wbdust + sdiagv( v ) = sdiagv( v ) + diagv( v ) + & * float( time2sec( tstep( 2 ) ) ) +#endif + end do + end if ! dustem_diag + end do ! col + end do ! row + +#ifdef verbose_wbdust + write( logdev,'( 5x, a, 2i8 / )' ) 'dust hit count, out of total cells:', + & dusthit, (c-1)*(r-1) +#endif + + if ( dustem_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. + + wstep = wstep + time2sec( tstep( 2 ) ) + + if ( wstep .ge. time2sec( tstep( 1 ) ) ) then + if ( .not. currstep( jdate, jtime, sdate, stime, tstep( 1 ), + & mdate, mtime ) ) then + xmsg = 'Cannot get step date and time' + call m3exit( pname, jdate, jtime, xmsg, xstat3 ) + end if + call nextime( mdate, mtime, tstep( 1 ) ) + +#ifdef verbose_wbdust + sdiagv = sdiagv / float( wstep ) ! array assignment + write( logdev,2015 ) jdate, jtime + do v = 1, ndust_diag + if ( diagnm( v )%var(1:4) .ne. 'ANUM' ) then + write( logdev,2019 ) v, diagnm( v )%var, sdiagv( v ) + else + write( logdev,2023 ) v, diagnm( v )%var, sdiagv( v ) + end if + end do + sdiagv = 0.0 ! array assignment +#endif + do v = 1, ndust_diag + do r = 1, my_nrows + do c = 1, my_ncols + wrbuf( c,r ) = dustbf( v,c,r ) / float( wstep ) + end do + end do + + if ( .not. WRITE3( ctm_dust_emis_1, diagnm( v )%var, + & mdate, mtime, wrbuf ) ) then + xmsg = 'Could not write ' // trim( diagnm( v )%var ) + & // ' to CTM_DUST_EMIS_1' + call m3exit( pname, mdate, mtime, xmsg, xstat1 ) + end if + end do + write( logdev,'( /5x, 2( a, 1x ), i8, ":", i6.6 )' ) + & 'Timestep written to CTM_DUST_EMIS_1', + & 'for date and time', mdate, mtime + wstep = 0 + dustbf = 0.0 ! array assignment + end if ! time to write + end if ! dustem_diag + +2009 Format( '*** Erodible landuse incorrect ', 1pe13.5, 1x, 'at: ', 3i4 ) +2015 format( /5x, 'Total grid time-avg sum of dust emis variables at:', + & 1x, i8, ":", I6.6 ) +2019 format( i10, 1x, a, f20.5 ) +2023 format( i10, 1x, a, e20.3 ) + + end subroutine get_dust_emis + +C======================================================================= + 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 fmoit( c,r ), +C fruf( c,r,m ), +C ustr( c,r,m ), +C sd_ep( c,r ), +C dens( c,r ) ) + + implicit none + + include SUBST_CONST ! for grav + + integer, intent( in ) :: ndp + real, intent( in ) :: dp( ndp ) + real, intent( in ) :: soiltxt( ndp ) + real, intent( in ) :: fmoit, fruf, ustr, sd_ep, dens + real hflux + + real, parameter :: amen = 1.0 ! Marticorena and Bergametti [JGR,1997] + real, parameter :: cfac = 1000.0 * amen / grav + real, parameter :: A = 260.60061 ! 0.0123 * 2650.0 * 9.81 / 1.227 + real, parameter :: B = 1.6540342e-06 ! 0.0123 * 0.000165 / 1.227 + real utstar ! threshold U* [m/s] + real utem ! U term [(m/s)**3] + real fac + integer n + +! I can't initialize dp this way - it has to be passed in since ndp is variable + +C---Mean mass median diameter (m) for each soil texture +C [Chatenet et al., Sedimentology 1996 and Menut et al., JGR 2013] +! real :: dp( ndp ) = +! & (/ 690.0E-6, ! Coarse sand +! & 210.0E-6, ! Fine-medium sand +! & 125.0E-6, ! Silt +! & 2.0E-6 /) ! Clay + + fac = cfac * dens * sd_ep + utem = 0.0 + utstar = 0.0 + hflux = 0.0 + do n = 1, ndp ! loop over dust particle size +! utstar = sqrt( 0.0123 * ( 2650.0 * 9.81 * dp( n ) / 1.227 + 0.000165 +! / 1.227 / dp( n ) ) ) ! X roughness & moisture effects + utstar = sqrt( A * dp( n ) + B / dp( n ) ) * fmoit * fruf !Shao and Lu [JGR,2000] + if ( ustr .gt. utstar ) then ! wind erosion occurs only if U* > U*t +C---Horiz. Flux from White (1979) + utem = ( ustr + utstar ) * ( ustr * ustr - utstar * utstar ) +C---Horiz. Flux from Owen (1964) +! utem = ustr * ( ustr * ustr - utstar * utstar ) + hflux = hflux + & + fac * utem * soiltxt( n ) ! [g/m/s] + end if + end do ! dust particle size + + end function dust_hflux + +C============================================================================== + function dust_volumetric_to_gravimetric(vsoilm,clay,sand) + & result ( gwc ) +C usage: H = dust_volumetric_to_gravimetric(vsoilm(c,r), +C clay(c,r), +C sand(c,r)) + + implicit none + ! INPUTS + real, intent(in) :: vsoilm ! volumetric soil moisture + real, intent(in) :: clay ! clay fraction (0 -> 1) + real, intent(in) :: sand ! sand fraction (0 -> 1) + ! OUTPUTS + real :: H + ! LOCAL + real :: gwc ! gravimetric soil moisture + real :: bulk_dens_dry ! bulk density + real :: limit ! fecan soil moisture limit + real :: wsat ! saturated volumentric water content + real :: mpot ! saturated soil matric potential + + ! parameters + real*8, parameter :: bulk_dens = 2650.0d0 + real*8, parameter :: h20_dens = 1000.0d0 + + ! saturated soil matric potential [ mm H2O ] + mpot = 10.d0 * (10.0d0 ** (1.88d0 - 0.0131d0 * sand )) + + ! saturated volumentric water content [ m3 m-3 ] + wsat = 0.489d0 - 0.00126d0 * sand + + ! Bulk density of dry surface soil [kg m-3] + bulk_dens_dry = bulk_dens * ( 1.0d0 - wsat) + + ! Gravimetric water content [ kg kg-1] + gwc = VSOILM * h20_dens / bulk_dens_dry + if (gwc.ge.1.0e10) then + gwc = 0.d0 + endif + + end function dust_volumetric_to_gravimetric + +C======================================================================= + function dust_hflux_fengsha( ustar, fmoit, drag, uthr, ssm, dens ) + & result( hflux ) + +C hflux = dust_hflux( Met_Data%ustar( c,r), +C & fmoit( c,r ), +C & drag( c,r ), +C & uthr( c,r ), +C & ssm( c,r ), +C & Met_Data%dens1( c,r ) ) + + implicit none + + include SUBST_CONST ! for grav + + 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 + u_thresh = uthr * fmoit + u_sum = rustar * u_thresh + + + hflux = max(0., rustar - u_thresh) * u_sum * u_sum * fac * ssm + + end function dust_hflux_fengsha + + end module dust_emis + diff --git a/src/model/src/centralized_io_util_module.F b/src/model/src/centralized_io_util_module.F new file mode 100644 index 0000000..f5b0653 --- /dev/null +++ b/src/model/src/centralized_io_util_module.F @@ -0,0 +1,282 @@ + +!------------------------------------------------------------------------! +! 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 +!------------------------------------------------------------------------! + + module centralized_io_util_module + + implicit none + + interface quicksort + module procedure quicksort1d, + & quicksort2d + end interface + + contains + +! ------------------------------------------------------------------------- + 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 + +!-------------------------------------------------------------------------- + + 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 From 1abdda056abb38083f9425d4ed38a88b37af3aea Mon Sep 17 00:00:00 2001 From: bbakernoaa Date: Wed, 3 Aug 2022 14:09:57 +0000 Subject: [PATCH 36/90] updates --- src/shr/aqm_config_mod.F90 | 16 +++++++++++ src/shr/aqm_emis_mod.F90 | 7 +++++ src/shr/aqm_methods.F90 | 57 +++++++++++++++++++++++++++++++++++--- 3 files changed, 76 insertions(+), 4 deletions(-) diff --git a/src/shr/aqm_config_mod.F90 b/src/shr/aqm_config_mod.F90 index c9ddc1a..9f75340 100644 --- a/src/shr/aqm_config_mod.F90 +++ b/src/shr/aqm_config_mod.F90 @@ -35,6 +35,7 @@ module aqm_config_mod logical :: ctm_wb_dust = .false. logical :: init_conc = .false. logical :: run_aero = .false. + logical :: fengsha_yn = .false. logical :: verbose = .false. type(aqm_species_type), pointer :: species => null() end type aqm_config_type @@ -193,6 +194,14 @@ subroutine aqm_config_read(model, config, rc) rcToReturn=rc)) & return ! bail out + call ESMF_ConfigGetAttribute(cf, config % fengsha_yn, & + label="fengsha_yn:", default=.false., rc=localrc) + if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__, & + rcToReturn=rc)) & + return ! bail out + ! -- set other default values config % ctm_depvfile = .false. config % ctm_photodiag = .false. @@ -496,6 +505,13 @@ subroutine aqm_config_log(config, name, rc) call ESMF_LogWrite(trim(name) // ": config: read: ctm_wb_dust: false", & ESMF_LOGMSG_INFO, rc=localrc) end if + if (config % fengsha_yn) then + call ESMF_LogWrite(trim(name) // ": config: read: fengsha_yn: true", & + ESMF_LOGMSG_INFO, rc=localrc) + else + call ESMF_LogWrite(trim(name) // ": config: read: fengsha_yn: false", & + ESMF_LOGMSG_INFO, rc=localrc) + end if if (config % run_aero) then call ESMF_LogWrite(trim(name) // ": config: read: run_aerosol: true", & ESMF_LOGMSG_INFO, rc=localrc) diff --git a/src/shr/aqm_emis_mod.F90 b/src/shr/aqm_emis_mod.F90 index 5590ef1..a8dbcee 100644 --- a/src/shr/aqm_emis_mod.F90 +++ b/src/shr/aqm_emis_mod.F90 @@ -1160,6 +1160,13 @@ subroutine aqm_emis_read(etype, spcname, buffer, localDe, rc) if (present(rc)) rc = AQM_RC_FAILURE return ! bail out end if + + if (trim(em % type) == "fengsha") then + ! -- ensure fengsha 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 diff --git a/src/shr/aqm_methods.F90 b/src/shr/aqm_methods.F90 index f4c4a8f..f82fc4f 100644 --- a/src/shr/aqm_methods.F90 +++ b/src/shr/aqm_methods.F90 @@ -148,7 +148,7 @@ LOGICAL FUNCTION DESC3( FNAME ) ELSE IF ( TRIM( FNAME ) .EQ. TRIM( MET_CRO_2D ) ) THEN - NVARS3D = 31 + NVARS3D = 35 VNAME3D( 1:NVARS3D ) = & (/ 'PRSFC ', 'USTAR ', & 'WSTAR ', 'PBL ', & @@ -165,7 +165,9 @@ LOGICAL FUNCTION DESC3( FNAME ) 'SLTYP ', 'Q2 ', & 'SEAICE ', 'SOIM1 ', & 'SOIM2 ', 'SOIT1 ', & - 'SOIT2 ', 'LH ' /) + 'SOIT2 ', 'LH ', & + 'CLAYF ', 'SANDF ', & + 'DRAG ', 'UTHR ' /) UNITS3D( 1:NVARS3D ) = & (/ 'Pascal ', 'M/S ', & 'M/S ', 'M ', & @@ -182,7 +184,9 @@ LOGICAL FUNCTION DESC3( FNAME ) '- ', 'KG/KG ', & 'FRACTION ', 'M**3/M**3 ', & 'M**3/M**3 ', 'K ', & - 'K ', 'WATTS/M**2 ' /) + 'K ', 'WATTS/M**2 ', & + '- ', '- ', & + '- ', 'M/S ' /) ELSE IF ( TRIM( FNAME ) .EQ. TRIM( MET_CRO_3D ) ) THEN @@ -330,6 +334,10 @@ logical function envyn(name, description, defaultval, status) envyn = associated(em) case ('CTM_GRAV_SETL') envyn = .false. + case ('CTM_FENGSHA') + write(*,*) 'CTM_FENGSHA CONFIG SET' + envyn = config % fengsha_yn ! Default: False + envyn = .true. case ('INITIAL_RUN') envyn = .true. case default @@ -736,7 +744,48 @@ logical function interpx( fname, vname, pname, & buffer(k) = 0.01 * stateIn % zorl(c,r) end do end do - case default + case ("CLAYF") + ! p2d -> stateIn % clayf + if (config % fengsha_yn) then + write(*,*) 'FENGSHA CONFIG READ' + call aqm_emis_read("fengsha", vname, buffer, rc=localrc) + if (aqm_rc_test((localrc /= 0), & + msg="Failure to read fengsha for " // vname, & + file=__FILE__, line=__LINE__)) return + else + buffer(1:lbuf) = 0 + endif + case ("SANDF") + ! p2d -> stateIn % clayf + if (config % fengsha_yn) then + call aqm_emis_read("fengsha", vname, buffer, rc=localrc) + if (aqm_rc_test((localrc /= 0), & + msg="Failure to read fengsha for " // vname, & + file=__FILE__, line=__LINE__)) return + else + buffer(1:lbuf) = 0 + endif + case ("DRAG") + ! p2d -> stateIn % clayf + if (config % fengsha_yn) then + call aqm_emis_read("fengsha", vname, buffer, rc=localrc) + if (aqm_rc_test((localrc /= 0), & + msg="Failure to read fengsha for " // vname, & + file=__FILE__, line=__LINE__)) return + else + buffer(1:lbuf) = 0 + endif + case ("UTHR") + ! p2d -> stateIn % clayf + if (config % fengsha_yn) then + call aqm_emis_read("fengsha", vname, buffer, rc=localrc) + if (aqm_rc_test((localrc /= 0), & + msg="Failure to read fengsha for " // vname, & + file=__FILE__, line=__LINE__)) return + else + buffer(1:lbuf) = 0 + endif + case default ! return end select From 11c22626d5da6655be3b0f403e8dcae3511353c2 Mon Sep 17 00:00:00 2001 From: bbakernoaa Date: Wed, 3 Aug 2022 14:30:50 +0000 Subject: [PATCH 37/90] Revert "updates" This reverts commit 1abdda056abb38083f9425d4ed38a88b37af3aea. --- src/shr/aqm_config_mod.F90 | 16 ----------- src/shr/aqm_emis_mod.F90 | 7 ----- src/shr/aqm_methods.F90 | 57 +++----------------------------------- 3 files changed, 4 insertions(+), 76 deletions(-) diff --git a/src/shr/aqm_config_mod.F90 b/src/shr/aqm_config_mod.F90 index 9f75340..c9ddc1a 100644 --- a/src/shr/aqm_config_mod.F90 +++ b/src/shr/aqm_config_mod.F90 @@ -35,7 +35,6 @@ module aqm_config_mod logical :: ctm_wb_dust = .false. logical :: init_conc = .false. logical :: run_aero = .false. - logical :: fengsha_yn = .false. logical :: verbose = .false. type(aqm_species_type), pointer :: species => null() end type aqm_config_type @@ -194,14 +193,6 @@ subroutine aqm_config_read(model, config, rc) rcToReturn=rc)) & return ! bail out - call ESMF_ConfigGetAttribute(cf, config % fengsha_yn, & - label="fengsha_yn:", default=.false., rc=localrc) - if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, & - file=__FILE__, & - rcToReturn=rc)) & - return ! bail out - ! -- set other default values config % ctm_depvfile = .false. config % ctm_photodiag = .false. @@ -505,13 +496,6 @@ subroutine aqm_config_log(config, name, rc) call ESMF_LogWrite(trim(name) // ": config: read: ctm_wb_dust: false", & ESMF_LOGMSG_INFO, rc=localrc) end if - if (config % fengsha_yn) then - call ESMF_LogWrite(trim(name) // ": config: read: fengsha_yn: true", & - ESMF_LOGMSG_INFO, rc=localrc) - else - call ESMF_LogWrite(trim(name) // ": config: read: fengsha_yn: false", & - ESMF_LOGMSG_INFO, rc=localrc) - end if if (config % run_aero) then call ESMF_LogWrite(trim(name) // ": config: read: run_aerosol: true", & ESMF_LOGMSG_INFO, rc=localrc) diff --git a/src/shr/aqm_emis_mod.F90 b/src/shr/aqm_emis_mod.F90 index a8dbcee..5590ef1 100644 --- a/src/shr/aqm_emis_mod.F90 +++ b/src/shr/aqm_emis_mod.F90 @@ -1160,13 +1160,6 @@ subroutine aqm_emis_read(etype, spcname, buffer, localDe, rc) if (present(rc)) rc = AQM_RC_FAILURE return ! bail out end if - - if (trim(em % type) == "fengsha") then - ! -- ensure fengsha 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 diff --git a/src/shr/aqm_methods.F90 b/src/shr/aqm_methods.F90 index f82fc4f..f4c4a8f 100644 --- a/src/shr/aqm_methods.F90 +++ b/src/shr/aqm_methods.F90 @@ -148,7 +148,7 @@ LOGICAL FUNCTION DESC3( FNAME ) ELSE IF ( TRIM( FNAME ) .EQ. TRIM( MET_CRO_2D ) ) THEN - NVARS3D = 35 + NVARS3D = 31 VNAME3D( 1:NVARS3D ) = & (/ 'PRSFC ', 'USTAR ', & 'WSTAR ', 'PBL ', & @@ -165,9 +165,7 @@ LOGICAL FUNCTION DESC3( FNAME ) 'SLTYP ', 'Q2 ', & 'SEAICE ', 'SOIM1 ', & 'SOIM2 ', 'SOIT1 ', & - 'SOIT2 ', 'LH ', & - 'CLAYF ', 'SANDF ', & - 'DRAG ', 'UTHR ' /) + 'SOIT2 ', 'LH ' /) UNITS3D( 1:NVARS3D ) = & (/ 'Pascal ', 'M/S ', & 'M/S ', 'M ', & @@ -184,9 +182,7 @@ LOGICAL FUNCTION DESC3( FNAME ) '- ', 'KG/KG ', & 'FRACTION ', 'M**3/M**3 ', & 'M**3/M**3 ', 'K ', & - 'K ', 'WATTS/M**2 ', & - '- ', '- ', & - '- ', 'M/S ' /) + 'K ', 'WATTS/M**2 ' /) ELSE IF ( TRIM( FNAME ) .EQ. TRIM( MET_CRO_3D ) ) THEN @@ -334,10 +330,6 @@ logical function envyn(name, description, defaultval, status) envyn = associated(em) case ('CTM_GRAV_SETL') envyn = .false. - case ('CTM_FENGSHA') - write(*,*) 'CTM_FENGSHA CONFIG SET' - envyn = config % fengsha_yn ! Default: False - envyn = .true. case ('INITIAL_RUN') envyn = .true. case default @@ -744,48 +736,7 @@ logical function interpx( fname, vname, pname, & buffer(k) = 0.01 * stateIn % zorl(c,r) end do end do - case ("CLAYF") - ! p2d -> stateIn % clayf - if (config % fengsha_yn) then - write(*,*) 'FENGSHA CONFIG READ' - call aqm_emis_read("fengsha", vname, buffer, rc=localrc) - if (aqm_rc_test((localrc /= 0), & - msg="Failure to read fengsha for " // vname, & - file=__FILE__, line=__LINE__)) return - else - buffer(1:lbuf) = 0 - endif - case ("SANDF") - ! p2d -> stateIn % clayf - if (config % fengsha_yn) then - call aqm_emis_read("fengsha", vname, buffer, rc=localrc) - if (aqm_rc_test((localrc /= 0), & - msg="Failure to read fengsha for " // vname, & - file=__FILE__, line=__LINE__)) return - else - buffer(1:lbuf) = 0 - endif - case ("DRAG") - ! p2d -> stateIn % clayf - if (config % fengsha_yn) then - call aqm_emis_read("fengsha", vname, buffer, rc=localrc) - if (aqm_rc_test((localrc /= 0), & - msg="Failure to read fengsha for " // vname, & - file=__FILE__, line=__LINE__)) return - else - buffer(1:lbuf) = 0 - endif - case ("UTHR") - ! p2d -> stateIn % clayf - if (config % fengsha_yn) then - call aqm_emis_read("fengsha", vname, buffer, rc=localrc) - if (aqm_rc_test((localrc /= 0), & - msg="Failure to read fengsha for " // vname, & - file=__FILE__, line=__LINE__)) return - else - buffer(1:lbuf) = 0 - endif - case default + case default ! return end select From 9b8d2e07af34fe5c7edf50276da808d583c6c82b Mon Sep 17 00:00:00 2001 From: bbakernoaa Date: Wed, 3 Aug 2022 14:31:04 +0000 Subject: [PATCH 38/90] Revert "updates" This reverts commit 43588af77cf86ee9f24cc67437d625d0ebede984. --- aqm_files.cmake | 6 +- src/model/Makefile.am | 64 +- src/model/Makefile.in | 109 +- src/model/src/ASX_DATA_MOD.F | 1463 ------------------- src/model/src/ASX_DATA_MOD.F~ | 1459 ------------------- src/model/src/DUST_EMIS.F | 1525 -------------------- src/model/src/centralized_io_util_module.F | 282 ---- 7 files changed, 80 insertions(+), 4828 deletions(-) delete mode 100755 src/model/src/ASX_DATA_MOD.F delete mode 100755 src/model/src/ASX_DATA_MOD.F~ delete mode 100644 src/model/src/DUST_EMIS.F delete mode 100644 src/model/src/centralized_io_util_module.F diff --git a/aqm_files.cmake b/aqm_files.cmake index 22bd6af..c3f7420 100644 --- a/aqm_files.cmake +++ b/aqm_files.cmake @@ -130,6 +130,7 @@ list(APPEND aqm_CCTM_files ${EMIS}/BEIS_DEFN.F ${EMIS}/BIOG_EMIS.F ${EMIS}/cropcal.F + ${EMIS}/DUST_EMIS.F ${EMIS}/EMIS_DEFN.F ${EMIS}/LTNG_DEFN.F ${EMIS}/LUS_DEFN.F @@ -214,6 +215,7 @@ list(APPEND aqm_CCTM_files ${UTIL}/subhdomain.F ${UTIL}/UTILIO_DEFN.F ${VDIFF}/aero_sedv.F + ${VDIFF}/ASX_DATA_MOD.F ${VDIFF}/conv_cgrid.F ${VDIFF}/matrix1.F ${VDIFF}/opddep.F @@ -229,8 +231,4 @@ list(APPEND aqm_CCTM_files ${localCCTM}/vdiffacmx.F ${localCCTM}/PTMAP.F ${localCCTM}/PT3D_DEFN.F - ${localCCTM}/ASX_DATA_MOD.F - ${localCCTM}/centralized_io_util_module.F - ${localCCTM}/DUST_EMIS.F ) - diff --git a/src/model/Makefile.am b/src/model/Makefile.am index 909b66e..61c4887 100644 --- a/src/model/Makefile.am +++ b/src/model/Makefile.am @@ -79,6 +79,7 @@ libCCTM_a_SOURCES += \ $(EMIS)/BEIS_DEFN.F \ $(EMIS)/BIOG_EMIS.F \ $(EMIS)/cropcal.F \ + $(EMIS)/DUST_EMIS.F \ $(EMIS)/EMIS_DEFN.F \ $(EMIS)/LTNG_DEFN.F \ $(EMIS)/LUS_DEFN.F \ @@ -222,6 +223,7 @@ VDIFF = $(CCTM)/vdiff/acm2 libVDIFF = $(VDIFF)/$(libCCTM)- libCCTM_a_SOURCES += \ $(VDIFF)/aero_sedv.F \ + $(VDIFF)/ASX_DATA_MOD.F \ $(VDIFF)/conv_cgrid.F \ $(VDIFF)/matrix1.F \ $(VDIFF)/opddep.F \ @@ -240,11 +242,7 @@ libCCTM_a_SOURCES += \ $(localCCTM)/o3totcol.f \ $(localCCTM)/vdiffacmx.F \ $(localCCTM)/PTMAP.F \ - $(localCCTM)/PT3D_DEFN.F \ - $(localCCTM)/ASX_DATA_MOD.F \ - $(localCCTM)/centralized_io_util_module.F \ - $(localCCTM)/DUST_EMIS.F - + $(localCCTM)/PT3D_DEFN.F libCCTM_a_CPPFLAGS = -DSUBST_FILES_ID=\"FILES_CTM.EXT\" @@ -291,7 +289,7 @@ $(libAERO)AERO_DATA.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libAERO)aero_depv.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libAERO)AERO_DATA.$(OBJEXT) $(libAERO)AEROMET_DATA.$(OBJEXT) \ - $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ $(libDEPV)MOSAIC_MOD.$(OBJEXT) $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) @@ -303,8 +301,8 @@ $(libAERO)aero_driver.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) $(libAERO)SOA_DEFN.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libAERO)AERO_EMIS.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(libAERO)AERO_DATA.$(OBJEXT) $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) \ - $(libSPCS)CGRID_SPCS.$(OBJEXT) $(liblocalCCTM)DUST_EMIS.$(OBJEXT) \ + $(libAERO)AERO_DATA.$(OBJEXT) $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) \ + $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libEMIS)DUST_EMIS.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libAERO)PRECURSOR_DATA.$(OBJEXT) \ $(liblocalCCTM)PT3D_DEFN.$(OBJEXT) $(liblocalCCTM)PTMAP.$(OBJEXT) \ $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) $(libEMIS)SSEMIS.$(OBJEXT) \ @@ -320,7 +318,7 @@ $(libAERO)aero_subs.$(OBJEXT) : $(ICL)/const/CONST.EXT $(AERO)/isrpia.inc \ $(libAERO)AOD_DEFN.$(OBJEXT) $(libAERO)PRECURSOR_DATA.$(OBJEXT) \ $(libAERO)SOA_DEFN.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libAERO)AOD_DEFN.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(libAERO)AERO_DATA.$(OBJEXT) $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) \ + $(libAERO)AERO_DATA.$(OBJEXT) $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libAERO)getpar.$(OBJEXT) : \ @@ -349,11 +347,11 @@ $(libAERO)SOA_DEFN.$(OBJEXT) : \ # biog $(libBIOG)beis3.$(OBJEXT) : \ - $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BIOG_EMIS.$(OBJEXT) + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BIOG_EMIS.$(OBJEXT) $(libBIOG)czangle.$(OBJEXT) : $(ICL)/const/CONST.EXT \ - $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libBIOG)hrno.$(OBJEXT) : \ - $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BIOG_EMIS.$(OBJEXT) \ + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BIOG_EMIS.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ $(libSTENEX)noop_modules.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libBIOG)parsline.$(OBJEXT) : \ @@ -370,7 +368,7 @@ $(libCLOUD)hlconst.$(OBJEXT) : \ # depv $(libDEPV)ABFLUX_MOD.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ $(libDEPV)MOSAIC_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ @@ -380,7 +378,7 @@ $(libDEPV)cgrid_depv.$(OBJEXT) : \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)DEPV_DEFN.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libDEPV)DEPVVARS.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ $(libDEPV)MOSAIC_MOD.$(OBJEXT) $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) \ @@ -389,13 +387,13 @@ $(libDEPV)gas_depv_map.$(OBJEXT) : \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libDEPV)DEPVVARS.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)HGSIM.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libDEPV)LSM_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)MOSAIC_MOD.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libDEPV)LSM_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)opdepv_diag.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ @@ -407,7 +405,7 @@ $(libDEPV)opdepv_fst.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libDEPV)LSM_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)m3dry.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(libDEPV)ABFLUX_MOD.$(OBJEXT) $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) \ + $(libDEPV)ABFLUX_MOD.$(OBJEXT) $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) \ $(libDEPV)BIDI_MOD.$(OBJEXT) $(libDEPV)DEPVVARS.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libDEPV)HGSIM.$(OBJEXT) \ $(libDEPV)LSM_MOD.$(OBJEXT) $(libDEPV)MOSAIC_MOD.$(OBJEXT) \ @@ -422,9 +420,13 @@ $(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) $(libVDIFF)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) \ + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BEIS_DEFN.$(OBJEXT) \ $(libEMIS)BIOG_EMIS.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libDEPV)DEPV_DEFN.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libEMIS)LTNG_DEFN.$(OBJEXT) $(libEMIS)MGEMIS.$(OBJEXT) \ @@ -437,7 +439,7 @@ $(libEMIS)LTNG_DEFN.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libEMIS)LUS_DEFN.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libEMIS)MGEMIS.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(libAERO)AEROMET_DATA.$(OBJEXT) $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) \ + $(libAERO)AEROMET_DATA.$(OBJEXT) $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libGRID)PCGRID_DEFN.$(OBJEXT) \ $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) @@ -450,7 +452,7 @@ $(libEMIS)PTBILIN.$(OBJEXT) : \ $(libEMIS)UDTYPES.$(OBJEXT) $(libGRID)VGRD_DEFN.$(OBJEXT) $(libEMIS)SSEMIS.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libAERO)AERO_DATA.$(OBJEXT) $(libAERO)AEROMET_DATA.$(OBJEXT) \ - $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libSTENEX)noop_modules.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libEMIS)STK_EMIS.$(OBJEXT) : \ @@ -459,7 +461,7 @@ $(libEMIS)STK_PRMS.$(OBJEXT) : \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libEMIS)UDTYPES.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libEMIS)tfabove.$(OBJEXT) : \ - $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libEMIS)LUS_DEFN.$(OBJEXT) $(libEMIS)tfbelow.$(OBJEXT) : \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libEMIS)LUS_DEFN.$(OBJEXT) \ @@ -618,8 +620,12 @@ $(libUTIL)subhdomain.$(OBJEXT) : \ # vdiff $(libVDIFF)aero_sedv.$(OBJEXT) : \ $(libAERO)AERO_DATA.$(OBJEXT) $(libAERO)AEROMET_DATA.$(OBJEXT) \ - $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) +$(libVDIFF)ASX_DATA_MOD.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT $(ICL)/mpi/PE_COMM.EXT \ + $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ + $(libDEPV)LSM_MOD.$(OBJEXT) $(libSTENEX)noop_modules.$(OBJEXT) \ + $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libVDIFF)conv_cgrid.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) @@ -639,7 +645,7 @@ $(libVDIFF)rddepv.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libVDIFF)SEDIMENTATION.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) \ $(libVDIFF)VDIFF_DIAG.$(OBJEXT) $(libVDIFF)VDIFF_MAP.$(OBJEXT) $(libVDIFF)tri.$(OBJEXT) : \ @@ -651,7 +657,7 @@ $(libVDIFF)VDIFF_MAP.$(OBJEXT) : $(ICL)/emctrl/EMISPRM.EXT \ $(libAERO)AERO_EMIS.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libVDIFF)vdiffproc.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libDEPV)DEPV_DEFN.$(OBJEXT) \ $(libEMIS)EMIS_DEFN.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libDEPV)HGSIM.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ @@ -663,7 +669,7 @@ $(libVDIFF)vdiffproc.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(liblocalCCTM)o3totcol.$(OBJEXT) : \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(liblocalCCTM)vdiffacmx.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libDEPV)DEPV_DEFN.$(OBJEXT) $(libEMIS)EMIS_DEFN.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) \ $(libVDIFF)VDIFF_MAP.$(OBJEXT) @@ -673,11 +679,3 @@ $(liblocalCCTM)PT3D_DEFN.$(OBJEXT) : $(libAERO)AERO_DATA.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(liblocalCCTM)PTMAP.$(OBJEXT) $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) \ $(libEMIS)STK_EMIS.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) -$(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT $(ICL)/mpi/PE_COMM.EXT \ - $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ - $(libDEPV)LSM_MOD.$(OBJEXT) $(libSTENEX)noop_modules.$(OBJEXT) \ - $(libUTIL)UTILIO_DEFN.$(OBJEXT) -$(liblocalCCTM)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) diff --git a/src/model/Makefile.in b/src/model/Makefile.in index e6ef50a..0c12a88 100644 --- a/src/model/Makefile.in +++ b/src/model/Makefile.in @@ -143,6 +143,7 @@ am_libCCTM_a_OBJECTS = $(AERO)/libCCTM_a-AERO_DATA.$(OBJEXT) \ $(EMIS)/libCCTM_a-BEIS_DEFN.$(OBJEXT) \ $(EMIS)/libCCTM_a-BIOG_EMIS.$(OBJEXT) \ $(EMIS)/libCCTM_a-cropcal.$(OBJEXT) \ + $(EMIS)/libCCTM_a-DUST_EMIS.$(OBJEXT) \ $(EMIS)/libCCTM_a-EMIS_DEFN.$(OBJEXT) \ $(EMIS)/libCCTM_a-LTNG_DEFN.$(OBJEXT) \ $(EMIS)/libCCTM_a-LUS_DEFN.$(OBJEXT) \ @@ -221,6 +222,7 @@ am_libCCTM_a_OBJECTS = $(AERO)/libCCTM_a-AERO_DATA.$(OBJEXT) \ $(UTIL)/libCCTM_a-subhdomain.$(OBJEXT) \ $(UTIL)/libCCTM_a-UTILIO_DEFN.$(OBJEXT) \ $(VDIFF)/libCCTM_a-aero_sedv.$(OBJEXT) \ + $(VDIFF)/libCCTM_a-ASX_DATA_MOD.$(OBJEXT) \ $(VDIFF)/libCCTM_a-conv_cgrid.$(OBJEXT) \ $(VDIFF)/libCCTM_a-matrix1.$(OBJEXT) \ $(VDIFF)/libCCTM_a-opddep.$(OBJEXT) \ @@ -235,10 +237,7 @@ am_libCCTM_a_OBJECTS = $(AERO)/libCCTM_a-AERO_DATA.$(OBJEXT) \ $(localCCTM)/libCCTM_a-o3totcol.$(OBJEXT) \ $(localCCTM)/libCCTM_a-vdiffacmx.$(OBJEXT) \ $(localCCTM)/libCCTM_a-PTMAP.$(OBJEXT) \ - $(localCCTM)/libCCTM_a-PT3D_DEFN.$(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-PT3D_DEFN.$(OBJEXT) libCCTM_a_OBJECTS = $(am_libCCTM_a_OBJECTS) AM_V_P = $(am__v_P_@AM_V@) am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) @@ -469,7 +468,7 @@ libCCTM_a_SOURCES = $(AERO)/AERO_DATA.F $(AERO)/aero_depv.F \ $(DEPV)/MOSAIC_MOD.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)/LTNG_DEFN.F \ + $(EMIS)/DUST_EMIS.F $(EMIS)/EMIS_DEFN.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 \ @@ -505,15 +504,13 @@ libCCTM_a_SOURCES = $(AERO)/AERO_DATA.F $(AERO)/aero_depv.F \ $(STENEX)/noop_util_module.f $(UTIL)/bmatvec.F \ $(UTIL)/findex.f $(UTIL)/get_envlist.f $(UTIL)/setup_logdev.F \ $(UTIL)/subhdomain.F $(UTIL)/UTILIO_DEFN.F \ - $(VDIFF)/aero_sedv.F \ + $(VDIFF)/aero_sedv.F $(VDIFF)/ASX_DATA_MOD.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_DIAG.F \ $(VDIFF)/VDIFF_MAP.F $(VDIFF)/vdiffproc.F \ $(localCCTM)/o3totcol.f $(localCCTM)/vdiffacmx.F \ - $(localCCTM)/PTMAP.F $(localCCTM)/PT3D_DEFN.F \ - $(localCCTM)/ASX_DATA_MOD.F \ - $(localCCTM)/centralized_io_util_module.F $(localCCTM)/DUST_EMIS.F + $(localCCTM)/PTMAP.F $(localCCTM)/PT3D_DEFN.F # local version of CCTM source files localCCTM = $(builddir)/src @@ -760,6 +757,8 @@ $(EMIS)/libCCTM_a-BIOG_EMIS.$(OBJEXT): $(EMIS)/$(am__dirstamp) \ $(EMIS)/$(DEPDIR)/$(am__dirstamp) $(EMIS)/libCCTM_a-cropcal.$(OBJEXT): $(EMIS)/$(am__dirstamp) \ $(EMIS)/$(DEPDIR)/$(am__dirstamp) +$(EMIS)/libCCTM_a-DUST_EMIS.$(OBJEXT): $(EMIS)/$(am__dirstamp) \ + $(EMIS)/$(DEPDIR)/$(am__dirstamp) $(EMIS)/libCCTM_a-EMIS_DEFN.$(OBJEXT): $(EMIS)/$(am__dirstamp) \ $(EMIS)/$(DEPDIR)/$(am__dirstamp) $(EMIS)/libCCTM_a-LTNG_DEFN.$(OBJEXT): $(EMIS)/$(am__dirstamp) \ @@ -982,6 +981,8 @@ $(VDIFF)/$(DEPDIR)/$(am__dirstamp): @: > $(VDIFF)/$(DEPDIR)/$(am__dirstamp) $(VDIFF)/libCCTM_a-aero_sedv.$(OBJEXT): $(VDIFF)/$(am__dirstamp) \ $(VDIFF)/$(DEPDIR)/$(am__dirstamp) +$(VDIFF)/libCCTM_a-ASX_DATA_MOD.$(OBJEXT): $(VDIFF)/$(am__dirstamp) \ + $(VDIFF)/$(DEPDIR)/$(am__dirstamp) $(VDIFF)/libCCTM_a-conv_cgrid.$(OBJEXT): $(VDIFF)/$(am__dirstamp) \ $(VDIFF)/$(DEPDIR)/$(am__dirstamp) $(VDIFF)/libCCTM_a-matrix1.$(OBJEXT): $(VDIFF)/$(am__dirstamp) \ @@ -1021,12 +1022,6 @@ $(localCCTM)/libCCTM_a-PTMAP.$(OBJEXT): $(localCCTM)/$(am__dirstamp) \ $(localCCTM)/libCCTM_a-PT3D_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): $(localCCTM)/$(am__dirstamp) \ - $(localCCTM)/$(DEPDIR)/$(am__dirstamp) libCCTM.a: $(libCCTM_a_OBJECTS) $(libCCTM_a_DEPENDENCIES) $(EXTRA_libCCTM_a_DEPENDENCIES) $(AM_V_at)-rm -f libCCTM.a @@ -1278,13 +1273,11 @@ $(EMIS)/libCCTM_a-cropcal.o: $(EMIS)/cropcal.F $(EMIS)/libCCTM_a-cropcal.obj: $(EMIS)/cropcal.F $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(EMIS)/libCCTM_a-cropcal.obj `if test -f '$(EMIS)/cropcal.F'; then $(CYGPATH_W) '$(EMIS)/cropcal.F'; else $(CYGPATH_W) '$(srcdir)/$(EMIS)/cropcal.F'; fi` -$(localCCTM)/libCCTM_a-DUST_EMIS.o: $(localCCTM)/DUST_EMIS.F - $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(localCCTM)/libCCTM_a-DUST_EMIS.o `test -f '$(local -CCTM)/DUST_EMIS.F' || echo '$(srcdir)/'`$(localCCTM)/DUST_EMIS.F +$(EMIS)/libCCTM_a-DUST_EMIS.o: $(EMIS)/DUST_EMIS.F + $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(EMIS)/libCCTM_a-DUST_EMIS.o `test -f '$(EMIS)/DUST_EMIS.F' || echo '$(srcdir)/'`$(EMIS)/DUST_EMIS.F -$(localCCTM)/libCCTM_a-DUST_EMIS.obj: $(localCCTM)/DUST_EMIS.F - $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(localCCTM)/libCCTM_a-DUST_EMIS.obj `if test -f '$( -localCCTM)/DUST_EMIS.F'; then $(CYGPATH_W) '$(localCCTM)/DUST_EMIS.F'; else $(CYGPATH_W) '$(srcdir)/$(localCCTM)/DUST_EMIS.F'; fi` +$(EMIS)/libCCTM_a-DUST_EMIS.obj: $(EMIS)/DUST_EMIS.F + $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(EMIS)/libCCTM_a-DUST_EMIS.obj `if test -f '$(EMIS)/DUST_EMIS.F'; then $(CYGPATH_W) '$(EMIS)/DUST_EMIS.F'; else $(CYGPATH_W) '$(srcdir)/$(EMIS)/DUST_EMIS.F'; fi` $(EMIS)/libCCTM_a-EMIS_DEFN.o: $(EMIS)/EMIS_DEFN.F $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(EMIS)/libCCTM_a-EMIS_DEFN.o `test -f '$(EMIS)/EMIS_DEFN.F' || echo '$(srcdir)/'`$(EMIS)/EMIS_DEFN.F @@ -1622,20 +1615,11 @@ $(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-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 -+ -+$(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.ob -j `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` +$(VDIFF)/libCCTM_a-ASX_DATA_MOD.o: $(VDIFF)/ASX_DATA_MOD.F + $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(VDIFF)/libCCTM_a-ASX_DATA_MOD.o `test -f '$(VDIFF)/ASX_DATA_MOD.F' || echo '$(srcdir)/'`$(VDIFF)/ASX_DATA_MOD.F -$(liblocalCCTM)/libCCTM_a-ASX_DATA_MOD.o: $(liblocalCCTM)/ASX_DATA_MOD.F - $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(liblocalCCTM)/libCCTM_a-ASX_DATA_MOD.o `test -f '$(liblocalCCTM)/ASX_DATA_MOD.F' || echo '$(srcdir)/'`$(liblocalCCTM)/ASX_DATA_MOD.F - -$(liblocalCCTM)/libCCTM_a-ASX_DATA_MOD.obj: $(liblocalCCTM)/ASX_DATA_MOD.F - $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(liblocalCCTM)/libCCTM_a-ASX_DATA_MOD.obj `if test -f '$(liblocalCCTM)/ASX_DATA_MOD.F'; then $(CYGPATH_W) '$(liblocalCCTM)/ASX_DATA_MOD.F'; else $(CYGPATH_W) '$(srcdir)/$(liblocalCCTM)/ASX_DATA_MOD.F'; fi` +$(VDIFF)/libCCTM_a-ASX_DATA_MOD.obj: $(VDIFF)/ASX_DATA_MOD.F + $(AM_V_PPF77)$(F77) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libCCTM_a_CPPFLAGS) $(CPPFLAGS) $(libCCTM_a_FFLAGS) $(FFLAGS) -c -o $(VDIFF)/libCCTM_a-ASX_DATA_MOD.obj `if test -f '$(VDIFF)/ASX_DATA_MOD.F'; then $(CYGPATH_W) '$(VDIFF)/ASX_DATA_MOD.F'; else $(CYGPATH_W) '$(srcdir)/$(VDIFF)/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 @@ -2180,7 +2164,7 @@ $(libAERO)AERO_DATA.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libAERO)aero_depv.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libAERO)AERO_DATA.$(OBJEXT) $(libAERO)AEROMET_DATA.$(OBJEXT) \ - $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ $(libDEPV)MOSAIC_MOD.$(OBJEXT) $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) @@ -2192,8 +2176,8 @@ $(libAERO)aero_driver.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) $(libAERO)SOA_DEFN.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libAERO)AERO_EMIS.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(libAERO)AERO_DATA.$(OBJEXT) $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) \ - $(libSPCS)CGRID_SPCS.$(OBJEXT) $(liblocalCCTM)DUST_EMIS.$(OBJEXT) \ + $(libAERO)AERO_DATA.$(OBJEXT) $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) \ + $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libEMIS)DUST_EMIS.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libAERO)PRECURSOR_DATA.$(OBJEXT) \ $(liblocalCCTM)PT3D_DEFN.$(OBJEXT) $(liblocalCCTM)PTMAP.$(OBJEXT) \ $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) $(libEMIS)SSEMIS.$(OBJEXT) \ @@ -2209,7 +2193,7 @@ $(libAERO)aero_subs.$(OBJEXT) : $(ICL)/const/CONST.EXT $(AERO)/isrpia.inc \ $(libAERO)AOD_DEFN.$(OBJEXT) $(libAERO)PRECURSOR_DATA.$(OBJEXT) \ $(libAERO)SOA_DEFN.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libAERO)AOD_DEFN.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(libAERO)AERO_DATA.$(OBJEXT) $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) \ + $(libAERO)AERO_DATA.$(OBJEXT) $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libAERO)getpar.$(OBJEXT) : \ @@ -2238,11 +2222,11 @@ $(libAERO)SOA_DEFN.$(OBJEXT) : \ # biog $(libBIOG)beis3.$(OBJEXT) : \ - $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BIOG_EMIS.$(OBJEXT) + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BIOG_EMIS.$(OBJEXT) $(libBIOG)czangle.$(OBJEXT) : $(ICL)/const/CONST.EXT \ - $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libBIOG)hrno.$(OBJEXT) : \ - $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BIOG_EMIS.$(OBJEXT) \ + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BIOG_EMIS.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ $(libSTENEX)noop_modules.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libBIOG)parsline.$(OBJEXT) : \ @@ -2259,7 +2243,7 @@ $(libCLOUD)hlconst.$(OBJEXT) : \ # depv $(libDEPV)ABFLUX_MOD.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ $(libDEPV)MOSAIC_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ @@ -2269,7 +2253,7 @@ $(libDEPV)cgrid_depv.$(OBJEXT) : \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)DEPV_DEFN.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libDEPV)DEPVVARS.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ $(libDEPV)MOSAIC_MOD.$(OBJEXT) $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) \ @@ -2278,13 +2262,13 @@ $(libDEPV)gas_depv_map.$(OBJEXT) : \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libDEPV)DEPVVARS.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)HGSIM.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libDEPV)LSM_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)MOSAIC_MOD.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libDEPV)LSM_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)opdepv_diag.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ @@ -2296,7 +2280,7 @@ $(libDEPV)opdepv_fst.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libDEPV)LSM_MOD.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libDEPV)m3dry.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(libDEPV)ABFLUX_MOD.$(OBJEXT) $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) \ + $(libDEPV)ABFLUX_MOD.$(OBJEXT) $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) \ $(libDEPV)BIDI_MOD.$(OBJEXT) $(libDEPV)DEPVVARS.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libDEPV)HGSIM.$(OBJEXT) \ $(libDEPV)LSM_MOD.$(OBJEXT) $(libDEPV)MOSAIC_MOD.$(OBJEXT) \ @@ -2311,9 +2295,13 @@ $(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) $(libVDIFF)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) \ + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libEMIS)BEIS_DEFN.$(OBJEXT) \ $(libEMIS)BIOG_EMIS.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libDEPV)DEPV_DEFN.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libEMIS)LTNG_DEFN.$(OBJEXT) $(libEMIS)MGEMIS.$(OBJEXT) \ @@ -2326,7 +2314,7 @@ $(libEMIS)LTNG_DEFN.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libEMIS)LUS_DEFN.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libEMIS)MGEMIS.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(libAERO)AEROMET_DATA.$(OBJEXT) $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) \ + $(libAERO)AEROMET_DATA.$(OBJEXT) $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libGRID)PCGRID_DEFN.$(OBJEXT) \ $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) @@ -2339,7 +2327,7 @@ $(libEMIS)PTBILIN.$(OBJEXT) : \ $(libEMIS)UDTYPES.$(OBJEXT) $(libGRID)VGRD_DEFN.$(OBJEXT) $(libEMIS)SSEMIS.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libAERO)AERO_DATA.$(OBJEXT) $(libAERO)AEROMET_DATA.$(OBJEXT) \ - $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libSTENEX)noop_modules.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libEMIS)STK_EMIS.$(OBJEXT) : \ @@ -2348,7 +2336,7 @@ $(libEMIS)STK_PRMS.$(OBJEXT) : \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libEMIS)UDTYPES.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libEMIS)tfabove.$(OBJEXT) : \ - $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libEMIS)LUS_DEFN.$(OBJEXT) $(libEMIS)tfbelow.$(OBJEXT) : \ $(libGRID)HGRD_DEFN.$(OBJEXT) $(libEMIS)LUS_DEFN.$(OBJEXT) \ @@ -2507,8 +2495,12 @@ $(libUTIL)subhdomain.$(OBJEXT) : \ # vdiff $(libVDIFF)aero_sedv.$(OBJEXT) : \ $(libAERO)AERO_DATA.$(OBJEXT) $(libAERO)AEROMET_DATA.$(OBJEXT) \ - $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) +$(libVDIFF)ASX_DATA_MOD.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT $(ICL)/mpi/PE_COMM.EXT \ + $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ + $(libDEPV)LSM_MOD.$(OBJEXT) $(libSTENEX)noop_modules.$(OBJEXT) \ + $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libVDIFF)conv_cgrid.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) @@ -2528,7 +2520,7 @@ $(libVDIFF)rddepv.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libGRID)HGRD_DEFN.$(OBJEXT) \ $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libVDIFF)SEDIMENTATION.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT \ - $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) \ $(libVDIFF)VDIFF_DIAG.$(OBJEXT) $(libVDIFF)VDIFF_MAP.$(OBJEXT) $(libVDIFF)tri.$(OBJEXT) : \ @@ -2540,7 +2532,7 @@ $(libVDIFF)VDIFF_MAP.$(OBJEXT) : $(ICL)/emctrl/EMISPRM.EXT \ $(libAERO)AERO_EMIS.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(libVDIFF)vdiffproc.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libDEPV)DEPV_DEFN.$(OBJEXT) \ $(libEMIS)EMIS_DEFN.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ $(libDEPV)HGSIM.$(OBJEXT) $(libDEPV)LSM_MOD.$(OBJEXT) \ @@ -2552,7 +2544,7 @@ $(libVDIFF)vdiffproc.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ $(liblocalCCTM)o3totcol.$(OBJEXT) : \ $(libUTIL)UTILIO_DEFN.$(OBJEXT) $(liblocalCCTM)vdiffacmx.$(OBJEXT) : $(ICL)/filenames/FILES_CTM.EXT \ - $(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ + $(libVDIFF)ASX_DATA_MOD.$(OBJEXT) $(libDEPV)BIDI_MOD.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(libSPCS)CGRID_SPCS.$(OBJEXT) $(libDEPV)DEPV_DEFN.$(OBJEXT) $(libEMIS)EMIS_DEFN.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) \ $(libVDIFF)VDIFF_MAP.$(OBJEXT) @@ -2562,14 +2554,7 @@ $(liblocalCCTM)PT3D_DEFN.$(OBJEXT) : $(libAERO)AERO_DATA.$(OBJEXT) \ $(libGRID)GRID_CONF.$(OBJEXT) $(libSPCS)CGRID_SPCS.$(OBJEXT) \ $(liblocalCCTM)PTMAP.$(OBJEXT) $(libMECHS)RXNS_DATA_MODULE.$(OBJEXT) \ $(libEMIS)STK_EMIS.$(OBJEXT) $(libUTIL)UTILIO_DEFN.$(OBJEXT) -$(liblocalCCTM)ASX_DATA_MOD.$(OBJEXT) : $(ICL)/const/CONST.EXT $(ICL)/filenames/FILES_CTM.EXT $(ICL)/mpi/PE_COMM.EXT \ - $(libDEPV)DEPVVARS.$(OBJEXT) $(libGRID)GRID_CONF.$(OBJEXT) \ - $(libDEPV)LSM_MOD.$(OBJEXT) $(libSTENEX)noop_modules.$(OBJEXT) \ - $(libUTIL)UTILIO_DEFN.$(OBJEXT) -$(liblocalCCTM)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) + # Tell versions [3.59,3.63) of GNU make to not export all variables. # Otherwise a system limit (for SysV at least) may be exceeded. .NOEXPORT: diff --git a/src/model/src/ASX_DATA_MOD.F b/src/model/src/ASX_DATA_MOD.F deleted file mode 100755 index 160183f..0000000 --- a/src/model/src/ASX_DATA_MOD.F +++ /dev/null @@ -1,1463 +0,0 @@ -!------------------------------------------------------------------------! -! The Community Multiscale Air Quality (CMAQ) system software is in ! -! continuous development by various groups and is based on information ! -! from these groups: Federal Government employees, contractors working ! -! within a United States Government contract, and non-Federal sources ! -! including research institutions. These groups give the Government ! -! permission to use, prepare derivative works of, and distribute copies ! -! of their work in the CMAQ system to the public and to permit others ! -! to do so. The United States Environmental Protection Agency ! -! therefore grants similar permission to use the CMAQ system software, ! -! but users are requested to provide copies of derivative works or ! -! products designed to operate in the CMAQ system to the United States ! -! Government without restrictions as to use by others. Software ! -! that is used with the CMAQ system but distributed under the GNU ! -! General Public License or the GNU Lesser General Public License is ! -! subject to their copyright restrictions. ! -!------------------------------------------------------------------------! - -C::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - Module ASX_DATA_MOD - -C----------------------------------------------------------------------- -C Function: User-defined types - -C Revision History: -C 19 Aug 2014 J.Bash: initial implementation -C 17 July 2015 H.Foroutan: Updated the calculation of MOL, MOLI, HOL, and WSTAR -C 25 Aug 2015 H. Pye: Added IEPOX, HACET surrogates -C modified PROPNN and H2O2 -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 -C---------Notes -C * Updates based on literature review 7/96 JEP -C # Diff and H based on Wesely (1988) same as RADM -C + Estimated by JEP 2/97 -C @ Updated by JEP 9/01 -C ~ Added by YW 1/02. Dif0 based on Massman (1998). Henry's Law constant -C is defined here as: h=cg/ca, where cg is the concentration of a species -C in gas-phase, and ca is its aqueous-phase concentration. The smaller h, -C the larger solubility. Henry's Law constant in another definition (KH): -C KH = ca/pg [M/atm], KH = KH0 * exp(-DKH/R(1/T-1/T0)), where KH0 and -DKH -C values are from Rolf Sander (1999). h=1/(KH*R*T). -C ** Update by DBS based on estimates by JEP 1/03 -C ^^ From Bill Massman, personal communication 4/03 -C ## Diffusivity calculated by SPARC, reactivity = other aldehydes -C ++ Dif0 in Massman is diffusivity at temperature 0C and 1 atm (101.325kPa), so -C chemicals that were not in Massman's paper need to be adjusted. We assume -C JEP's original values were for 25C and 1 atm. -C % Added by G. Sarwar (10/04) -C $ Added by R. Bullock (02/05) HG diffusivity is from Massman (1999). -C HGIIGAS diffusivity calculated from the HG value and a mol. wt. scaling -C factor of MW**(-2/3) from EPA/600/3-87/015. ORD, Athens, GA. HGIIGAS -C mol.wt. used is that of HgCl2. Reactivity of HG is 1/20th of NO and NO2 -C values based on general atmospheric lifetimes of each species. Reactivity -C of HGIIGAS is based on HNO3 surrogate. -C @@ Mesophyll resistances for NO, NO2, and CO added by J. Pleim (07/07) based -C on values in Pleim, Venkatram, and Yamartino, 1984: ADOM/TADAP Model -C Development Program, Volume 4, The Dry Deposition Module. ERT, Inc., -C Concord, MA (peer reviewed). -C ~~ Reactivity for PAN changed from 4.0 to 16.0 by J. Pleim (07/07) based on -C comparisons with Turnipseed et al., JGR, 2006. -C %% Species ICL1 and ICL2 are removed, not used in CB05. G. Sarwar (07/07) -C <> Hazardous Air Pollutants that are believed to undergo significant dry -C deposition. Hydrazine and triethylamine reactivities are based on analogies -C to NH3. Maleic anhydride reactivity is assumed similar to aldehydes. -C Toluene diisocyanate and hexamethylene diisocyanate reactivities are -C assumed to be similar to SO2. Diffusivities are calculated with standard -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------------------------------------------------------------------------------- - - Use GRID_CONF ! horizontal & vertical domain specifications - Use LSM_MOD ! Land surface data - Use DEPVVARS, Only: ltotg - - Implicit None - - Include SUBST_CONST ! constants - - Type :: MET_Type -!> 2-D meteorological fields: - Real, Allocatable :: RDEPVHT ( :,: ) ! air dens / dep vel ht - 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 :: RC ( :,: ) ! convective precipitation [cm] - Real, Allocatable :: RN ( :,: ) ! non-convective precipitation [mc] - 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] - Real, Allocatable :: SNOCOV ( :,: ) ! Snow cover [1=yes, 0=no] - Real, Allocatable :: TEMP2 ( :,: ) ! two meter temperature [K] - Real, Allocatable :: TEMPG ( :,: ) ! skin temperature [K] - Real, Allocatable :: TSEASFC ( :,: ) ! SST [K] - Real, Allocatable :: USTAR ( :,: ) ! surface friction velocity [m/s] - Real, Allocatable :: VEG ( :,: ) ! fractional vegetation coverage [ratio] - Real, Allocatable :: LAI ( :,: ) ! grid cell leaf area index [m**2/m**2] - Real, Allocatable :: WR ( :,: ) ! precip intercepted by canopy [m] - Real, Allocatable :: WSPD10 ( :,: ) ! 10-m wind speed [m/s] - Real, Allocatable :: WSTAR ( :,: ) ! convective velocity scale [m/s] - Real, Allocatable :: Z0 ( :,: ) ! roughness length [m] - Real, Allocatable :: SOIM1 ( :,: ) ! 1 cm soil moisture [m**3/m**3] - Real, Allocatable :: SOIM2 ( :,: ) ! 1 m soil moisture [m**3/m**3] - Real, Allocatable :: SOIT1 ( :,: ) ! 1 cm soil temperature [K] - Real, Allocatable :: SOIT2 ( :,: ) ! 1 m soil temperature [K] - Real, Allocatable :: SEAICE ( :,: ) ! Sea ice coverage [%] - Real, Allocatable :: MOL ( :,: ) ! Monin-Obukhov length [m] - Real, Allocatable :: MOLI ( :,: ) ! inverse of Monin-Obukhov length [m] - Real, Allocatable :: HOL ( :,: ) ! PBL over Obukhov length - Real, Allocatable :: XPBL ( :,: ) ! PBL sigma height - 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) - -!> 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 - -!> 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 :: QV ( :,:,: ) ! water vapor mixing ratio - Real, Allocatable :: QC ( :,:,: ) ! cloud water mixing ratio - Real, Allocatable :: THETAV ( :,:,: ) ! potential temp - Real, Allocatable :: TA ( :,:,: ) ! temperature (K) - Real, Allocatable :: ZH ( :,:,: ) ! mid-layer height above ground [m] - Real, Allocatable :: ZF ( :,:,: ) ! layer height [m] - Real, Allocatable :: DZF ( :,:,: ) ! layer surface thickness - Real, Allocatable :: DENS ( :,:,: ) ! air density - Real, Allocatable :: RJACM ( :,:,: ) ! reciprocal mid-layer Jacobian - Real, Allocatable :: RJACF ( :,:,: ) ! reciprocal full-layer Jacobian - Real, Allocatable :: RRHOJ ( :,:,: ) ! reciprocal density X Jacobian - End Type MET_Type - - Type :: GRID_Type -!> Grid infomation: -!> Vertical information - Real, Allocatable :: DX3F ( : ) ! sigma layer surface thickness ! vdiffacmx.F - Real, Allocatable :: RDX3F ( : ) ! reciprocal sigma layer thickness ! EMIS_DEFN.F, sedi.F, vdiffacmx.F, vdiffproc.F - Real, Allocatable :: RDX3M ( : ) ! reciprocal sigma midlayer thickness ! vdiffproc.F -!> Horizontal Information: - Real, Allocatable :: RMSFX4 ( :,: ) ! inverse map scale factor ** 4 - 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 :: PURB ( :,: ) ! percent urban [%] - Integer, Allocatable :: SLTYP ( :,: ) ! soil type [category] - Real, Allocatable :: WSAT ( :,: ) ! soil wilting point - 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 :: RHOB ( :,: ) ! soil bulk density - 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 - - Integer, Save :: n_spc_m3dry = ltotg ! from DEPVVARS module -!> M3 asx constants - Real, Parameter :: a0 = 8.0 ! [dim'less] - Real, Parameter :: d3 = 1.38564e-2 ! [dim'less] - Real, Parameter :: dwat = 0.2178 ! [cm^2/s] at 273.15K - Real, Parameter :: hplus_ap = 1.0e-6 ! pH=6.0 leaf apoplast solution Ph (Massad et al 2008) - Real, Parameter :: hplus_def = 1.0e-5 ! pH=5.0 - Real, Parameter :: hplus_east = 1.0e-5 ! pH=5.0 - Real, Parameter :: hplus_h2o = 7.94328e-9 ! 10.0**(-8.1) - Real, Parameter :: hplus_west = 3.16228e-6 ! 10.0**(-5.5) - Real, Parameter :: kvis = 0.132 ! [cm^2 / s] at 273.15K - Real, Parameter :: pr = 0.709 ! [dim'less] - Real, Parameter :: rcut0 = 3000.0 ! [s/m] - Real, Parameter :: rcw0 = 125000.0 ! acc'd'g to Padro and - Real, Parameter :: resist_max = 1.0e30 ! maximum resistance - 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 :: 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 - Real, Parameter :: twothirds = 2.0 / 3.0 - Real, Parameter :: betah = 5.0 ! WRF 3.6 px uses Dyer - Real, Parameter :: gamah = 16.0 - Real, Parameter :: pr0 = 0.95 - Real, Parameter :: karman = 0.40 - Real, Parameter :: f3min = 0.25 - Real, Parameter :: ftmin = 0.0000001 ! m/s - Real, Parameter :: nscat = 16.0 - Real, Parameter :: rsmax = 5000.0 ! s/m - - Real :: ar ( ltotg ) ! reactivity relative to HNO3 - Real :: dif0 ( ltotg ) ! molecular diffusivity [cm2/s] - Real :: lebas ( ltotg ) ! Le Bas molar volume [cm3/mol ] - Real :: meso ( ltotg ) ! Exception for species that - ! react with cell walls. fo in - ! Wesely 1989 eq 6. - 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. - - Public :: INIT_MET - - Logical, Private, Save :: ifsst = .false. - Logical, Private, Save :: ifq2 = .false. - Logical, Private, Save :: rinv = .True. - Logical, Private, Save :: iflh = .false. - - Integer, Private :: C, R, L, S ! loop induction variables - Integer, Private :: SPC - Character( 16 ), Private, Save :: vname_rc, vname_rn, vname_uc, vname_vc - Real, Private, Save :: P0 ! reference pressure (100000.0 Pa) for Potential Temperature, note that in meteorology they do not use the SI 1 ATM. - - Integer, Private, Save :: LOGDEV - Integer, Private, Save :: GXOFF, GYOFF ! global origin offset from file - Integer, Private, Save :: STRTCOLMC3, ENDCOLMC3, STRTROWMC3, ENDROWMC3 ! MET_CRO_3D - Integer, Private, Save :: STRTCOLMD3, ENDCOLMD3, STRTROWMD3, ENDROWMD3 ! MET_DOT_3D - Integer, Private, Save :: STRTCOLMC2, ENDCOLMC2, STRTROWMC2, ENDROWMC2 ! MET_CRO_2D - Integer, Private, Save :: STRTCOL_O1, ENDCOL_O1, STRTROW_O1, ENDROW_O1 ! OCEAN_1 - - Real, Pointer, Private :: BUFF1D( : ) ! 1D temp var number of layers - Real, Pointer, Private :: BUFF2D( :,: ) ! 2D temp var - Real, Pointer, Private :: BUFF3D( :,:,: ) ! 3D temp var - -! FENGSHA option control - CHARACTER( 20 ), SAVE :: CTM_FENGSHA = 'CTM_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. - - CONTAINS - -C======================================================================= - Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) - -C----------------------------------------------------------------------- -C 30 Mar 01 J.Young: dyn alloc - Use HGRD_DEFN; replace INTERP3 with INTERPX; -C allocatable RDEPVHT, RJACM, RRHOJ -C 14 Nov 03 J.Young: add reciprocal vertical Jacobian product for full and -C mid-layer -C Tanya took JACOBF out of METCRO3D! Improvise -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----------------------------------------------------------------------- - - Use UTILIO_DEFN - - 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' - Character( 16 ) :: VNAME - CHARACTER( 16 ) :: UNITSCK - 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 - ALLOCATE ( BUFF1D( NLAYS ), - & BUFF2D( NCOLS,NROWS ), - & BUFF3D( NCOLS,NROWS,NLAYS ), STAT = ALLOCSTAT ) - If ( ALLOCSTAT .Ne. 0 ) Then - XMSG = 'Failure allocating Buffers' - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - BUFF1D = 0.0 - BUFF2D = 0.0 - BUFF3D = 0.0 - -!> Allocate shared arrays -!> Met_Data - ALLOCATE( Met_Data%RDEPVHT ( NCOLS,NROWS ), - & Met_Data%DENS1 ( NCOLS,NROWS ), - & Met_Data%PRSFC ( NCOLS,NROWS ), - & Met_Data%Q2 ( NCOLS,NROWS ), - & Met_Data%QSS_GRND ( NCOLS,NROWS ), - & Met_Data%RH ( NCOLS,NROWS ), - & Met_Data%RA ( NCOLS,NROWS ), - & Met_Data%RS ( NCOLS,NROWS ), - & Met_Data%RC ( NCOLS,NROWS ), - & Met_Data%RN ( NCOLS,NROWS ), - & Met_Data%RGRND ( NCOLS,NROWS ), - & Met_Data%HFX ( NCOLS,NROWS ), - & Met_Data%LH ( NCOLS,NROWS ), - & Met_Data%SNOCOV ( NCOLS,NROWS ), - & Met_Data%TEMP2 ( NCOLS,NROWS ), - & Met_Data%TEMPG ( NCOLS,NROWS ), - & Met_Data%TSEASFC ( NCOLS,NROWS ), - & Met_Data%USTAR ( NCOLS,NROWS ), - & Met_Data%VEG ( NCOLS,NROWS ), - & Met_Data%LAI ( NCOLS,NROWS ), - & Met_Data%WR ( NCOLS,NROWS ), - & Met_Data%WSPD10 ( NCOLS,NROWS ), - & Met_Data%WSTAR ( NCOLS,NROWS ), - & Met_Data%Z0 ( NCOLS,NROWS ), - & Met_Data%SOIM1 ( NCOLS,NROWS ), - & Met_Data%SOIT1 ( NCOLS,NROWS ), - & Met_Data%SEAICE ( NCOLS,NROWS ), - & Met_Data%MOL ( NCOLS,NROWS ), - & Met_Data%MOLI ( NCOLS,NROWS ), - & Met_Data%HOL ( NCOLS,NROWS ), - & Met_Data%XPBL ( NCOLS,NROWS ), - & Met_Data%LPBL ( NCOLS,NROWS ), - & Met_Data%CONVCT ( NCOLS,NROWS ), - & Met_Data%PBL ( NCOLS,NROWS ), - & Met_Data%NACL_EMIS( NCOLS,NROWS ), - & Met_Data%UWIND ( NCOLS+1,NROWS+1,NLAYS ), - & Met_Data%VWIND ( NCOLS+1,NROWS+1,NLAYS ), - & Met_Data%KZMIN ( NCOLS,NROWS,NLAYS ), - & Met_Data%PRES ( NCOLS,NROWS,NLAYS ), - & Met_Data%QV ( NCOLS,NROWS,NLAYS ), - & Met_Data%QC ( NCOLS,NROWS,NLAYS ), - & Met_Data%THETAV ( NCOLS,NROWS,NLAYS ), - & Met_Data%TA ( NCOLS,NROWS,NLAYS ), - & Met_Data%ZH ( NCOLS,NROWS,NLAYS ), - & Met_Data%ZF ( NCOLS,NROWS,NLAYS ), - & Met_Data%DZF ( NCOLS,NROWS,NLAYS ), - & Met_Data%DENS ( NCOLS,NROWS,NLAYS ), - & Met_Data%RJACM ( NCOLS,NROWS,NLAYS ), - & Met_Data%RJACF ( NCOLS,NROWS,NLAYS ), - & Met_Data%RRHOJ ( NCOLS,NROWS,NLAYS ), - & STAT = ALLOCSTAT ) - If ( ALLOCSTAT .Ne. 0 ) Then - XMSG = 'Failure allocating met vars' - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - ALLOCATE( Grid_Data%DX3F ( NLAYS ), - & Grid_Data%RDX3F ( NLAYS ), - & Grid_Data%RDX3M ( NLAYS ), - & Grid_Data%RMSFX4 ( NCOLS,NROWS ), - & Grid_Data%LON ( NCOLS,NROWS ), - & Grid_Data%LAT ( NCOLS,NROWS ), - & Grid_Data%LWMASK ( NCOLS,NROWS ), - & Grid_Data%OCEAN ( NCOLS,NROWS ), - & Grid_Data%SZONE ( NCOLS,NROWS ), - & Grid_Data%PURB ( NCOLS,NROWS ), - & Grid_Data%SLTYP ( NCOLS,NROWS ), - & Grid_Data%NAME ( n_lufrac ), - & Grid_Data%LU_Type ( n_lufrac ), - & STAT = ALLOCSTAT ) - If ( ALLOCSTAT .Ne. 0 ) Then - XMSG = 'Failure allocating grid vars' - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - Grid_Data%NAME = name_lu - Grid_Data%LU_Type = cat_lu - - If ( ABFLUX .Or. HGBIDI .Or. MOSAIC ) Then - ALLOCATE( Met_Data%SOIM2 ( NCOLS,NROWS ), - & Met_Data%SOIT2 ( NCOLS,NROWS ), - & STAT = ALLOCSTAT ) - If ( ALLOCSTAT .Ne. 0 ) Then - XMSG = 'Failure allocating mosaic met vars' - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - ALLOCATE( Grid_Data%WSAT ( NCOLS,NROWS ), - & Grid_Data%WWLT ( NCOLS,NROWS ), - & Grid_Data%BSLP ( NCOLS,NROWS ), - & Grid_Data%WRES ( NCOLS,NROWS ), - & Grid_Data%WFC ( NCOLS,NROWS ), - & Grid_Data%LUFRAC ( NCOLS,NROWS,n_lufrac ), - & STAT = ALLOCSTAT ) - If ( ALLOCSTAT .Ne. 0 ) Then - XMSG = 'Failure allocating mosaic 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 - - 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 ), - & STAT = ALLOCSTAT ) - If ( ALLOCSTAT .Ne. 0 ) Then - XMSG = 'Failure allocating chemistry dependent mosaic vars' - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - ChemMos_Data%Rb = resist_max - ChemMos_Data%Rst = resist_max - ChemMos_Data%Rcut = resist_max - ChemMos_Data%Rgc = resist_max - ChemMos_Data%Rgb = resist_max - ChemMos_Data%Rwat = resist_max - ChemMos_Data%CZ0 = 0.0 - ChemMos_Data%Cleaf = 0.0 - ChemMos_Data%Cstom = 0.0 - ChemMos_Data%Ccut = 0.0 - ChemMos_Data%Csoil = 0.0 - ChemMos_Data%NAME = name_lu - ChemMos_Data%LU_Type = cat_lu - ChemMos_Data%SubName = subname - End If - -!> ccccccccccccccccccccc Fengsha option!ccccccccccccccccccccc - FENGSHA = ENVYN( 'CTM_FENGSHA', - & 'Flag for in-line fengsha ', - & .FALSE., IOSX ) - - If ( FENGSHA ) Then - ALLOCATE( Met_Data%CLAYF ( NCOLS,NROWS ), - & Met_Data%SANDF ( NCOLS,NROWS ), - & Met_Data%DRAG ( NCOLS,NROWS ), - & Met_Data%UTHR ( NCOLS,NROWS ), - & STAT = ALLOCSTAT ) - If ( ALLOCSTAT .Ne. 0 ) Then - XMSG = 'Failure allocating Fengsha variables' - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - End If - -!> ccccccccccccccccccccc enable backward compatiblity ccccccccccccccccccccc - - If ( .Not. desc3( met_cro_2d ) ) Then - xmsg = 'Could not get ' // MET_CRO_2D // ' file description' - Call m3exit( pname, JDATE, JTIME, xmsg, xstat2 ) - End If - - SPC = INDEX1( 'RA', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) rinv = .FALSE. ! Ra and Rst are in units s/m - - SPC = INDEX1( 'WR', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) ifwr = .True. ! canopy wetness is in METCRO2D - - SPC = INDEX1( 'Q2', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) ifq2 = .True. ! two meter mixing ratio in METCRO2D - - SPC = INDEX1( 'TSEASFC', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) ifsst = .True. ! two meter SST in METCRO2D - - SPC = INDEX1( 'LH', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) iflh = .True. ! LH in METCRO2D - - SPC = INDEX1( 'RCA', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) Then - vname_rc = 'RCA' - Else - vname_rc = 'RC' - End If - - SPC = INDEX1( 'RNA', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) 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 - vname_uc = 'UWINDC' - CSTAGUV = .TRUE. - Else - vname_uc = 'UWIND' - CSTAGUV = .FALSE. - End If - - SPC = INDEX1( 'VWINDC', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) 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 ) ) - End Do - Do L = 1, NLAYS - 1 - Grid_Data%RDX3M( L ) = 1.0 / ( X3M( L+1 ) - X3M( 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 - - 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 - - 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 - - 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 - - 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%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 - - 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 ) ) - Grid_Data%WWLT( C,R ) = WWLT( Grid_Data%SLTYP( C,R ) ) - Grid_Data%WFC ( C,R ) = WFC ( Grid_Data%SLTYP( C,R ) ) - 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 - - MET_INITIALIZED = .true. - - Return - End Subroutine INIT_MET - -C======================================================================= - Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) - -C----------------------------------------------------------------------- -C 30 Mar 01 J.Young: dyn alloc - Use HGRD_DEFN; replace INTERP3 with INTERPX; -C allocatable RDEPVHT, RJACM, RRHOJ -C 14 Nov 03 J.Young: add reciprocal vertical Jacobian product for full and -C mid-layer -C Tanya took JACOBF out of METCRO3D! Improvise -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----------------------------------------------------------------------- - - USE GRID_CONF ! horizontal & vertical domain specifications - Use UTILIO_DEFN -#ifdef parallel - USE SE_MODULES ! stenex (using SE_COMM_MODULE) -#else - USE NOOP_MODULES ! stenex (using NOOP_COMM_MODULE) -#endif - - Implicit None - - 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] - Real, Parameter :: KZMAXL = 500.0 ! upper limit for min Kz [m] - Real, Parameter :: KZ0UT = 1.0 ! minimum eddy diffusivity [m**2/sec] KZ0 - Real, Parameter :: KZL = 0.01 ! lowest KZ - Real, Parameter :: KZU = 1.0 ! 2.0 ! highest KZ - Real, Parameter :: EPS = 1.0E-08 ! small number for temperature difference - -C Local variables: - 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 - - Character( 16 ) :: PNAME = 'GET_MET' - Character( 16 ) :: VNAME - CharactER( 30 ) :: MSG1 = ' Error interpolating variable ' - Character( 96 ) :: XMSG = ' ' - -C----------------------------------------------------------------------- -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 - - 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 - - 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 - - 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 - - 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 - - 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 - - Met_Data%RRHOJ = 1.0 / Met_Data%RRHOJ - - VNAME = 'TA' - IF ( .NOT. INTERPX( MET_CRO_3D, VNAME, PNAME, - & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, - & JDATE, JTIME, Met_Data%TA ) ) THEN - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D - CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - END IF - - VNAME = 'QV' - IF ( .NOT. INTERPX( MET_CRO_3D, VNAME, PNAME, - & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, - & JDATE, JTIME, Met_Data%QV ) ) THEN - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D - CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - END IF - - VNAME = 'QC' - IF ( .NOT. INTERPX( MET_CRO_3D, VNAME, PNAME, - & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, - & JDATE, JTIME, Met_Data%QC ) ) THEN - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D - CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - END IF - -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 - - 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 - - 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 - If ( FENGSHA ) Then - write(*,*) 'Read clayfrac' - VNAME = 'CLAYF' - write(*,*) VNAME, PNAME - write(*,*) JDATE, JTIME - write(*,*) STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2 - 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 - write(*,*) 'read sandfrac' - 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 - - write(*,*) 'read drag' - 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 - write(*,*) 'Read uthr' - VNAME = 'UTHR' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%UTHR ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - End If -C Soil vars - VNAME = 'SOIM1' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%SOIM1 ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - If ( ABFLUX .Or. HGBIDI .Or. MOSAIC ) Then - VNAME = 'SOIM2' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%SOIM2 ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - 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 - - VNAME = 'SOIT1' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%SOIT1 ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - 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 ) - End If - -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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - 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 - 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 - - 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 - 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 - 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 - - Where( Met_Data%RA .Gt. cond_min ) - Met_Data%RA = 1.0/Met_Data%RA - Elsewhere - 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 - - Where( Met_Data%RS .Gt. cond_min ) - Met_Data%RS = 1.0 / Met_Data%RS - Elsewhere - Met_Data%RS = resist_max - End Where - - 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 - - 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 - - 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 - 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 ) ) - Elsewhere - Es_Grnd = 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 ) - - Es_Air => BUFF2D - Where( Met_Data%TEMP2 .Lt. stdtemp ) - Es_Air = vp0 *Exp( 22.514 - ( 6.15e3 / Met_Data%TEMP2 ) ) - Elsewhere - Es_Air = 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 - End Where - Nullify( Es_Air ) - -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 - - 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 - -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 ) - CALL SUBST_COMM ( Met_Data%VWIND, DSPL_N1_E0_S0_W0, DRCN_N ) - -C-------------------------------- Calculated Variables -------------------------------- - Met_Data%DZF = Met_Data%ZF - EOSHIFT(Met_Data%ZF, Shift = -1, Boundary = 0.0, Dim = 3) - - Met_Data%RDEPVHT = 1.0 / Met_Data%ZF( :,:,1 ) - - IF ( MINKZ ) THEN - Met_Data%KZMIN = KZL - DO L = 1, NLAYS - Where( Met_Data%ZF( :,:,L ) .LE. KZMAXL ) - Met_Data%KZMIN( :,:,L ) = KZL + ( KZU - KZL ) * 0.01 * Grid_data%PURB - End Where - End Do - ELSE - 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 ) - -C------ Updating MOL, then WSTAR, MOLI, HOL - DO R = 1, MY_NROWS - DO C = 1, MY_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 ) ) - TMPVTCON = 1.0 + 0.608 * Met_Data%QV( C,R,1 ) ! Conversion factor for virtual temperature - TST = -TMPFX / Met_Data%USTAR( C,R ) - IF ( Met_Data%TA( C,R,1 ) .GT. STDTEMP ) THEN - LV = LV0 - ( 0.00237 * ( Met_Data%TA( C,R,1 ) - STDTEMP ) ) * 1.0E6 - ELSE - LV = 2.83E6 ! Latent heat of sublimation at 0C from Stull (1988) (J/KG) - END IF - QST = -( Met_Data%LH( C,R ) / LV ) - & / ( Met_Data%USTAR( C,R ) * Met_Data%DENS( C,R,1 ) ) - TSTV = TST * TMPVTCON + Met_Data%THETAV( C,R,1 ) * 0.608 * QST - IF ( ABS( TSTV ) .LT. 1.0E-6 ) THEN - TSTV = SIGN( 1.0E-6, TSTV ) - END IF - Met_Data%MOL( C,R ) = Met_Data%THETAV( C,R,1 ) - & * Met_Data%USTAR( C,R ) ** 2 / ( karman * GRAV * TSTV ) - IF ( Met_Data%MOL( C,R ) .LT. 0.0 ) THEN - Met_Data%WSTAR( C,R ) = Met_Data%USTAR( C,R ) * ( Met_Data%PBL( C,R ) - & / ( karman * ABS( Met_Data%MOL( C,R ) ) ) ) ** 0.333333 - ELSE - Met_Data%WSTAR( C,R ) = 0.0 - END IF - - END DO - END DO - - Met_Data%MOLI = 1.0 / Met_Data%MOL - Met_Data%HOL = Met_Data%PBL / Met_Data%MOL -C------ - - Met_Data%CONVCT = .FALSE. - DO R = 1, MY_NROWS - DO C = 1, MY_NCOLS - DO L = 1, NLAYS - IF ( Met_Data%PBL( C,R ) .LT. Met_Data%ZF( C,R,L ) ) THEN - LP = L; EXIT - END IF - END DO - - Met_Data%LPBL( C,R ) = LP - If ( LP .Eq. 1 ) Then - FINT = ( Met_Data%PBL( C,R ) ) - & / ( Met_Data%ZF( C,R,LP ) ) - Met_Data%XPBL( C,R ) = FINT * ( X3FACE_GD( LP ) - X3FACE_GD( LP-1 ) ) - & + X3FACE_GD( LP-1 ) - Else - FINT = ( Met_Data%PBL( C,R ) - Met_Data%ZF( C,R,LP-1 ) ) - & / ( Met_Data%ZF( C,R,LP ) - Met_Data%ZF( C,R,LP-1 ) ) - Met_Data%XPBL( C,R ) = FINT * ( X3FACE_GD( LP ) - X3FACE_GD( LP-1 ) ) - & + X3FACE_GD( LP-1 ) - End If - END DO - END DO - Where( Met_Data%THETAV( :,:,1 ) - Met_Data%THETAV( :,:,2 ) .Gt. EPS .And. - & Met_Data%HOL .Lt. -0.02 .And. Met_Data%LPBL .Gt. 3 ) - Met_Data%CONVCT = .True. - End Where - - Return - End Subroutine GET_MET - - End Module ASX_DATA_MOD diff --git a/src/model/src/ASX_DATA_MOD.F~ b/src/model/src/ASX_DATA_MOD.F~ deleted file mode 100755 index 0e7b79e..0000000 --- a/src/model/src/ASX_DATA_MOD.F~ +++ /dev/null @@ -1,1459 +0,0 @@ -!------------------------------------------------------------------------! -! The Community Multiscale Air Quality (CMAQ) system software is in ! -! continuous development by various groups and is based on information ! -! from these groups: Federal Government employees, contractors working ! -! within a United States Government contract, and non-Federal sources ! -! including research institutions. These groups give the Government ! -! permission to use, prepare derivative works of, and distribute copies ! -! of their work in the CMAQ system to the public and to permit others ! -! to do so. The United States Environmental Protection Agency ! -! therefore grants similar permission to use the CMAQ system software, ! -! but users are requested to provide copies of derivative works or ! -! products designed to operate in the CMAQ system to the United States ! -! Government without restrictions as to use by others. Software ! -! that is used with the CMAQ system but distributed under the GNU ! -! General Public License or the GNU Lesser General Public License is ! -! subject to their copyright restrictions. ! -!------------------------------------------------------------------------! - -C::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - Module ASX_DATA_MOD - -C----------------------------------------------------------------------- -C Function: User-defined types - -C Revision History: -C 19 Aug 2014 J.Bash: initial implementation -C 17 July 2015 H.Foroutan: Updated the calculation of MOL, MOLI, HOL, and WSTAR -C 25 Aug 2015 H. Pye: Added IEPOX, HACET surrogates -C modified PROPNN and H2O2 -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 -C---------Notes -C * Updates based on literature review 7/96 JEP -C # Diff and H based on Wesely (1988) same as RADM -C + Estimated by JEP 2/97 -C @ Updated by JEP 9/01 -C ~ Added by YW 1/02. Dif0 based on Massman (1998). Henry's Law constant -C is defined here as: h=cg/ca, where cg is the concentration of a species -C in gas-phase, and ca is its aqueous-phase concentration. The smaller h, -C the larger solubility. Henry's Law constant in another definition (KH): -C KH = ca/pg [M/atm], KH = KH0 * exp(-DKH/R(1/T-1/T0)), where KH0 and -DKH -C values are from Rolf Sander (1999). h=1/(KH*R*T). -C ** Update by DBS based on estimates by JEP 1/03 -C ^^ From Bill Massman, personal communication 4/03 -C ## Diffusivity calculated by SPARC, reactivity = other aldehydes -C ++ Dif0 in Massman is diffusivity at temperature 0C and 1 atm (101.325kPa), so -C chemicals that were not in Massman's paper need to be adjusted. We assume -C JEP's original values were for 25C and 1 atm. -C % Added by G. Sarwar (10/04) -C $ Added by R. Bullock (02/05) HG diffusivity is from Massman (1999). -C HGIIGAS diffusivity calculated from the HG value and a mol. wt. scaling -C factor of MW**(-2/3) from EPA/600/3-87/015. ORD, Athens, GA. HGIIGAS -C mol.wt. used is that of HgCl2. Reactivity of HG is 1/20th of NO and NO2 -C values based on general atmospheric lifetimes of each species. Reactivity -C of HGIIGAS is based on HNO3 surrogate. -C @@ Mesophyll resistances for NO, NO2, and CO added by J. Pleim (07/07) based -C on values in Pleim, Venkatram, and Yamartino, 1984: ADOM/TADAP Model -C Development Program, Volume 4, The Dry Deposition Module. ERT, Inc., -C Concord, MA (peer reviewed). -C ~~ Reactivity for PAN changed from 4.0 to 16.0 by J. Pleim (07/07) based on -C comparisons with Turnipseed et al., JGR, 2006. -C %% Species ICL1 and ICL2 are removed, not used in CB05. G. Sarwar (07/07) -C <> Hazardous Air Pollutants that are believed to undergo significant dry -C deposition. Hydrazine and triethylamine reactivities are based on analogies -C to NH3. Maleic anhydride reactivity is assumed similar to aldehydes. -C Toluene diisocyanate and hexamethylene diisocyanate reactivities are -C assumed to be similar to SO2. Diffusivities are calculated with standard -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------------------------------------------------------------------------------- - - Use GRID_CONF ! horizontal & vertical domain specifications - Use LSM_MOD ! Land surface data - Use DEPVVARS, Only: ltotg - - Implicit None - - Include SUBST_CONST ! constants - - Type :: MET_Type -!> 2-D meteorological fields: - Real, Allocatable :: RDEPVHT ( :,: ) ! air dens / dep vel ht - 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 :: RC ( :,: ) ! convective precipitation [cm] - Real, Allocatable :: RN ( :,: ) ! non-convective precipitation [mc] - 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] - Real, Allocatable :: SNOCOV ( :,: ) ! Snow cover [1=yes, 0=no] - Real, Allocatable :: TEMP2 ( :,: ) ! two meter temperature [K] - Real, Allocatable :: TEMPG ( :,: ) ! skin temperature [K] - Real, Allocatable :: TSEASFC ( :,: ) ! SST [K] - Real, Allocatable :: USTAR ( :,: ) ! surface friction velocity [m/s] - Real, Allocatable :: VEG ( :,: ) ! fractional vegetation coverage [ratio] - Real, Allocatable :: LAI ( :,: ) ! grid cell leaf area index [m**2/m**2] - Real, Allocatable :: WR ( :,: ) ! precip intercepted by canopy [m] - Real, Allocatable :: WSPD10 ( :,: ) ! 10-m wind speed [m/s] - Real, Allocatable :: WSTAR ( :,: ) ! convective velocity scale [m/s] - Real, Allocatable :: Z0 ( :,: ) ! roughness length [m] - Real, Allocatable :: SOIM1 ( :,: ) ! 1 cm soil moisture [m**3/m**3] - Real, Allocatable :: SOIM2 ( :,: ) ! 1 m soil moisture [m**3/m**3] - Real, Allocatable :: SOIT1 ( :,: ) ! 1 cm soil temperature [K] - Real, Allocatable :: SOIT2 ( :,: ) ! 1 m soil temperature [K] - Real, Allocatable :: SEAICE ( :,: ) ! Sea ice coverage [%] - Real, Allocatable :: MOL ( :,: ) ! Monin-Obukhov length [m] - Real, Allocatable :: MOLI ( :,: ) ! inverse of Monin-Obukhov length [m] - Real, Allocatable :: HOL ( :,: ) ! PBL over Obukhov length - Real, Allocatable :: XPBL ( :,: ) ! PBL sigma height - 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) - -!> 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 - -!> 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 :: QV ( :,:,: ) ! water vapor mixing ratio - Real, Allocatable :: QC ( :,:,: ) ! cloud water mixing ratio - Real, Allocatable :: THETAV ( :,:,: ) ! potential temp - Real, Allocatable :: TA ( :,:,: ) ! temperature (K) - Real, Allocatable :: ZH ( :,:,: ) ! mid-layer height above ground [m] - Real, Allocatable :: ZF ( :,:,: ) ! layer height [m] - Real, Allocatable :: DZF ( :,:,: ) ! layer surface thickness - Real, Allocatable :: DENS ( :,:,: ) ! air density - Real, Allocatable :: RJACM ( :,:,: ) ! reciprocal mid-layer Jacobian - Real, Allocatable :: RJACF ( :,:,: ) ! reciprocal full-layer Jacobian - Real, Allocatable :: RRHOJ ( :,:,: ) ! reciprocal density X Jacobian - End Type MET_Type - - Type :: GRID_Type -!> Grid infomation: -!> Vertical information - Real, Allocatable :: DX3F ( : ) ! sigma layer surface thickness ! vdiffacmx.F - Real, Allocatable :: RDX3F ( : ) ! reciprocal sigma layer thickness ! EMIS_DEFN.F, sedi.F, vdiffacmx.F, vdiffproc.F - Real, Allocatable :: RDX3M ( : ) ! reciprocal sigma midlayer thickness ! vdiffproc.F -!> Horizontal Information: - Real, Allocatable :: RMSFX4 ( :,: ) ! inverse map scale factor ** 4 - 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 :: PURB ( :,: ) ! percent urban [%] - Integer, Allocatable :: SLTYP ( :,: ) ! soil type [category] - Real, Allocatable :: WSAT ( :,: ) ! soil wilting point - 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 :: RHOB ( :,: ) ! soil bulk density - 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 - - Integer, Save :: n_spc_m3dry = ltotg ! from DEPVVARS module -!> M3 asx constants - Real, Parameter :: a0 = 8.0 ! [dim'less] - Real, Parameter :: d3 = 1.38564e-2 ! [dim'less] - Real, Parameter :: dwat = 0.2178 ! [cm^2/s] at 273.15K - Real, Parameter :: hplus_ap = 1.0e-6 ! pH=6.0 leaf apoplast solution Ph (Massad et al 2008) - Real, Parameter :: hplus_def = 1.0e-5 ! pH=5.0 - Real, Parameter :: hplus_east = 1.0e-5 ! pH=5.0 - Real, Parameter :: hplus_h2o = 7.94328e-9 ! 10.0**(-8.1) - Real, Parameter :: hplus_west = 3.16228e-6 ! 10.0**(-5.5) - Real, Parameter :: kvis = 0.132 ! [cm^2 / s] at 273.15K - Real, Parameter :: pr = 0.709 ! [dim'less] - Real, Parameter :: rcut0 = 3000.0 ! [s/m] - Real, Parameter :: rcw0 = 125000.0 ! acc'd'g to Padro and - Real, Parameter :: resist_max = 1.0e30 ! maximum resistance - 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 :: 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 - Real, Parameter :: twothirds = 2.0 / 3.0 - Real, Parameter :: betah = 5.0 ! WRF 3.6 px uses Dyer - Real, Parameter :: gamah = 16.0 - Real, Parameter :: pr0 = 0.95 - Real, Parameter :: karman = 0.40 - Real, Parameter :: f3min = 0.25 - Real, Parameter :: ftmin = 0.0000001 ! m/s - Real, Parameter :: nscat = 16.0 - Real, Parameter :: rsmax = 5000.0 ! s/m - - Real :: ar ( ltotg ) ! reactivity relative to HNO3 - Real :: dif0 ( ltotg ) ! molecular diffusivity [cm2/s] - Real :: lebas ( ltotg ) ! Le Bas molar volume [cm3/mol ] - Real :: meso ( ltotg ) ! Exception for species that - ! react with cell walls. fo in - ! Wesely 1989 eq 6. - 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. - - Public :: INIT_MET - - Logical, Private, Save :: ifsst = .false. - Logical, Private, Save :: ifq2 = .false. - Logical, Private, Save :: rinv = .True. - Logical, Private, Save :: iflh = .false. - - Integer, Private :: C, R, L, S ! loop induction variables - Integer, Private :: SPC - Character( 16 ), Private, Save :: vname_rc, vname_rn, vname_uc, vname_vc - Real, Private, Save :: P0 ! reference pressure (100000.0 Pa) for Potential Temperature, note that in meteorology they do not use the SI 1 ATM. - - Integer, Private, Save :: LOGDEV - Integer, Private, Save :: GXOFF, GYOFF ! global origin offset from file - Integer, Private, Save :: STRTCOLMC3, ENDCOLMC3, STRTROWMC3, ENDROWMC3 ! MET_CRO_3D - Integer, Private, Save :: STRTCOLMD3, ENDCOLMD3, STRTROWMD3, ENDROWMD3 ! MET_DOT_3D - Integer, Private, Save :: STRTCOLMC2, ENDCOLMC2, STRTROWMC2, ENDROWMC2 ! MET_CRO_2D - Integer, Private, Save :: STRTCOL_O1, ENDCOL_O1, STRTROW_O1, ENDROW_O1 ! OCEAN_1 - - Real, Pointer, Private :: BUFF1D( : ) ! 1D temp var number of layers - Real, Pointer, Private :: BUFF2D( :,: ) ! 2D temp var - Real, Pointer, Private :: BUFF3D( :,:,: ) ! 3D temp var - -! FENGSHA option control - CHARACTER( 20 ), SAVE :: CTM_FENGSHA = 'CTM_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. - - CONTAINS - -C======================================================================= - Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) - -C----------------------------------------------------------------------- -C 30 Mar 01 J.Young: dyn alloc - Use HGRD_DEFN; replace INTERP3 with INTERPX; -C allocatable RDEPVHT, RJACM, RRHOJ -C 14 Nov 03 J.Young: add reciprocal vertical Jacobian product for full and -C mid-layer -C Tanya took JACOBF out of METCRO3D! Improvise -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----------------------------------------------------------------------- - - Use UTILIO_DEFN - - 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' - Character( 16 ) :: VNAME - CHARACTER( 16 ) :: UNITSCK - 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 - ALLOCATE ( BUFF1D( NLAYS ), - & BUFF2D( NCOLS,NROWS ), - & BUFF3D( NCOLS,NROWS,NLAYS ), STAT = ALLOCSTAT ) - If ( ALLOCSTAT .Ne. 0 ) Then - XMSG = 'Failure allocating Buffers' - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - BUFF1D = 0.0 - BUFF2D = 0.0 - BUFF3D = 0.0 - -!> Allocate shared arrays -!> Met_Data - ALLOCATE( Met_Data%RDEPVHT ( NCOLS,NROWS ), - & Met_Data%DENS1 ( NCOLS,NROWS ), - & Met_Data%PRSFC ( NCOLS,NROWS ), - & Met_Data%Q2 ( NCOLS,NROWS ), - & Met_Data%QSS_GRND ( NCOLS,NROWS ), - & Met_Data%RH ( NCOLS,NROWS ), - & Met_Data%RA ( NCOLS,NROWS ), - & Met_Data%RS ( NCOLS,NROWS ), - & Met_Data%RC ( NCOLS,NROWS ), - & Met_Data%RN ( NCOLS,NROWS ), - & Met_Data%RGRND ( NCOLS,NROWS ), - & Met_Data%HFX ( NCOLS,NROWS ), - & Met_Data%LH ( NCOLS,NROWS ), - & Met_Data%SNOCOV ( NCOLS,NROWS ), - & Met_Data%TEMP2 ( NCOLS,NROWS ), - & Met_Data%TEMPG ( NCOLS,NROWS ), - & Met_Data%TSEASFC ( NCOLS,NROWS ), - & Met_Data%USTAR ( NCOLS,NROWS ), - & Met_Data%VEG ( NCOLS,NROWS ), - & Met_Data%LAI ( NCOLS,NROWS ), - & Met_Data%WR ( NCOLS,NROWS ), - & Met_Data%WSPD10 ( NCOLS,NROWS ), - & Met_Data%WSTAR ( NCOLS,NROWS ), - & Met_Data%Z0 ( NCOLS,NROWS ), - & Met_Data%SOIM1 ( NCOLS,NROWS ), - & Met_Data%SOIT1 ( NCOLS,NROWS ), - & Met_Data%SEAICE ( NCOLS,NROWS ), - & Met_Data%MOL ( NCOLS,NROWS ), - & Met_Data%MOLI ( NCOLS,NROWS ), - & Met_Data%HOL ( NCOLS,NROWS ), - & Met_Data%XPBL ( NCOLS,NROWS ), - & Met_Data%LPBL ( NCOLS,NROWS ), - & Met_Data%CONVCT ( NCOLS,NROWS ), - & Met_Data%PBL ( NCOLS,NROWS ), - & Met_Data%NACL_EMIS( NCOLS,NROWS ), - & Met_Data%UWIND ( NCOLS+1,NROWS+1,NLAYS ), - & Met_Data%VWIND ( NCOLS+1,NROWS+1,NLAYS ), - & Met_Data%KZMIN ( NCOLS,NROWS,NLAYS ), - & Met_Data%PRES ( NCOLS,NROWS,NLAYS ), - & Met_Data%QV ( NCOLS,NROWS,NLAYS ), - & Met_Data%QC ( NCOLS,NROWS,NLAYS ), - & Met_Data%THETAV ( NCOLS,NROWS,NLAYS ), - & Met_Data%TA ( NCOLS,NROWS,NLAYS ), - & Met_Data%ZH ( NCOLS,NROWS,NLAYS ), - & Met_Data%ZF ( NCOLS,NROWS,NLAYS ), - & Met_Data%DZF ( NCOLS,NROWS,NLAYS ), - & Met_Data%DENS ( NCOLS,NROWS,NLAYS ), - & Met_Data%RJACM ( NCOLS,NROWS,NLAYS ), - & Met_Data%RJACF ( NCOLS,NROWS,NLAYS ), - & Met_Data%RRHOJ ( NCOLS,NROWS,NLAYS ), - & STAT = ALLOCSTAT ) - If ( ALLOCSTAT .Ne. 0 ) Then - XMSG = 'Failure allocating met vars' - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - ALLOCATE( Grid_Data%DX3F ( NLAYS ), - & Grid_Data%RDX3F ( NLAYS ), - & Grid_Data%RDX3M ( NLAYS ), - & Grid_Data%RMSFX4 ( NCOLS,NROWS ), - & Grid_Data%LON ( NCOLS,NROWS ), - & Grid_Data%LAT ( NCOLS,NROWS ), - & Grid_Data%LWMASK ( NCOLS,NROWS ), - & Grid_Data%OCEAN ( NCOLS,NROWS ), - & Grid_Data%SZONE ( NCOLS,NROWS ), - & Grid_Data%PURB ( NCOLS,NROWS ), - & Grid_Data%SLTYP ( NCOLS,NROWS ), - & Grid_Data%NAME ( n_lufrac ), - & Grid_Data%LU_Type ( n_lufrac ), - & STAT = ALLOCSTAT ) - If ( ALLOCSTAT .Ne. 0 ) Then - XMSG = 'Failure allocating grid vars' - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - Grid_Data%NAME = name_lu - Grid_Data%LU_Type = cat_lu - - If ( ABFLUX .Or. HGBIDI .Or. MOSAIC ) Then - ALLOCATE( Met_Data%SOIM2 ( NCOLS,NROWS ), - & Met_Data%SOIT2 ( NCOLS,NROWS ), - & STAT = ALLOCSTAT ) - If ( ALLOCSTAT .Ne. 0 ) Then - XMSG = 'Failure allocating mosaic met vars' - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - ALLOCATE( Grid_Data%WSAT ( NCOLS,NROWS ), - & Grid_Data%WWLT ( NCOLS,NROWS ), - & Grid_Data%BSLP ( NCOLS,NROWS ), - & Grid_Data%WRES ( NCOLS,NROWS ), - & Grid_Data%WFC ( NCOLS,NROWS ), - & Grid_Data%LUFRAC ( NCOLS,NROWS,n_lufrac ), - & STAT = ALLOCSTAT ) - If ( ALLOCSTAT .Ne. 0 ) Then - XMSG = 'Failure allocating mosaic 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 - - 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 ), - & STAT = ALLOCSTAT ) - If ( ALLOCSTAT .Ne. 0 ) Then - XMSG = 'Failure allocating chemistry dependent mosaic vars' - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - ChemMos_Data%Rb = resist_max - ChemMos_Data%Rst = resist_max - ChemMos_Data%Rcut = resist_max - ChemMos_Data%Rgc = resist_max - ChemMos_Data%Rgb = resist_max - ChemMos_Data%Rwat = resist_max - ChemMos_Data%CZ0 = 0.0 - ChemMos_Data%Cleaf = 0.0 - ChemMos_Data%Cstom = 0.0 - ChemMos_Data%Ccut = 0.0 - ChemMos_Data%Csoil = 0.0 - ChemMos_Data%NAME = name_lu - ChemMos_Data%LU_Type = cat_lu - ChemMos_Data%SubName = subname - End If - -!> ccccccccccccccccccccc Fengsha option!ccccccccccccccccccccc - FENGSHA = ENVYN( 'CTM_FENGSHA', - & 'Flag for in-line fengsha ', - & .FALSE., IOSX ) - - If ( FENGSHA ) Then - ALLOCATE( Met_Data%CLAYF ( NCOLS,NROWS ), - & Met_Data%SANDF ( NCOLS,NROWS ), - & Met_Data%DRAG ( NCOLS,NROWS ), - & Met_Data%UTHR ( NCOLS,NROWS ), - & STAT = ALLOCSTAT ) - If ( ALLOCSTAT .Ne. 0 ) Then - XMSG = 'Failure allocating Fengsha variables' - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - End If - -!> ccccccccccccccccccccc enable backward compatiblity ccccccccccccccccccccc - - If ( .Not. desc3( met_cro_2d ) ) Then - xmsg = 'Could not get ' // MET_CRO_2D // ' file description' - Call m3exit( pname, JDATE, JTIME, xmsg, xstat2 ) - End If - - SPC = INDEX1( 'RA', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) rinv = .FALSE. ! Ra and Rst are in units s/m - - SPC = INDEX1( 'WR', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) ifwr = .True. ! canopy wetness is in METCRO2D - - SPC = INDEX1( 'Q2', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) ifq2 = .True. ! two meter mixing ratio in METCRO2D - - SPC = INDEX1( 'TSEASFC', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) ifsst = .True. ! two meter SST in METCRO2D - - SPC = INDEX1( 'LH', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) iflh = .True. ! LH in METCRO2D - - SPC = INDEX1( 'RCA', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) Then - vname_rc = 'RCA' - Else - vname_rc = 'RC' - End If - - SPC = INDEX1( 'RNA', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) 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 - vname_uc = 'UWINDC' - CSTAGUV = .TRUE. - Else - vname_uc = 'UWIND' - CSTAGUV = .FALSE. - End If - - SPC = INDEX1( 'VWINDC', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) 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 ) ) - End Do - Do L = 1, NLAYS - 1 - Grid_Data%RDX3M( L ) = 1.0 / ( X3M( L+1 ) - X3M( 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 - - 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 - - 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 - - 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 - - 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%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 - - 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 ) ) - Grid_Data%WWLT( C,R ) = WWLT( Grid_Data%SLTYP( C,R ) ) - Grid_Data%WFC ( C,R ) = WFC ( Grid_Data%SLTYP( C,R ) ) - 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 - - MET_INITIALIZED = .true. - - Return - End Subroutine INIT_MET - -C======================================================================= - Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) - -C----------------------------------------------------------------------- -C 30 Mar 01 J.Young: dyn alloc - Use HGRD_DEFN; replace INTERP3 with INTERPX; -C allocatable RDEPVHT, RJACM, RRHOJ -C 14 Nov 03 J.Young: add reciprocal vertical Jacobian product for full and -C mid-layer -C Tanya took JACOBF out of METCRO3D! Improvise -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----------------------------------------------------------------------- - - USE GRID_CONF ! horizontal & vertical domain specifications - Use UTILIO_DEFN -#ifdef parallel - USE SE_MODULES ! stenex (using SE_COMM_MODULE) -#else - USE NOOP_MODULES ! stenex (using NOOP_COMM_MODULE) -#endif - - Implicit None - - 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] - Real, Parameter :: KZMAXL = 500.0 ! upper limit for min Kz [m] - Real, Parameter :: KZ0UT = 1.0 ! minimum eddy diffusivity [m**2/sec] KZ0 - Real, Parameter :: KZL = 0.01 ! lowest KZ - Real, Parameter :: KZU = 1.0 ! 2.0 ! highest KZ - Real, Parameter :: EPS = 1.0E-08 ! small number for temperature difference - -C Local variables: - 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 - - Character( 16 ) :: PNAME = 'GET_MET' - Character( 16 ) :: VNAME - CharactER( 30 ) :: MSG1 = ' Error interpolating variable ' - Character( 96 ) :: XMSG = ' ' - -C----------------------------------------------------------------------- -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 - - 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 - - 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 - - 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 - - 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 - - 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 - - Met_Data%RRHOJ = 1.0 / Met_Data%RRHOJ - - VNAME = 'TA' - IF ( .NOT. INTERPX( MET_CRO_3D, VNAME, PNAME, - & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, - & JDATE, JTIME, Met_Data%TA ) ) THEN - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D - CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - END IF - - VNAME = 'QV' - IF ( .NOT. INTERPX( MET_CRO_3D, VNAME, PNAME, - & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, - & JDATE, JTIME, Met_Data%QV ) ) THEN - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D - CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - END IF - - VNAME = 'QC' - IF ( .NOT. INTERPX( MET_CRO_3D, VNAME, PNAME, - & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, - & JDATE, JTIME, Met_Data%QC ) ) THEN - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D - CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - END IF - -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 - - 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 - - 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 - write(*,*) 'Read clayfrac' - 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 - write(*,*) 'read sandfrac' - VNAME = 'SANDF' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%SANDF ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - VNAME = 'DRAG' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%DRAG ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - VNAME = 'UTHR' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%UTHR ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - End If -C Soil vars - VNAME = 'SOIM1' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%SOIM1 ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - If ( ABFLUX .Or. HGBIDI .Or. MOSAIC ) Then - VNAME = 'SOIM2' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%SOIM2 ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - 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 - - VNAME = 'SOIT1' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%SOIT1 ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - 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 ) - End If - -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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - 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 - 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 - - 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 - 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 - 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 - - Where( Met_Data%RA .Gt. cond_min ) - Met_Data%RA = 1.0/Met_Data%RA - Elsewhere - 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 - - Where( Met_Data%RS .Gt. cond_min ) - Met_Data%RS = 1.0 / Met_Data%RS - Elsewhere - Met_Data%RS = resist_max - End Where - - 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 - - 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 - - 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 - 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 ) ) - Elsewhere - Es_Grnd = 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 ) - - Es_Air => BUFF2D - Where( Met_Data%TEMP2 .Lt. stdtemp ) - Es_Air = vp0 *Exp( 22.514 - ( 6.15e3 / Met_Data%TEMP2 ) ) - Elsewhere - Es_Air = 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 - End Where - Nullify( Es_Air ) - -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 - - 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 - -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 ) - CALL SUBST_COMM ( Met_Data%VWIND, DSPL_N1_E0_S0_W0, DRCN_N ) - -C-------------------------------- Calculated Variables -------------------------------- - Met_Data%DZF = Met_Data%ZF - EOSHIFT(Met_Data%ZF, Shift = -1, Boundary = 0.0, Dim = 3) - - Met_Data%RDEPVHT = 1.0 / Met_Data%ZF( :,:,1 ) - - IF ( MINKZ ) THEN - Met_Data%KZMIN = KZL - DO L = 1, NLAYS - Where( Met_Data%ZF( :,:,L ) .LE. KZMAXL ) - Met_Data%KZMIN( :,:,L ) = KZL + ( KZU - KZL ) * 0.01 * Grid_data%PURB - End Where - End Do - ELSE - 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 ) - -C------ Updating MOL, then WSTAR, MOLI, HOL - DO R = 1, MY_NROWS - DO C = 1, MY_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 ) ) - TMPVTCON = 1.0 + 0.608 * Met_Data%QV( C,R,1 ) ! Conversion factor for virtual temperature - TST = -TMPFX / Met_Data%USTAR( C,R ) - IF ( Met_Data%TA( C,R,1 ) .GT. STDTEMP ) THEN - LV = LV0 - ( 0.00237 * ( Met_Data%TA( C,R,1 ) - STDTEMP ) ) * 1.0E6 - ELSE - LV = 2.83E6 ! Latent heat of sublimation at 0C from Stull (1988) (J/KG) - END IF - QST = -( Met_Data%LH( C,R ) / LV ) - & / ( Met_Data%USTAR( C,R ) * Met_Data%DENS( C,R,1 ) ) - TSTV = TST * TMPVTCON + Met_Data%THETAV( C,R,1 ) * 0.608 * QST - IF ( ABS( TSTV ) .LT. 1.0E-6 ) THEN - TSTV = SIGN( 1.0E-6, TSTV ) - END IF - Met_Data%MOL( C,R ) = Met_Data%THETAV( C,R,1 ) - & * Met_Data%USTAR( C,R ) ** 2 / ( karman * GRAV * TSTV ) - IF ( Met_Data%MOL( C,R ) .LT. 0.0 ) THEN - Met_Data%WSTAR( C,R ) = Met_Data%USTAR( C,R ) * ( Met_Data%PBL( C,R ) - & / ( karman * ABS( Met_Data%MOL( C,R ) ) ) ) ** 0.333333 - ELSE - Met_Data%WSTAR( C,R ) = 0.0 - END IF - - END DO - END DO - - Met_Data%MOLI = 1.0 / Met_Data%MOL - Met_Data%HOL = Met_Data%PBL / Met_Data%MOL -C------ - - Met_Data%CONVCT = .FALSE. - DO R = 1, MY_NROWS - DO C = 1, MY_NCOLS - DO L = 1, NLAYS - IF ( Met_Data%PBL( C,R ) .LT. Met_Data%ZF( C,R,L ) ) THEN - LP = L; EXIT - END IF - END DO - - Met_Data%LPBL( C,R ) = LP - If ( LP .Eq. 1 ) Then - FINT = ( Met_Data%PBL( C,R ) ) - & / ( Met_Data%ZF( C,R,LP ) ) - Met_Data%XPBL( C,R ) = FINT * ( X3FACE_GD( LP ) - X3FACE_GD( LP-1 ) ) - & + X3FACE_GD( LP-1 ) - Else - FINT = ( Met_Data%PBL( C,R ) - Met_Data%ZF( C,R,LP-1 ) ) - & / ( Met_Data%ZF( C,R,LP ) - Met_Data%ZF( C,R,LP-1 ) ) - Met_Data%XPBL( C,R ) = FINT * ( X3FACE_GD( LP ) - X3FACE_GD( LP-1 ) ) - & + X3FACE_GD( LP-1 ) - End If - END DO - END DO - Where( Met_Data%THETAV( :,:,1 ) - Met_Data%THETAV( :,:,2 ) .Gt. EPS .And. - & Met_Data%HOL .Lt. -0.02 .And. Met_Data%LPBL .Gt. 3 ) - Met_Data%CONVCT = .True. - End Where - - Return - End Subroutine GET_MET - - End Module ASX_DATA_MOD diff --git a/src/model/src/DUST_EMIS.F b/src/model/src/DUST_EMIS.F deleted file mode 100644 index 3fb64c8..0000000 --- a/src/model/src/DUST_EMIS.F +++ /dev/null @@ -1,1525 +0,0 @@ - -!------------------------------------------------------------------------! -! The Community Multiscale Air Quality (CMAQ) system software is in ! -! continuous development by various groups and is based on information ! -! from these groups: Federal Government employees, contractors working ! -! within a United States Government contract, and non-Federal sources ! -! including research institutions. These groups give the Government ! -! permission to use, prepare derivative works of, and distribute copies ! -! of their work in the CMAQ system to the public and to permit others ! -! to do so. The United States Environmental Protection Agency ! -! therefore grants similar permission to use the CMAQ system software, ! -! but users are requested to provide copies of derivative works or ! -! products designed to operate in the CMAQ system to the United States ! -! Government without restrictions as to use by others. Software ! -! that is used with the CMAQ system but distributed under the GNU ! -! General Public License or the GNU Lesser General Public License is ! -! subject to their copyright restrictions. ! -!------------------------------------------------------------------------! - - -C 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 - -C----------------------------------------------------------------------- -C Description: -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 - -C Revision History: -C 16 Dec 10 J.Young: Adapting Daniel Tong`s work on windblown dust -C 21 Apr 11 S.Roselle: replaced I/O API include files with UTILIO_DEFN -C 11 May 11 D.Wong: incorporated twoway model implementation -C 8 Jul 11 J.Young: unified string lengths in character lists for compiler compatibility -C 11 Nov 11 J.Young: generalizing land use/cover -C 8 Jun 12 J.Young: remove full character blank padding for GNU Fortran (GCC) 4.1.2 -C 13 Jul 12 J.Young: following Daniel Tong: changed clayc, siltc, sandc units from mass -C fraction to %; adjusted F/G (vertical to horizontal flux) ratio -C to be continuous for clay content > 20% -C 30 Sep 13 J.Young: corrected diag file units description; added snow cover adjustment; -C adjusted F/G (vertical to horizontal flux) ratio to be continuous -C for clay content > 0.2; convert volumetric soil moisture to -C gravimetric water content; corrected soil moisture factor (fmoit); -C use lwmask>0 rather than sltyp>0 (non-existent) for over water test -C 15 Sep 15 H.Foroutan: revised threshold friction velocity parameterization -C 20 Oct 15 H.Foroutan: Updated the calculation of the threshold velocity(U*t), which is -C now based on dust particle size, following Shao and Lu [JGR,2000]. -C Implemented a dynamic vegetation fraction based on the MODIS FPAR. -C Introduced a new parametrization for surface roughness (z0) -C applicable to dust emission schemes, and accordingly calculated -C the friction velocity (U*) at the surface using 10m wind speed -C and the new (microspcopic) surface roughness. -C Surface roughness adjusted for estimated annual vegetation height. -C Included drag partitioning coefficient. Updated the calculation of -C the vertical-to-horizontal flux based on Lu and Shao [JGR,1999]. -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----------------------------------------------------------------------- - use lus_defn - use aero_data - - 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, - & dust_emis_init, get_dust_emis - private - - real, allocatable, save :: dust_em( :,: ) ! total dust emissions [g/m**3/s] - -C updated values of mass fraction for "freshly emitted dust" -C based on Kok [PNAS, 2011] and Nabat et al. [ACP, 2012] - real, parameter :: fracmj = 0.07 ! mass fraction assigned to accum mode - real, parameter :: fracmk = 0.93 ! mass fraction assigned to coarse mode - -C diam`s from fracmj,fracmk-weighted 2 2-bin averages of geom means -C 2 J-mode bins: 0.1-1.0, 1.0-2.5 um -C 2 K-mode bins: 2.5-5.0, 5.0-10.0 um - real, parameter :: dgvj = 1.3914 ! geom mean diam of accum mode [um] - real, parameter :: dgvk = 5.2590 ! geom mean diam of coarse mode [um] - real, parameter :: sigj = 2.0000 ! geom std deviation of accum mode flux - real, parameter :: sigk = 2.0000 ! geom std deviation of coarse mode flux - -C Local Variables: - -C Factors for converting 3rd moment emission rates into number and 2nd moment -C emission rates. (Diameters in [um] changed to [m] ) See Equations 7b and 7c -C of Binkowski & Roselle (2003) - real :: l2sgj ! [ln( sigj )] ** 2 - real :: l2sgk ! [ln( sigk )] ** 2 - real, save :: factnumj ! = exp( 4.5 * l2sgj ) / dgvj ** 3 * 1.0e18 - real, save :: factnumk ! = exp( 4.5 * l2sgk ) / dgvk ** 3 * 1.0e18 - real, save :: factm2j ! = exp( 0.5 * l2sgj ) / dgvj * 1.0e6 - real, save :: factm2k ! = exp( 0.5 * l2sgk ) / dgvk * 1.0e6 - 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 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, save :: ndust_diag ! number of diagnostic output vars - real, allocatable, save :: diagv( : ) ! diagnostic output variables - real, allocatable, save :: dustbf( :,:,: ) ! diagnostic accumulate buffer - -#ifdef verbose_wbdust - real, allocatable, save :: sdiagv( : ) ! global sum of each diag output var -#endif - - type diag_type - character( 16 ) :: var - character( 16 ) :: units - character( 80 ) :: desc - end type diag_type - - type( diag_type ), allocatable, save :: diagnm( : ) - type( diag_type ), allocatable, save :: vdiagnm_emis( : ) - type( diag_type ), allocatable, save :: vdiagnm_frac( : ) - type( diag_type ), allocatable, save :: vdiagnm_ustar( : ) - type( diag_type ), allocatable, save :: vdiagnm_kvh( : ) - type( diag_type ), allocatable, save :: vdiagnm_rough( : ) - - character( 10 ) :: truncnm - character( 16 ) :: vnm - - 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 ')/) - -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======================================================================= - function dust_emis_init( jdate, jtime, tstep ) result( success ) - -C Revision History. -C Aug 12, 15 D. Wong: Replaced MYPE with IO_PE_INCLUSIVE for parallel I/O -C implementation - - use hgrd_defn ! horizontal domain specifications - use aero_data ! aerosol species definitions - use asx_data_mod ! meteorology data - use utilio_defn - -C Arguments: - integer, intent( in ) :: jdate ! current model date, coded YYYYDDD - integer, intent( in ) :: jtime ! current model time, coded HHMMSS - integer, intent( in ) :: tstep ! output time step - logical 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 - - logical :: erode_agland = .true. ! default - integer status - integer c, r, i, j, k, l, n - integer idiag - integer n_mass_emissions - - integer gxoff, gyoff ! global origin offset from file - integer, save :: strtcol, endcol, strtrow, endrow - integer jdatemod - - 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 ) - if ( status .ne. 0 ) then - xmsg = '*** Failure allocating DUSTOUTM, DUSTOUTN, or DUSTOUTS' - call m3warn ( pname, jdate, jtime, xmsg ) - success = .false.; return - end if - -C Allocate emissions array - allocate( dust_em( ncols,nrows ), stat = status ) - if ( status .ne. 0 ) then - xmsg = '*** Failure allocating DUST_EM' - call m3warn( pname, jdate, jtime, xmsg ) - success = .false.; return - end if - -C Allocate private arrays - allocate( agland( ncols,nrows ), - & wmax ( ncols,nrows ), - & sd_ep ( ncols,nrows ), - & fpar ( ncols,nrows ), - & tfb ( ncols,nrows ), stat = status ) - if ( status .ne. 0 ) then - xmsg = '*** Failure allocating AGLAND, WMAX, FPAR, SD_EP, or TFB' - 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 - xmsg = 'Failure initializing land use module' - 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) - allocate( vdiagnm_emis ( n_dlcat ), - & vdiagnm_frac ( n_dlcat ), - & vdiagnm_kvh ( n_dlcat ), - & vdiagnm_rough( n_dlcat ), - & vdiagnm_ustar( n_dlcat ), stat = status ) - if ( status .ne. 0 ) then - xmsg = '*** Failure allocating VDIAGNM_*' - call m3warn( pname, jdate, jtime, xmsg ) - success = .false.; return - end if - vdiagnm_emis = diag_type( ' ', ' ', ' ' ) ! array assignment - vdiagnm_frac = diag_type( ' ', ' ', ' ' ) ! array assignment - vdiagnm_ustar = diag_type( ' ', ' ', ' ' ) ! array assignment - 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 - - ndust_diag = fndust_diag + 5 * n_dlcat + n_mass_emissions - - do i = 1, n_dlcat - truncnm = vnmld( i )%desc ! char( 10 ) -C... replace embedded spaces (within 16 chars) with "_" -C... replace embedded dashes (within 16 chars) with "_" - l = len_trim( truncnm ) - do k = 1, l - if ( truncnm( k:k ) .eq. " " .or. - & truncnm( k:k ) .eq. "-" ) truncnm( k:k ) = "_" - end do - vnm = trim( truncnm ) // '_Emis' ! char( 16 ) - vdiagnm_emis( i ) = diag_type( vnm, 'g/m**2/s', vnmld( i )%desc ) - vnm = trim( truncnm ) // '_Frac' ! char( 16 ) - vdiagnm_frac( i ) = diag_type( vnm, 'percent', vnmld( i )%desc ) - vnm = trim( truncnm ) // '_Ustr' ! char( 16 ) - vdiagnm_ustar( i ) = diag_type( vnm, 'm/s', vnmld( i )%desc ) - vnm = trim( truncnm ) // '_Kvh' ! char( 16 ) - vdiagnm_kvh( i ) = diag_type( vnm, '1/m', vnmld( i )%desc ) - vnm = trim( truncnm ) // '_Rough' ! char( 16 ) - vdiagnm_rough( i ) = diag_type( vnm, ' ', vnmld( i )%desc ) - end do - -C Allocate diagnostic emissions arrays - allocate( diagnm( ndust_diag ), ! diag_type - & diagv ( ndust_diag ), - & dustbf( ndust_diag,ncols,nrows ), stat = status ) - if ( status .ne. 0 ) then - xmsg = '*** Failure allocating DIAGNM, DIAGV or DUSTBF' - call m3warn( pname, jdate, jtime, xmsg ) - success = .false.; return - end if - -#ifdef verbose_wbdust - allocate( sdiagv( ndust_diag ), stat = status ) - if ( status .ne. 0 ) then - xmsg = '*** Failure allocating SDIAGV' - call m3warn( pname, jdate, jtime, xmsg ) - success = .false.; return - end if -#endif - -C Build the complete diagnostic name array n for MODIS NOAH - do i = 1, n_dlcat ! 4 - diagnm( i ) = vdiagnm_emis( i ) - end do - n = n_dlcat + 1 - diagnm( n ) = fdiagnm( 1 ) ! Cropland_Emis - n = n + 1 - diagnm( n ) = fdiagnm( 2 ) ! Desertland_Emis - - do i = 1, n_dlcat - diagnm( i+n ) = vdiagnm_frac( i ) - end do - n = n + n_dlcat + 1 - diagnm( n ) = fdiagnm( 3 ) ! Cropland_Frac - n = n + 1 - diagnm( n ) = fdiagnm( 4 ) ! Desertland_Frac - - do i = 1, n_dlcat - diagnm( i+n ) = vdiagnm_ustar( i ) - end do - n = n + n_dlcat + 1 - diagnm( n ) = fdiagnm( 5 ) ! Cropland_Ustar - - do i = 1, n_dlcat - diagnm( i+n ) = vdiagnm_kvh( i ) - end do - n = n + n_dlcat + 1 - diagnm( n ) = fdiagnm( 6 ) ! Cropland_Kvh - - do i = 1, n_dlcat - diagnm( i+n ) = vdiagnm_rough( i ) - end do - n = n + n_dlcat + 1 - diagnm( n ) = fdiagnm( 7 ) ! Cropland_Rough - - n = n - 7 ! add remaining variables in fdiagnm - do i = 8, fndust_diag - idiag = i+n - diagnm( idiag ) = fdiagnm( i ) - end do - -C...append diagnostic variables with mass emissions species - do j = 2, n_mode - 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 - 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 - 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 ) - & // ' emissions for ' - & // Trim( dust_spc( i )%description ) - end do - end do - -! remove unused space in diagnm by deallocated and reallocating to idiag value - allocate( diagnm_swap( ndust_diag ), stat = status ) - if ( status .ne. 0 ) then - xmsg = '*** Failure allocating DIAGNM_SWAP' - call m3warn( pname, jdate, jtime, xmsg ) - success = .false.; return - end if - diagnm_swap = diagnm - - deallocate( diagnm ) - - ndust_diag = idiag - allocate( diagnm( ndust_diag ), stat = status ) - if ( status .ne. 0 ) then - xmsg = '*** Failure reallocating DIAGNM' - call m3warn( pname, jdate, jtime, xmsg ) - success = .false.; return - end if - 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 ) - - 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 - -C Get transport factor within canopy and 4 land use type percents - call tfbelow ( jdate, jtime, tfb ) - - l2sgj = log( sigj ) * log( sigj ) - l2sgk = log( sigk ) * log( sigk ) - -C Factors for converting 3rd moment emission rates into number and 2nd moment -C emission rates. (Diameters in [um] changed to [m] ) See Equations 7b and 7c -C of Binkowski & Roselle (2003) - factnumj = 1.0e18 * exp( 4.5 * l2sgj ) / dgvj ** 3 - factnumk = 1.0e18 * exp( 4.5 * l2sgk ) / dgvk ** 3 - factm2j = 1.0e06 * exp( 0.5 * l2sgj ) / dgvj - factm2k = 1.0e06 * exp( 0.5 * l2sgk ) / dgvk - 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 - - end function dust_emis_init - -C======================================================================= - subroutine opdust_emis ( jdate, jtime, tstep, ndust_var, dust_var ) - -C 27 Dec 10 J.Young: initial - - use grid_conf ! horizontal & vertical domain specifications - use utilio_defn - - implicit none - - include SUBST_FILES_ID ! file name parameters - -C Arguments: - integer, intent( in ) :: jdate ! current model date, coded YYYYDDD - integer, intent( in ) :: jtime ! current model time, coded HHMMSS - integer, intent( in ) :: tstep ! output time step - integer, intent( in ) :: ndust_var - type( diag_type ), intent( in ) :: dust_var( : ) - -C Local variables: - character( 16 ) :: pname = 'OPDUST_EMIS' - character( 96 ) :: xmsg = ' ' - - integer v, l ! loop induction variables - -C----------------------------------------------------------------------- - -C Try to open existing file for update - if ( .not. open3( ctm_dust_emis_1, fsrdwr3, pname ) ) then - xmsg = 'Could not open CTM_DUST_EMIS_1 for update - ' - & // 'try to open new' - call m3mesg( xmsg ) - -C Set output file characteristics based on COORD.EXT and open diagnostic file - ftype3d = grdded3 - sdate3d = jdate - stime3d = jtime - tstep3d = tstep - call nextime( sdate3d, stime3d, tstep3d ) ! start the next hour - - nvars3d = ndust_var - ncols3d = gl_ncols - nrows3d = gl_nrows - nlays3d = 1 - nthik3d = 1 - gdtyp3d = gdtyp_gd - p_alp3d = p_alp_gd - p_bet3d = p_bet_gd - p_gam3d = p_gam_gd - xorig3d = xorig_gd - yorig3d = yorig_gd - xcent3d = xcent_gd - ycent3d = ycent_gd - xcell3d = xcell_gd - ycell3d = ycell_gd - vgtyp3d = vgtyp_gd - vgtop3d = vgtop_gd -! vgtpun3d = vgtpun_gd ! currently, not defined - do l = 1, nlays3d + 1 - vglvs3d( l ) = vglvs_gd( l ) - end do - gdnam3d = grid_name ! from HGRD_DEFN - - do v = 1, nvars3d - vtype3d( v ) = m3real - vname3d( v ) = dust_var( v )%var - units3d( v ) = dust_var( v )%units - vdesc3d( v ) = dust_var( v )%desc - end do - - fdesc3d( 1 ) = 'windblown dust parameters, variables, and' - fdesc3d( 2 ) = 'hourly layer-1 windblown dust emission rates' - do l = 3, mxdesc3 - fdesc3d( l ) = ' ' - end do - -C Open windblown dust emissions diagnostic file - if ( .not. open3( ctm_dust_emis_1, fsnew3, pname ) ) then - xmsg = 'Could not create the CTM_DUST_EMIS_1 file' - call m3exit( pname, sdate3d, stime3d, xmsg, xstat1 ) - end if - - end if - - return - - end subroutine opdust_emis - -C======================================================================= - subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt ) - - use grid_conf ! horizontal & vertical domain specifications - use asx_data_mod ! meteorology data - use aero_data - use utilio_defn - -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 - real, intent( in ) :: rjacm( ncols,nrows ) ! reciprocal Jacobian [1/m] - real, intent( in ) :: cellhgt ! grid-cell height [sigma] - -C Includes: - include SUBST_FILES_ID ! file name parameters - -C External Functions: - -C Parameters: - integer, parameter :: ndp = 4 ! number of soil texture type particle sizes: - ! 1 Coarse sand - ! 2 Fine-medium sand - ! 3 Silt - ! 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 - real, parameter :: betav = 202.0 - real, parameter :: sigv_mv = sigv * mv ! = 0.232 - real, parameter :: betav_mv = betav * mv ! = 32.32 - real, parameter :: mb = 0.5 - real, parameter :: sigb = 1.0 - real, parameter :: betab = 90.0 - real, parameter :: sigb_mb = sigb * mb ! = 0.5 - real, parameter :: betab_mb = betab * mb ! = 45.0 - - real, parameter :: alpha = 0.7 - - character( 16 ) :: pname = 'GET_DUST_EMIS' - character( 16 ) :: vname - character( 96 ) :: xmsg - integer status - integer c, r, j, m, n, v - - integer, save :: wstep = 0 ! local write counter - integer :: mdate, mtime ! diagnostic file write date&time - - ! 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 - real :: lai ( ncols,nrows ) ! leaf area index - - real, allocatable, save :: ustr ( :,:,: ) ! U* [m/s] - real, allocatable, save :: qam ( :,:,: ) ! emis for landuse type [g/m**2/s] - 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 :: 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] - real :: m3k ! 3rd moment coarse mode (K) emis rates [m3/m3/s] - real :: fruf2 ! surface roughness factor squared - - character( 16 ), save :: rc_name, rn_name ! new names: RC -> RCA, RN -> RNA - logical, save :: firstime = .true. - - real :: lambda, vegheight - real :: z0 - real :: lambdav ! vegetation roughness density - Shao et. al [Aus. J. Soil Res., 1996] - real :: flxfac1, flxfac2 ! combined soli type mapping factors - real :: hflux, vflux ! horizontal and vertical dust flux - real :: jday - integer :: emap( n_dlcat+1 ) - -C---FENGSHA FLAG - -C CHARACTER( 20 ), SAVE :: CTM_FENGHSA = 'CTM_FENGSHA ' ! env var for in-line -C LOGICAL, SAVE :: FENGSHA ! flag in-lining canopy shading - -C---Height for veg elements - real :: hv( 4 ) - -C---Roughness density for solid elements -C from Darmenova et al. [JGR,2009] and Xi and Sokolik [JGR,2015] - real :: lambdab( 4 ) = - & (/ 0.03, ! shrubland - & 0.04, ! shrubgrass - & 0.0001, ! barrenland - & 0.15 /) ! cropland - -C---Compound for computational efficiency - real :: hb_lambdab( 4 ) = - & (/ 6.0e-04, ! shrubland - & 8.0e-04, ! shrubgrass - & 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) -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 converted to gravimetric [kg/kg] - real :: soilml1( nsltyp ) = - & (/ 0.242, ! Sand - & 0.257, ! Loamy Sand - & 0.286, ! Sandy Loam - & 0.350, ! Silt Loam - & 0.350, ! Silt - & 0.307, ! Loam - & 0.277, ! Sandy Clay Loam - & 0.350, ! Silty Clay Loam - & 0.332, ! Clay Loam - & 0.284, ! Sandy Clay - & 0.357, ! Silty Clay - & 0.344, ! Clay - & 0.363 /) ! Other - -C---Soil texture: the amount of -C 1: Coarse sand, 2: Fine-medium sand, 3: Silt, 4: Clay -C in each soil type [Kg/Kg]. from Menut et al. [JGR,2013] - real :: soiltxt( nsltyp,ndp ) = reshape ( - & (/ 0.46, 0.46, 0.05, 0.03, ! Sand - & 0.41, 0.41, 0.18, 0.00, ! Loamy Sand - & 0.29, 0.29, 0.32, 0.10, ! Sandy Loam - & 0.00, 0.17, 0.70, 0.13, ! Silt Loam - & 0.00, 0.10, 0.85, 0.05, ! Silt - & 0.00, 0.43, 0.39, 0.18, ! Loam - & 0.29, 0.29, 0.15, 0.27, ! Sandy Clay Loam - & 0.00, 0.10, 0.56, 0.34, ! Silty Clay Loam - & 0.00, 0.32, 0.34, 0.34, ! Clay Loam - & 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 /), ! 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 ) = - & (/ 690.0E-6, ! Coarse sand - & 210.0E-6, ! Fine-medium sand - & 125.0E-6, ! Silt - & 2.0E-6 /) ! Clay - - - interface - subroutine tfabove ( tfa ) - real, intent( out ) :: tfa( :,: ) - end subroutine tfabove - end interface - -#ifdef verbose_wbdust - integer dryhit - integer dusthit -#endif - -C----------------------------------------------------------------------- - - if ( firstime ) then - -! FENGHSA = ENVYN( 'CTM_FENGSHA', -! & 'Flag for fengsha dust emission module', -! & .FALSE., IOSX ) - IF ( FENGSHA ) THEN - XMSG = 'Using Fengsha dust emission module ' - CALL M3MSG2( XMSG ) - END IF - - firstime = .false. - 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 - -C---Calculate transport factor above the canopy - call tfabove ( tfa ) - -C---Get Julian day number in year - jday = float( mod( jdate,1000 ) ) - -C---Vegetation height dynamically changed based on the month of the year -C Veg. heights in [m] for 1: Shrubland 2: shrubgrass 3: barrenland 4: Cropland -C following the idea of Xi and Sokolik [JGR,2015] - if ( jday .gt. 59 .and. jday .le. 90 ) then ! Mar - hv = (/ 0.15 , 0.05 , 0.10 , 0.05 /) - else if ( jday .gt. 90 .and. jday .le. 120 ) then ! Apr - hv = (/ 0.15 , 0.10 , 0.10 , 0.05 /) - else if ( jday .gt. 120 .and. jday .le. 151 ) then ! May - hv = (/ 0.12 , 0.20 , 0.10 , 0.10 /) - else if ( jday .gt. 151 .and. jday .le. 181 ) then ! Jun - hv = (/ 0.12 , 0.15 , 0.10 , 0.30 /) - else if ( jday .gt. 181 .and. jday .le. 212 ) then ! Jul - hv = (/ 0.10 , 0.12 , 0.10 , 0.50 /) - else if ( jday .gt. 212 .and. jday .le. 243 ) then ! Aug - hv = (/ 0.10 , 0.12 , 0.10 , 0.50 /) - else if ( jday .gt. 243 .and. jday .le. 273 ) then ! Sep - hv = (/ 0.10 , 0.10 , 0.10 , 0.30 /) - else if ( jday .gt. 273 .and. jday .le. 304 ) then ! Oct - hv = (/ 0.05 , 0.08 , 0.10 , 0.10 /) - else ! Nov-Feb - hv = (/ 0.05 , 0.05 , 0.05 , 0.05 /) - end if - -#ifdef verbose_wbdust - dryhit = 0 - dusthit = 0 -#endif - -C Initialize windblown dust diagnostics output buffer - if ( dustem_diag .and. wstep .eq. 0 ) then - dustbf = 0.0 ! array assignment -#ifdef verbose_wbdust - sdiagv = 0.0 ! array assignment -#endif - end if - -C set erodible landuse map - do m = 1, n_dlcat - emap( m ) = dmap( m ) ! dmap maps to one of the 3 BELD3 desert types - end do - emap( n_dlcat+1 ) = 4 - -C --------- ###### Start Main Loop ###### --------- - - do r = 1, my_nrows - do c = 1, my_ncols - dust_em( c,r ) = 0.0 - soimt( c,r ) = 0.0 - fmoit( c,r ) = 0.0 ! for diagnostic output visualization - vegfrac( c,r ) = 0.0 - do m = 1, n_dlcat+1 - ustr( c,r,m ) = 0.0 ! for diagnostic output visualization - qam ( c,r,m ) = 0.0 - elus( c,r,m ) = 0.0 - fruf( c,r,m ) = 0.0 - kvh ( c,r,m ) = 0.0 - end do - - 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 ) - vegfree = 1.0 - vegfrac( c,r ) - lambdav = -0.35 * log( vegfree ) ! Shao et al. [Aus. J. Soil Res.,1996] - -C---Dust possiblity only if 1. not over water -C 2. rain < 1/100 in. (1 in. = 2.540 cm) -C 3. not snow-covered -C 4. if soimt <= limit -C 5. desert type or ag landuse -C 6. erodible landuse -C 7. friction velocity > threshold - -!----------------------------------------------------------- -!---------------------- FENGSHA Option --------------------- -!----------------------------------------------------------- - - if ( ( FENGSHA.eq. .true.) .and. ( Grid_Data%lwmask( c,r ) .gt. 0.0 ) .and. - & ( Met_Data%rn( c,r ) + Met_Data%rc( c,r ) .le. 0.0254 ) .and. ! rn, rc = [cm] - & ( Met_Data%snocov( c,r ) .lt. 0.001 ) .and. - & ( Met_Data%drag(c,r) .gt. 0.0 ) ) then ! less than 0.1% snow coverage - -C Calculate maximum amount of the water absorbed -C w` = 0.0014(%clay)**2 + 0.17(%clay) - w` in % -C Fecan et al. [1999,Annales Geophys.,17,144-157] - wmax ( c,r ) = (100.*Met_Data%clayf( c,r )) * - & (100.*Met_Data%clayf( c,r )) * - & .0014d0 + 0.17d0 * (100.*Met_Data%clayf( c,r )) - - soimt( c,r ) = dust_volumetric_to_gravimetric( Met_Data%soim1( c,r ), Met_Data%clayf( c,r ), Met_Data%sandf( c,r )) - -C---Soil moisture effect on U*t - if ( soimt( c,r ) .le. 0.01 * wmax( c,r ) ) then ! wmax in [%] - fmoit( c,r ) = 1.0 - else - fmoit( c,r ) = sqrt( 1.0 + 1.2 * ( 100.0 * soimt( c,r ) - wmax( c,r ) ) ** 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 - kvh( c,r,1 ) = 10. ** (0.134 * (Met_Data%clayf( c,r )*100.) - 6.0) - else - kvh(c,r,1) = 4.0e-4 - endif -C Horizontal Flux - hflux = dust_hflux_fengsha( Met_Data%USTAR( c,r ), - & fmoit( c,r), - & Met_Data%drag( c,r ), - & Met_Data%uthr( c,r ), - & 1.0, ! ssm = 1 - & Met_Data%dens1( c,r ) ) - vflux = hflux * kvh( c,r,1 ) ! [g/m**2/s] - - qam (c,r,1) = qam(c,r,1) + vflux * rlay1hgt * alpha - - dust_em( c,r ) = dust_em( c,r ) + qam(c,r,1) * tfa(c,r) * tfb(c,r) - - -!-------------------------------------------------------------------- -!--------------------- END OF FENGSHA ------------------------------- -!-------------------------------------------------------------------- - - else if ( ( Grid_Data%lwmask( c,r ) .gt. 0.0 ) .and. - & ( Met_Data%rn( c,r ) + Met_Data%rc( c,r ) .le. 0.0254 ) .and. ! rn, rc = [cm] - & ( 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 ) ! [%] - -! 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 ) ) ) ) - - if ( soimt( c,r ) .le. soilml1( j ) ) then -C---Dust possiblity 4 - -#ifdef verbose_wbdust - dryhit = dryhit + 1 -#endif - -C---Soil moisture effect on U*t - if ( soimt( c,r ) .le. 0.01 * wmax( c,r ) ) then ! wmax in [%] - fmoit( c,r ) = 1.0 - else - fmoit( c,r ) = sqrt( 1.0 + 1.21 - & * ( 100.0 * soimt( c,r ) - wmax( c,r ) ) ** 0.68 ) - 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 ) - -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] - select case ( j ) - case( 1, 2 ) ! sand - ! pp = 5000.0 - ! calpha = 0.001 - ! pfrac = 0.06 - ! flxfac1 = calpha * 9.81 * pfrac * 500.0 / pp - flxfac1 = 5.886e-05 - ! flxfac2 = 2.09 * sqrt( 2650.0 / pp ) - flxfac2 = 1.5215430 - case( 3, 4, 6, 8, 9 ) ! loam - ! pp = 10000.0 - ! calpha = 0.0006 - ! pfrac = 0.18 - ! flxfac1 = calpha * 9.81 * pfrac * 500.0 / pp - flxfac1 = 5.2974e-05 - ! flxfac2 = 2.09 * sqrt( 2650.0 / pp ) - flxfac2 = 1.0758933 - case( 7 ) ! sandy clay loam - ! pp = 10000.0 - ! calpha = 0.0006 - ! pfrac = 0.32 - ! flxfac1 = calpha * 9.81 * pfrac * 500.0 / pp - flxfac1 = 9.4176e-05 - ! flxfac2 = 2.09 * sqrt( 2650.0 / pp ) - flxfac2 = 1.0758933 - case( 5, 10, 11, 12 ) ! clay - ! pp = 30000.0 - ! calpha = 0.0002 - ! pfrac = 0.72 - ! flxfac1 = calpha * 9.81 * pfrac * 500.0 / pp - flxfac1 = 2.3544e-05 - ! flxfac2 = 2.09 * sqrt( 2650.0 / pp ) - flxfac2 = 0.1964303 - case default ! others -- no dust - ! pp = 100000.0 - ! calpha = 1.0 - ! pfrac = 0.0 - ! flxfac1 = calpha * 9.81 * pfrac * 500.0 / pp - flxfac1 = 0.0 - ! flxfac2 = 2.09 * sqrt( 2650.0 / pp ) - flxfac2 = 0.3402273 - end select - - 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 ---- - - do m = 1, n_dlcat+1 ! desert type & crop landuse categories - - if ( elus( c,r,m ) .gt. 100.0 .or. elus( c,r,m ) .lt. 0.0 ) then - write( xmsg,2009 ) elus( c,r,m ), c, r, m - call m3exit( pname, jdate, jtime, xmsg, xstat1 ) - end if - - if ( elus( c,r,m ) .gt. 0.0 ) then - - n = emap( m ) - lambda = lambdab( n ) + lambdav - vegheight = ( hb_lambdab( n ) + hv( n ) * lambdav ) / lambda - -C---New parametrization for surface roughness by H. Foroutan - Oct. 2015 - if ( lambda .le. 0.2 ) then - z0 = 0.96 * ( lambda ** 1.07 ) * vegheight - else - z0 = 0.083 * ( lambda ** ( -0.46 ) ) * vegheight - end if - -C---Calculate friction velocity (U*) at the surafce applicable to dust emission - ustr( c,r,m ) = karman * Met_Data%WSPD10( c,r ) / log ( 10.0 / z0 ) - -C---Roughness effect on U*t (Drag partitioning) -C Xi and Sokolik [JGR,2015] - fruf2 = ( 1.0 - sigv_mv * lambdav ) - & * ( 1.0 + betav_mv * lambdav ) - & * ( 1.0 - sigb_mb * lambdab( n ) / vegfree ) - & * ( 1.0 + betab_mb * lambdab( n ) / vegfree ) - - if( fruf2 .gt. 1.0 ) then - - fruf( c,r,m ) = sqrt( fruf2 ) - else - fruf( c,r,m ) = 10.0 - end if - -C---Vert-to-Horiz dust flux ratio : Kang et al. [JGR, 2011] : Eq. (12) -! 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 ) ) - hflux = dust_hflux( ndp, dp, - & soiltxt( j,: ), - & fmoit( c,r ), - & fruf( c,r,m ), - & ustr( c,r,m ), - & sd_ep( c,r ), - & Met_Data%dens1( c,r ) ) - vflux = hflux * kvh( c,r,m ) ! [g/m**2/s] - qam( c,r,m ) = qam( c,r,m ) + vflux * rlay1hgt - & * ( elus( c,r,m ) * 0.01 ) ! [g/m**3/s] - end if ! if erodible land - - if ( elus( c,r,m ) .eq. 0.0 .and. qam( c,r,m ) .ne. 0.0 ) then - xmsg = 'Erodible land use = 0, but emissions .ne. 0' - call m3exit( pname, jdate, jtime, xmsg, xstat1 ) - end if - - dust_em( c,r ) = dust_em( c,r ) + qam( c,r,m ) - - end do ! m landuse - -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 - - end do ! c - end do ! r - -C --------- ###### End Main Loop ##### --------- - -#ifdef verbose_wbdust - write( logdev,'( /5x, a, 1x, 2i8 )' ) 'dry hit count, - & out of total cells:', - & dryhit, (c-1)*(r-1) -#endif - - do r = 1, my_nrows - do c = 1, my_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 - - do n = 2, n_mode - do v = 1, ndust_spc - dustoutm( v,n,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 ) ) - -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 - -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 - -#ifdef verbose_wbdust - if ( m3j .ne. 0.0 ) dusthit = dusthit + 1 -#endif - - if ( dustem_diag ) then - do m = 1, n_dlcat+1 - diagv( m ) = qam( c,r,m ) ! g/m**3/s - end do - n = n_dlcat + 2 - diagv( n ) = dust_em( c,r ) ! g/m**3/s - - sumdfr = 0.0 - do m = 1, n_dlcat+1 - diagv( m+n ) = elus( c,r,m ) - sumdfr = sumdfr + elus( c,r,m ) - end do - n = n + n_dlcat + 2 - diagv( n ) = sumdfr - - do m = 1, n_dlcat+1 - diagv( m+n ) = ustr( c,r,m ) - end do - n = n + n_dlcat + 1 - - do m = 1, n_dlcat+1 - diagv( m+n ) = kvh( c,r,m ) - end do - n = n + n_dlcat + 1 - - do m = 1, n_dlcat+1 - diagv( m+n ) = fruf( c,r,m ) - end do - n = n + n_dlcat + 1 - - diagv( n+1 ) = fmoit( c,r ) ! 'Soil_Moist_Fac ' - diagv( n+2 ) = sd_ep( c,r ) ! 'Soil_Erode_Pot ' - diagv( n+3 ) = wmax ( c,r ) ! 'Mx_Adsrb_H2O_Frc' - 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 - -! accum and coarse mode number density emissions - diagv( n+1 ) = dustoutn( 2,c,r ) - diagv( n+2 ) = dustoutn( 3,c,r ) -! accum and coarse mode surface area density emissions - diagv( n+3 ) = dustouts( 2,c,r ) - diagv( n+4 ) = dustouts( 3,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 - m = m + 1 - diagv( m+n ) = dustoutm( v,2,c,r ) - end if - end do - - do v = 1, ndust_spc - if ( trim( dust_spc( v )%name( 3 ) ) .ne. ' ' ) then ! coarse mode mass emissions - m = m + 1 - diagv( m+n ) = dustoutm( v,3,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 - dustbf( v,c,r ) = dustbf( v,c,r ) + diagv( v ) - & * float( time2sec( tstep( 2 ) ) ) -#ifdef verbose_wbdust - sdiagv( v ) = sdiagv( v ) + diagv( v ) - & * float( time2sec( tstep( 2 ) ) ) -#endif - end do - end if ! dustem_diag - end do ! col - end do ! row - -#ifdef verbose_wbdust - write( logdev,'( 5x, a, 2i8 / )' ) 'dust hit count, out of total cells:', - & dusthit, (c-1)*(r-1) -#endif - - if ( dustem_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. - - wstep = wstep + time2sec( tstep( 2 ) ) - - if ( wstep .ge. time2sec( tstep( 1 ) ) ) then - if ( .not. currstep( jdate, jtime, sdate, stime, tstep( 1 ), - & mdate, mtime ) ) then - xmsg = 'Cannot get step date and time' - call m3exit( pname, jdate, jtime, xmsg, xstat3 ) - end if - call nextime( mdate, mtime, tstep( 1 ) ) - -#ifdef verbose_wbdust - sdiagv = sdiagv / float( wstep ) ! array assignment - write( logdev,2015 ) jdate, jtime - do v = 1, ndust_diag - if ( diagnm( v )%var(1:4) .ne. 'ANUM' ) then - write( logdev,2019 ) v, diagnm( v )%var, sdiagv( v ) - else - write( logdev,2023 ) v, diagnm( v )%var, sdiagv( v ) - end if - end do - sdiagv = 0.0 ! array assignment -#endif - do v = 1, ndust_diag - do r = 1, my_nrows - do c = 1, my_ncols - wrbuf( c,r ) = dustbf( v,c,r ) / float( wstep ) - end do - end do - - if ( .not. WRITE3( ctm_dust_emis_1, diagnm( v )%var, - & mdate, mtime, wrbuf ) ) then - xmsg = 'Could not write ' // trim( diagnm( v )%var ) - & // ' to CTM_DUST_EMIS_1' - call m3exit( pname, mdate, mtime, xmsg, xstat1 ) - end if - end do - write( logdev,'( /5x, 2( a, 1x ), i8, ":", i6.6 )' ) - & 'Timestep written to CTM_DUST_EMIS_1', - & 'for date and time', mdate, mtime - wstep = 0 - dustbf = 0.0 ! array assignment - end if ! time to write - end if ! dustem_diag - -2009 Format( '*** Erodible landuse incorrect ', 1pe13.5, 1x, 'at: ', 3i4 ) -2015 format( /5x, 'Total grid time-avg sum of dust emis variables at:', - & 1x, i8, ":", I6.6 ) -2019 format( i10, 1x, a, f20.5 ) -2023 format( i10, 1x, a, e20.3 ) - - end subroutine get_dust_emis - -C======================================================================= - 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 fmoit( c,r ), -C fruf( c,r,m ), -C ustr( c,r,m ), -C sd_ep( c,r ), -C dens( c,r ) ) - - implicit none - - include SUBST_CONST ! for grav - - integer, intent( in ) :: ndp - real, intent( in ) :: dp( ndp ) - real, intent( in ) :: soiltxt( ndp ) - real, intent( in ) :: fmoit, fruf, ustr, sd_ep, dens - real hflux - - real, parameter :: amen = 1.0 ! Marticorena and Bergametti [JGR,1997] - real, parameter :: cfac = 1000.0 * amen / grav - real, parameter :: A = 260.60061 ! 0.0123 * 2650.0 * 9.81 / 1.227 - real, parameter :: B = 1.6540342e-06 ! 0.0123 * 0.000165 / 1.227 - real utstar ! threshold U* [m/s] - real utem ! U term [(m/s)**3] - real fac - integer n - -! I can't initialize dp this way - it has to be passed in since ndp is variable - -C---Mean mass median diameter (m) for each soil texture -C [Chatenet et al., Sedimentology 1996 and Menut et al., JGR 2013] -! real :: dp( ndp ) = -! & (/ 690.0E-6, ! Coarse sand -! & 210.0E-6, ! Fine-medium sand -! & 125.0E-6, ! Silt -! & 2.0E-6 /) ! Clay - - fac = cfac * dens * sd_ep - utem = 0.0 - utstar = 0.0 - hflux = 0.0 - do n = 1, ndp ! loop over dust particle size -! utstar = sqrt( 0.0123 * ( 2650.0 * 9.81 * dp( n ) / 1.227 + 0.000165 -! / 1.227 / dp( n ) ) ) ! X roughness & moisture effects - utstar = sqrt( A * dp( n ) + B / dp( n ) ) * fmoit * fruf !Shao and Lu [JGR,2000] - if ( ustr .gt. utstar ) then ! wind erosion occurs only if U* > U*t -C---Horiz. Flux from White (1979) - utem = ( ustr + utstar ) * ( ustr * ustr - utstar * utstar ) -C---Horiz. Flux from Owen (1964) -! utem = ustr * ( ustr * ustr - utstar * utstar ) - hflux = hflux - & + fac * utem * soiltxt( n ) ! [g/m/s] - end if - end do ! dust particle size - - end function dust_hflux - -C============================================================================== - function dust_volumetric_to_gravimetric(vsoilm,clay,sand) - & result ( gwc ) -C usage: H = dust_volumetric_to_gravimetric(vsoilm(c,r), -C clay(c,r), -C sand(c,r)) - - implicit none - ! INPUTS - real, intent(in) :: vsoilm ! volumetric soil moisture - real, intent(in) :: clay ! clay fraction (0 -> 1) - real, intent(in) :: sand ! sand fraction (0 -> 1) - ! OUTPUTS - real :: H - ! LOCAL - real :: gwc ! gravimetric soil moisture - real :: bulk_dens_dry ! bulk density - real :: limit ! fecan soil moisture limit - real :: wsat ! saturated volumentric water content - real :: mpot ! saturated soil matric potential - - ! parameters - real*8, parameter :: bulk_dens = 2650.0d0 - real*8, parameter :: h20_dens = 1000.0d0 - - ! saturated soil matric potential [ mm H2O ] - mpot = 10.d0 * (10.0d0 ** (1.88d0 - 0.0131d0 * sand )) - - ! saturated volumentric water content [ m3 m-3 ] - wsat = 0.489d0 - 0.00126d0 * sand - - ! Bulk density of dry surface soil [kg m-3] - bulk_dens_dry = bulk_dens * ( 1.0d0 - wsat) - - ! Gravimetric water content [ kg kg-1] - gwc = VSOILM * h20_dens / bulk_dens_dry - if (gwc.ge.1.0e10) then - gwc = 0.d0 - endif - - end function dust_volumetric_to_gravimetric - -C======================================================================= - function dust_hflux_fengsha( ustar, fmoit, drag, uthr, ssm, dens ) - & result( hflux ) - -C hflux = dust_hflux( Met_Data%ustar( c,r), -C & fmoit( c,r ), -C & drag( c,r ), -C & uthr( c,r ), -C & ssm( c,r ), -C & Met_Data%dens1( c,r ) ) - - implicit none - - include SUBST_CONST ! for grav - - 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 - u_thresh = uthr * fmoit - u_sum = rustar * u_thresh - - - hflux = max(0., rustar - u_thresh) * u_sum * u_sum * fac * ssm - - end function dust_hflux_fengsha - - end module dust_emis - diff --git a/src/model/src/centralized_io_util_module.F b/src/model/src/centralized_io_util_module.F deleted file mode 100644 index f5b0653..0000000 --- a/src/model/src/centralized_io_util_module.F +++ /dev/null @@ -1,282 +0,0 @@ - -!------------------------------------------------------------------------! -! 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 -!------------------------------------------------------------------------! - - module centralized_io_util_module - - implicit none - - interface quicksort - module procedure quicksort1d, - & quicksort2d - end interface - - contains - -! ------------------------------------------------------------------------- - 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 - -!-------------------------------------------------------------------------- - - 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 From ce3e309f47d44a22f76a0b21b968e74524abde66 Mon Sep 17 00:00:00 2001 From: Youhua Tang Date: Fri, 12 Aug 2022 17:22:22 +0000 Subject: [PATCH 39/90] initialize feature/pt-source --- src/model/src/PT3D_DEFN.F | 487 +++++++++++++++++++++++++++++++++++--- src/shr/aqm_methods.F90 | 6 + 2 files changed, 463 insertions(+), 30 deletions(-) diff --git a/src/model/src/PT3D_DEFN.F b/src/model/src/PT3D_DEFN.F index 64e90fc..3759b4c 100644 --- a/src/model/src/PT3D_DEFN.F +++ b/src/model/src/PT3D_DEFN.F @@ -1,5 +1,8 @@ MODULE PT3D_DEFN - + + USE NETCDF + USE ASX_DATA_MOD, ONLY: MET_DATA, GRID_DATA + IMPLICIT NONE LOGICAL, SAVE :: PT3DEMIS ! flag in-lining plume rise @@ -99,7 +102,7 @@ FUNCTION PT3D_INIT ( N_SPC_EMIS, EMLAYS, JDATE, JTIME, TSTEP ) RETURN END IF -C check if emissions are being provided +C check if fire emissions are being provided EM => AQM_EMIS_GET( ETYPE ) IF ( .NOT.ASSOCIATED( EM ) ) RETURN @@ -115,14 +118,8 @@ FUNCTION PT3D_INIT ( N_SPC_EMIS, EMLAYS, JDATE, JTIME, TSTEP ) C set number of emissions layers depending on whether plumerise is on - SELECT CASE ( TRIM( EM % PLUMERISE ) ) - CASE ("sofiev") - EMLYRS = NLAYS - PM_EMLYRS = NLAYS - CASE DEFAULT - EMLYRS = 1 - PM_EMLYRS = 1 - END SELECT + EMLYRS = NLAYS + PM_EMLYRS = NLAYS C get point source emission mapping @@ -172,18 +169,22 @@ SUBROUTINE GET_PT3D_EMIS ( JDATE, JTIME, TSTEP ) USE AQM_EMIS_MOD USE AQM_FIRES_MOD USE AQM_RC_MOD - USE RXNS_DATA, ONLY : MECHNAME !Get Chemical Mechanism Name +c use aqm_model_mod, only : aqm_config_type, aqm_state_type, +c & aqm_model_get, aqm_model_domain_get + + 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 AERO_DATA, ONLY : N_EMIS_PM, PMEM_MAP_NAME USE PTMAP ! defines pt src species mapping to VDEMIS* arrays USE UTILIO_DEFN + IMPLICIT NONE C Includes: -C INCLUDE SUBST_CONST ! physical and mathematical constants -C INCLUDE SUBST_FILES_ID ! file name parameters (for CTM_PT3D_DIAG) + INCLUDE SUBST_CONST ! physical and mathematical constants + INCLUDE SUBST_FILES_ID ! file name parameters (for CTM_PT3D_DIAG) C Arguments: INTEGER, INTENT( IN ) :: JDATE, JTIME @@ -200,22 +201,419 @@ SUBROUTINE GET_PT3D_EMIS ( JDATE, JTIME, TSTEP ) INTEGER IOS ! i/o and allocate memory status INTEGER L, S, V ! counters - INTEGER C, R, K, N + INTEGER C, R, K, N, I, J INTEGER LOCALRC LOGICAL :: IS_NOT_NVPOA, SAVE_POC LOGICAL, SAVE :: FIRSTIME = .TRUE. INTEGER, SAVE :: LOGDEV - TYPE( AQM_INTERNAL_EMIS_TYPE ), POINTER :: EM - -C----------------------------------------------------------------------- - + + REAL TSTK ! temperature at top of stack [K] + REAL TSUM ! tmp layer frac sum for renormalizing + REAL WSTK ! wind speed at top of stack [m/s] + REAL ZBOT ! plume bottom elevation [m] + REAL ZTOP ! plume top elevation [m] + REAL ZDIFF ! ZTOP - ZBOT + REAL DDZ ! 1 / ZDIFF + REAL ZPLM ! plume centerline height above stack [m] + REAL USTMP ! temp storage for ustar [m/s] + REAL HFLX ! converted heat flux + 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 + REAL LFRC ! intermediate LFRAC + character(len=NF90_MAX_NAME) :: path_in + + real zf0,zf1,mxzplm + integer, save :: ntimes,itstep,ncid,iddim_stack,nstack,idvar,nvars,idlists(200), + & id_em_gc(200),id_em_pm(200),indx_gc(200),indx_pm(200), nvars_gc,nvars_pm,ndims, + & elemStart(2),elemCount(2),jstartdate,jstarttime + + real,save :: distnear ! search distrance in km, sqrt(0.5)*model_resolution in km + integer, save, allocatable, dimension (:) :: ixt, jyt + real, save, allocatable, dimension (:) :: tlat,tlon,stkdm,stkht,tfrac, + & stktk,stkve,stkflw,stk_ddzf,stk_pres,stk_dens,stk_qv,stk_ta,stk_wspd,stk_zf,stk_zh,stk_zstk, + & stk_presf,stk_zzf,stk_dthdz,stk_uwind,stk_vwind + real, save, allocatable, dimension (:,:) :: stkemis, my_area + real, save, allocatable, dimension (:,:,:) :: uwind,vwind +c type(aqm_config_type), pointer :: config + + INTERFACE + SUBROUTINE PREPLM( FIREFLG, EMLAYS, HMIX, HTS, PSFC, TS, DDZF, QV, + & TA, UW, VW, ZH, ZF, PRES, LSTK, LPBL, TSTK, + & WSTK, DTHDZ, WSPD ) + LOGICAL, INTENT( IN ) :: FIREFLG ! .true. => processing fire source + INTEGER, INTENT( IN ) :: EMLAYS ! no. emissions layers + REAL, INTENT( IN ) :: HMIX ! mixing height + REAL, INTENT( IN ) :: HTS ! stack height + REAL, INTENT( IN ) :: PSFC ! surface pressure + REAL, INTENT( IN ) :: TS ! surface temperature + REAL, INTENT( IN ) :: DDZF( : ) ! 1/( zf(l) - zf(l-1) ) + REAL, INTENT( IN ) :: QV ( : ) ! mixing ratio + REAL, INTENT( IN ) :: TA ( : ) ! absolute temperature + REAL, INTENT( IN ) :: UW ( : ) ! x-direction winds + REAL, INTENT( IN ) :: VW ( : ) ! y-direction winds + REAL, INTENT( IN ) :: ZH ( : ) ! layer center height [m] + REAL, INTENT( IN ) :: ZF ( : ) ! layer surface height [m] + REAL, INTENT( IN ) :: PRES( 0: ) ! pres at full layer hts (mod by YOJ) + INTEGER, INTENT( OUT ) :: LSTK ! first L: ZF(L) > STKHT + INTEGER, INTENT( OUT ) :: LPBL ! first L: ZF(L) > mixing layer + REAL, INTENT( OUT ) :: TSTK ! temperature @ top of stack [K] + REAL, INTENT( OUT ) :: WSTK ! wind speed @ top of stack [m/s] + REAL, INTENT( OUT ) :: DTHDZ( : ) ! potential temp. grad. + REAL, INTENT( OUT ) :: WSPD ( : ) ! wind speed [m/s] + END SUBROUTINE PREPLM + + SUBROUTINE PLMRIS( EMLAYS, LSTK, HFX, HMIX, + & STKDM, STKHT, STKTK, STKVE, + & TSTK, USTAR, DTHDZ, TA, WSPD, + & ZF, ZH, ZSTK, WSTK, ZPLM ) + INTEGER, INTENT( IN ) :: EMLAYS ! no. of emission layers + INTEGER, INTENT( IN ) :: LSTK ! lyr of top of stack, = RADM's KSTK + REAL, INTENT( IN ) :: HFX ! sensible heat flux [m K/s] + REAL, INTENT( IN ) :: HMIX ! mixing height [m] + REAL, INTENT( IN ) :: STKDM ! stack diameter [m] + REAL, INTENT( IN ) :: STKHT ! stack height [m] + REAL, INTENT( IN ) :: STKTK ! exhaust temperature [deg K] + REAL, INTENT( IN ) :: STKVE ! exhaust velocity [m/s] + REAL, INTENT( IN ) :: TSTK ! tmptr at top of stack [deg K] + REAL, INTENT( IN ) :: USTAR ! friction velocity [m/s] + REAL, INTENT( IN ) :: DTHDZ( : ) ! gradient of THETV + REAL, INTENT( IN ) :: TA ( : ) ! temperature [deg K] + REAL, INTENT( IN ) :: WSPD ( : ) ! wind speed [m/s] + REAL, INTENT( IN ) :: ZF ( 0: ) ! layer surface height [m] + REAL, INTENT( IN ) :: ZH ( : ) ! layer center height [m] + REAL, INTENT( IN ) :: ZSTK ( : ) ! zf( l ) - stkht [m] + REAL, INTENT( INOUT ) :: WSTK ! wind speed @ top of stack [m/s] + REAL, INTENT( OUT ) :: ZPLM ! OUT for reporting, only + END SUBROUTINE PLMRIS ! temporarily, plume top height + END INTERFACE ! above stack, finally plume centerline +C----------------------------------------------------! height [m] (can be greater than the ------------------- + ! height of the top of the EMLAYS layer) IF ( FIRSTIME ) THEN FIRSTIME = .FALSE. LOGDEV = SETUP_LOGDEV() - END IF + + L=nf90_open('NEXUS/PT.nc',nf90_nowrite, ncid) + if(L.ne.nf90_noerr) then + write(logdev,*)'error openning NEXUS/PT.nc' + stop + endif + call check(nf90_inq_dimid(ncid,'nlocs',iddim_stack)) + call check(nf90_inquire_dimension(ncid,iddim_stack,len=nstack)) + allocate(tlat(nstack),tlon(nstack),ixt(nstack),jyt(nstack),stkdm(nstack),stkht(nstack), + & stktk(nstack),stkve(nstack),stkflw(nstack)) + + call check(nf90_inq_varid(ncid,'LATITUDE',idvar)) + call check(nf90_get_var(ncid,idvar,tlat)) + call check(nf90_inq_varid(ncid,'LONGITUDE',idvar)) + call check(nf90_get_var(ncid,idvar,tlon)) + call check(nf90_inq_varid(ncid,'STKDM',idvar)) + call check(nf90_get_var(ncid,idvar,stkdm)) + call check(nf90_inq_varid(ncid,'STKHT',idvar)) + call check(nf90_get_var(ncid,idvar,stkht)) + call check(nf90_inq_varid(ncid,'STKTK',idvar)) + call check(nf90_get_var(ncid,idvar,stktk)) + call check(nf90_inq_varid(ncid,'STKVE',idvar)) + call check(nf90_get_var(ncid,idvar,stkve)) + call check(nf90_inq_varid(ncid,'STKFLW',idvar)) + call check(nf90_get_var(ncid,idvar,stkflw)) + + distnear=0.7071*haversine(grid_data%lat(1,1),grid_data%lon(1,1),grid_data%lat(2,1),grid_data%lon(2,1)) + do n=1,nstack + search_loop: do r = 1, my_nrows + do c = 1, my_ncols + if(haversine(grid_data%lat(c,r),grid_data%lon(c,r),tlat(n),tlon(n)).le.distnear) exit search_loop + enddo + enddo search_loop + if(c.le.my_ncols.and.r.le.my_nrows) then + ixt(n)=c; jyt(n)=r + else + ixt(n)=-999; jyt(n)=-999 + endif + enddo + + call check(nf90_inq_varids(ncid,nvars,idlists)) + + nvars_gc=0 + nvars_pm=0 + do n=1,nvars + call check(nf90_inquire_variable(ncid,idlists(n),vname,ndims=ndims)) + L=index1(vname,n_gc_emis, gc_emis) + if (L > 0) then + + if(ndims.ne.2) then + write(logdev,*)'ndims wrong',ndims,vname + stop + endif + if( PTEM_MAP( L ) .gt.0) then + nvars_gc=nvars_gc+1 + id_em_gc(nvars_gc)=idlists(n) + indx_gc(nvars_gc)=PTEM_MAP( L ) + endif + + else ! aerosol + L=index1(vname,n_emis_pm, pmem_map_name) ! index in pt em + if (L > 0) then + if(ndims.ne.2) then + write(logdev,*)'ndims wrong',ndims,vname + stop + endif + do S=1, N_SPC_PTPM + if(PTPM_MAP(S).eq.L) exit + enddo + if (S. le. N_SPC_PTPM ) then + nvars_pm=nvars_pm+1 + id_em_pm(nvars_pm)=idlists(n) + indx_pm(nvars_pm)=S + endif + endif + endif + enddo + + write(logdev,*)'Point Sources nvars_gc, nvars_pm=',nvars_gc, nvars_pm + write(logdev,*)'ncols,nrows,my_ncols,my_nrows=',ncols,nrows,my_ncols,my_nrows + allocate(my_area(my_ncols,my_nrows)) + if(.not.interpx(GRID_CRO_2D,'AREA','emis',1,my_ncols,1,my_nrows,1,1,jdate,jtime,my_area)) stop + + allocate(stkemis(nstack,nvars_gc+nvars_pm),uwind(my_ncols,my_nrows,emlyrs), vwind(my_ncols,my_nrows,emlyrs), + & stk_ddzf(emlyrs),stk_pres(emlyrs),stk_dens(emlyrs),stk_qv(emlyrs),stk_ta(emlyrs),stk_wspd(emlyrs),stk_zf(emlyrs), + & stk_zh(emlyrs),stk_zstk(emlyrs),stk_dthdz(emlyrs),stk_uwind(emlyrs),stk_vwind(emlyrs),tfrac(emlyrs), + & stk_presf(0:emlyrs),stk_zzf(0:emlyrs)) + + jstartdate=jdate + jstarttime=jtime + END IF + +C ... initialize emission arrays ... + + VDEMIS_PT = 0.0 ! array assignment + VDEMIS_PT_FIRE = 0.0 ! array assignment + PMEMIS_PT = 0.0 ! array assignment + + +C--- anthropogenic point sources + + itstep=secsdiff(jstartdate,jstarttime,jdate,jtime)/3600+1 + write(logdev,*)'process PT emission ',jdate,jtime,tstep(1),itstep + n=nf90_inq_path(ncid,L,path_in) + if(n.ne.nf90_noerr.or.trim(path_in).ne.'NEXUS/PT.nc') then + write(logdev,*)itstep,'ncid wrong, reopen it ',trim(nf90_strerror(n)) + L=nf90_close(ncid) + call check(nf90_open('NEXUS/PT.nc',nf90_nowrite, ncid)) + endif + + elemStart(1)=1; elemStart(2)=itstep + elemCount(1)=nstack; elemCount(2)=1 + do v=1,nvars_gc +c write(logdev,*)'read PT emission of gas ',v,itstep + L=nf90_get_var(ncid,id_em_gc(v),stkemis(:,v),start=elemStart,count=elemCount) + if(L.ne.nf90_noerr) then + write(logdev,*)trim(nf90_strerror(L)),' error reading PT emission of gas ',v,itstep,nstack,id_em_gc(v) + S=nf90_get_var(ncid,id_em_gc(v),stkemis(:,v),start=[1,1],count=elemCount) + if(S.ne.nf90_noerr) then + write(logdev,*)'also error 1-step reading PT emission of gas ',v,trim(nf90_strerror(S)),id_em_gc(v) + else + write(logdev,*)'OK for 1-step reading PT emission of gas ',v,trim(nf90_strerror(S)),id_em_gc(v) + endif + stop + endif + enddo + + do v=1,nvars_pm +c write(logdev,*)'read PT emission of PM ',v + L=nf90_get_var(ncid,id_em_pm(v),stkemis(:,v+nvars_gc),start=elemStart,count=elemCount) + if(L.ne.nf90_noerr) then + write(logdev,*)'error reading PT emission of pm ',v,itstep,nstack,id_em_pm(v) + stop + endif + enddo +c call check(nf90_close(ncid)) + + if(.not.interpx(MET_CRO_3D,'UWINDA','PT3D_DEFN',1,my_ncols,1,my_nrows,1,emlyrs,jdate,jtime,uwind)) stop + if(.not.interpx(MET_CRO_3D,'VWINDA','PT3D_DEFN',1,my_ncols,1,my_nrows,1,emlyrs,jdate,jtime,vwind)) stop + + mxzplm=0.0 + + do n=1,nstack + if(ixt(n).lt.1.or.jyt(n).lt.1) cycle + c=ixt(n) + r=jyt(n) + + stk_zf(1:emlyrs)=met_data%zf(c,r,1:emlyrs) + stk_zh(1:emlyrs)=met_data%zh(c,r,1:emlyrs) + stk_zzf(1:emlyrs)=stk_zf(1:emlyrs) + stk_zzf(0)=0. + +c-----calculate ddzf + zf0=stk_zf(1) + stk_ddzf(1)=1./zf0 + stk_zstk(1)=zf0-stkht(n) + do L=2,emlyrs + zf1=stk_zf(L) + stk_zstk(L)=zf1-stkht(n) + stk_ddzf(L)=1./(zf1-zf0) + zf0=zf1 + enddo + + stk_ta(1:emlyrs)=met_data%ta(c,r,1:emlyrs) + stk_qv(1:emlyrs)=met_data%qv(c,r,1:emlyrs) + stk_uwind(1:emlyrs)=uwind(c,r,1:emlyrs) + stk_vwind(1:emlyrs)=vwind(c,r,1:emlyrs) + stk_presf(1:emlyrs)=met_data%pres(c,r,1:emlyrs) ! full level pressure + stk_presf(0)=met_data%prsfc(c,r) + +C Compute derived met vars needed before layer assignments + CALL PREPLM( .FALSE. , EMLYRS, + & Met_Data%PBL(C,R), STKHT(N), met_data%prsfc(c,r), + & Met_Data%TEMP2(C,R), stk_ddzf, + & stk_qv, stk_ta, + & stk_uwind, stk_vwind, + & stk_zh, stk_zf, + & stk_presf, LSTK, LPBL, TSTK, WSTK, + & stk_DTHDZ, stk_WSPD ) + +C Trap USTAR at a minimum realistic value + USTMP = MAX1( Met_Data%USTAR(C, R ), 0.1 ) + +C Convert heat flux (watts/m2 to m K /s ) + HFLX = Met_Data%HFX( C,R ) / ( 1004.7642148 * Met_Data%DENS( C,R,1 ) ) + + CALL PLMRIS( EMLYRS, LSTK, HFLX, Met_Data%PBL(C,R), + & STKDM(N), STKHT(N), + & STKTK(N), STKVE( N ), + & TSTK, USTMP, + & stk_DTHDZ, stk_TA, + & stk_WSPD, stk_ZZF, + & stk_ZH, stk_ZSTK, + & WSTK, ZPLM ) + + if ( zplm .gt. mxzplm ) mxzplm = zplm + +C Default Turner approach. Plume thickness = amount of plume rise +C Plume rise DH = ZPLM minus the stack height STKHT + ZTOP = STKHT( N ) + & + 1.5 * ( ZPLM - STKHT( N ) ) + ZBOT = STKHT( N ) + & + 0.5 * ( ZPLM - STKHT( N ) ) + +C Set up for computing plume fractions, assuming uniform distribution in pressure +C (~mass concentration -- minor hydrostatic assumption) from bottom to top. + + IF ( ZTOP .LT. STKHT( N ) ) THEN + WRITE( LOGDEV,94010 ) 'ERROR: Top of plume is less than ' + & // 'top of stack for source:', N + WRITE( LOGDEV,* ) ' Zbot: ', ZBOT, ' Ztop: ', ZTOP + WRITE( LOGDEV,* ) ' Stack Top: ', STKHT( N ), + & ' Plume Top: ', ZPLM + stop + END IF + +C Compute LBOT, LTOP such that +C ZZF( LBOT-1 ) <= ZBOT < ZZF( LBOT ) and +C ZZF( LTOP-1 ) <= ZTOP < ZZF( LTOP ) + + DO L = 1, EMLYRS - 1 + IF ( ZBOT .LE. STK_ZZF( L ) ) THEN + LBOT = L + GO TO 122 + ELSE + TFRAC( L ) = 0.0 ! fractions below plume + END IF + END DO + LBOT = EMLYRS ! fallback + +122 CONTINUE ! loop exit: bottom found at LBOT + + IF ( ZTOP .LE. stk_ZZF( LBOT ) ) THEN ! plume in this layer + + TFRAC( LBOT ) = 1.0 + LTOP = LBOT + + DO L = LBOT + 1, EMLYRS ! fractions above plume + TFRAC( L ) = 0.0 + END DO + + ELSE IF ( LBOT .EQ. EMLYRS ) THEN ! plume above top layer + + TFRAC( LBOT ) = 1.0 + + DO L = 1, EMLYRS - 1 ! fractions below plume + TFRAC( L ) = 0.0 + END DO + + ELSE ! plume crosses layers + + DO L = LBOT + 1, EMLYRS + IF ( ZTOP .LE. STK_ZZF( L ) ) THEN + LTOP = L + GO TO 126 + END IF + END DO + LTOP = EMLYRS ! fallback + +126 CONTINUE + + ZDIFF = ZTOP - ZBOT + IF ( ZDIFF .GT. 0.0 ) THEN + DDZ = 1.0 / ZDIFF + TFRAC( LBOT ) = DDZ * ( stk_ZZF( LBOT ) - ZBOT ) + TFRAC( LTOP ) = DDZ * ( ZTOP - stk_ZZF( LTOP-1 ) ) + + ELSE ! ZDIFF .le. 0 + WRITE(logdev,* ) + & 'Infinitely small plume created for source:,' + & ,N,'All emissions put in first layer.' + LBOT = 1; LTOP = 1 + TFRAC( LBOT ) = 1.0 + END IF + + DO L = LBOT + 1, LTOP - 1 ! layers in plume + TFRAC( L ) = DDZ * ( stk_ZZF( L ) - stk_ZZF( L-1 ) ) + END DO + + DO L = LTOP + 1, EMLYRS ! fractions above plume + TFRAC( L ) = 0.0 + END DO + + END IF + +C If layer fractions are negative, put in the first layer + + IF ( MINVAL( TFRAC( 1:EMLYRS ) ) .LT. 0.0 ) THEN + WRITE( logdev,* ) 'WARNING: One or more negative plume ' + & // 'fractions found for source:' , N, 'Plume reset to ' + & // 'put all emissions in surface layer.' + TFRAC( 1 ) = 1.0 + TFRAC( 2:EMLYRS ) = 0.0 + END IF + +C Apportion emissions to the layers + + DO L = 1, EMLYRS + LFRC = TFRAC( L ) + IF ( LFRC .LE. 0.0 ) CYCLE + + DO V = 1, nvars_gc + I = indx_gc( V ) + VDEMIS_PT( C,R,L,I ) = VDEMIS_PT( C,R,L,I ) + LFRC * STKEM( J ) + & + LFRC * stkemis(n,V)/my_area (c,r) + END DO + DO V = 1, nvars_pm + I = indx_pm( V ) + PMEMIS_PT( C,R,L,I ) = PMEMIS_PT( C,R,L,I ) + & + LFRC * stkemis(n,V+nvars_gc)/my_area (c,r) ! emis fac applied in AERO_EMIS + END DO + + END DO + + + enddo ! end loop of nstack + +c-----FIRE emissions EM => AQM_EMIS_GET( ETYPE ) IF ( .NOT.ASSOCIATED( EM ) ) RETURN @@ -227,11 +625,6 @@ SUBROUTINE GET_PT3D_EMIS ( JDATE, JTIME, TSTEP ) WRITE( LOGDEV,* ) ' ' CALL M3MSG2( XMSG ) -C ... initialize emission arrays ... - - VDEMIS_PT = 0.0 ! array assignment - VDEMIS_PT_FIRE = 0.0 ! array assignment - PMEMIS_PT = 0.0 ! array assignment C ... initialize vertical fraction arrays ... C ... fire emissions are added to surface only by default ... @@ -296,7 +689,7 @@ SUBROUTINE GET_PT3D_EMIS ( JDATE, JTIME, TSTEP ) DO R = 1, MY_NROWS DO C = 1, MY_NCOLS K = K + 1 - VDEMIS_PT( C,R,L,N ) = VFRAC( C,R,L ) * BUFFER( K ) + VDEMIS_PT( C,R,L,N ) = VDEMIS_PT( C,R,L,N )+ VFRAC( C,R,L ) * BUFFER( K ) END DO END DO END DO @@ -306,7 +699,7 @@ SUBROUTINE GET_PT3D_EMIS ( JDATE, JTIME, TSTEP ) 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 ) + VDEMIS_PT_FIRE( C,R,L,N ) = VFRAC( C,R,L ) * BUFFER( K ) END DO END DO END DO @@ -316,8 +709,8 @@ SUBROUTINE GET_PT3D_EMIS ( JDATE, JTIME, TSTEP ) C ... aerosol species ... - DO S = 1, N_SPC_PTPM - V = PTPM_MAP( S ) + DO S = 1, N_SPC_PTPM ! FIRE inventory index of aerosol + V = PTPM_MAP( S ) ! index in aerosol emission holder BUFFER = 0.0 CALL AQM_EMIS_READ( ETYPE, PMEM_MAP_NAME( V ), BUFFER, RC=LOCALRC ) IF ( AQM_RC_CHECK( LOCALRC, MSG="Failure while reading " // @@ -328,14 +721,48 @@ SUBROUTINE GET_PT3D_EMIS ( JDATE, JTIME, TSTEP ) DO R = 1, MY_NROWS DO C = 1, MY_NCOLS K = K + 1 - PMEMIS_PT( C,R,L,S ) = VFRAC( C,R,L ) * BUFFER( K ) + PMEMIS_PT( C,R,L,S ) = PMEMIS_PT( C,R,L,S ) + VFRAC( C,R,L ) * BUFFER( K ) END DO END DO END DO END DO + +94010 FORMAT( 12( A, :, I8, :, 1X ) ) RETURN END SUBROUTINE GET_PT3D_EMIS + + function to_radian(degree) result(rad) + ! degrees to radians + real,intent(in) :: degree + real, parameter :: deg_to_rad = atan(1.0)/45 ! exploit intrinsic atan to generate pi/180 runtime constant + real :: rad + + rad = degree*deg_to_rad + end function to_radian + + function haversine(deglat1,deglon1,deglat2,deglon2) result (dist) + real,intent(in) :: deglat1,deglon1,deglat2,deglon2 + real :: a,c,dist,dlat,dlon,lat1,lat2 + real,parameter :: radius = 6372.8 ! in km + + dlat = to_radian(deglat2-deglat1) + dlon = to_radian(deglon2-deglon1) + lat1 = to_radian(deglat1) + lat2 = to_radian(deglat2) + a = (sin(dlat/2))**2 + cos(lat1)*cos(lat2)*(sin(dlon/2))**2 + c = 2*asin(sqrt(a)) + dist = radius*c + end function haversine + + subroutine check(status) + integer, intent ( in) :: status + + if(status /= nf90_noerr) then + print *, 'netcdf error in PT3D_DEFN.F ', trim(nf90_strerror(status)) + stop "Stopped" + end if + end subroutine check END MODULE PT3D_DEFN diff --git a/src/shr/aqm_methods.F90 b/src/shr/aqm_methods.F90 index f4c4a8f..c660cf5 100644 --- a/src/shr/aqm_methods.F90 +++ b/src/shr/aqm_methods.F90 @@ -604,6 +604,8 @@ logical function interpx( fname, vname, pname, & select case (trim(vname)) case ('HT') p2d => stateIn % ht + case ('AREA') + p2d => stateIN % area case ('LAT') p2d => lat case ('LON') @@ -825,6 +827,10 @@ logical function interpx( fname, vname, pname, & end do end do end do + case ("UWINDA") + p3d => stateIn % uwind + case ("VWINDA") + p3d => stateIn % vwind case ("PRES") p3d => stateIn % prl case ("CFRAC_3D") From 203035553bff8fb84fca1966168134b951093b68 Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Thu, 25 Aug 2022 21:01:06 +0000 Subject: [PATCH 40/90] Testing Sub-Canopy phot effects only. --- src/model/src/phot.F | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/model/src/phot.F b/src/model/src/phot.F index 86ad888..655f965 100644 --- a/src/model/src/phot.F +++ b/src/model/src/phot.F @@ -1052,8 +1052,8 @@ END SUBROUTINE O3TOTCOL !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 +! 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 From 10b9b484353ac9d9e679ec4e1362a3308b90452d Mon Sep 17 00:00:00 2001 From: Raffaele Montuoro Date: Wed, 14 Sep 2022 20:02:42 +0000 Subject: [PATCH 41/90] Enable CMAQ simplistic scavenging and wet removal in resolved clouds. --- CMakeLists.txt | 2 ++ aqm_files.cmake | 5 +++++ src/drv/cmaq_mod.F90 | 7 +++++++ src/shr/aqm_methods.F90 | 27 +++++++++++++++++++++++++++ 4 files changed, 41 insertions(+) diff --git a/CMakeLists.txt b/CMakeLists.txt index 5fe78d8..b2a51ea 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -86,6 +86,8 @@ target_compile_definitions(CCTM PUBLIC SUBST_FILES_ID="FILES_CTM.EXT" SUBST_COMM=NOOP_COMM SUBST_BARRIER=NOOP_BARRIER SUBST_SUBGRID_INDEX=NOOP_SUBGRID_INDEX + AQ_MAP=DUMMY_AQ_MAP + CONVCLD_ACM=DUMMY_CONVCLD_ACM EDDYX=DUMMY_EDDYX MOSAIC_MOD=MOSAIC_MODULE Mosaic_Mod=Mosaic_Module diff --git a/aqm_files.cmake b/aqm_files.cmake index c3f7420..d4d5143 100644 --- a/aqm_files.cmake +++ b/aqm_files.cmake @@ -114,6 +114,11 @@ list(APPEND aqm_CCTM_files ${BIOG}/tmpbeis.F ${BIOG}/wrdaymsg.f ${CLOUD}/hlconst.F + ${CLOUD}/cldproc_acm.F + ${CLOUD}/getalpha.F + ${CLOUD}/indexn.f + ${CLOUD}/rescld.F + ${CLOUD}/scavwdep.F ${DEPV}/ABFLUX_MOD.F ${DEPV}/BIDI_MOD.F ${DEPV}/cgrid_depv.F diff --git a/src/drv/cmaq_mod.F90 b/src/drv/cmaq_mod.F90 index 8840434..9889e92 100644 --- a/src/drv/cmaq_mod.F90 +++ b/src/drv/cmaq_mod.F90 @@ -131,6 +131,11 @@ SUBROUTINE VDIFF ( CGRID, JDATE, JTIME, TSTEP ) INTEGER :: JDATE, JTIME INTEGER :: TSTEP( 3 ) END SUBROUTINE VDIFF + SUBROUTINE CLDPROC ( CGRID, JDATE, JTIME, TSTEP ) + REAL, POINTER :: CGRID( :,:,:,: ) + INTEGER, INTENT( IN ) :: JDATE, JTIME + INTEGER, INTENT( IN ) :: TSTEP( 3 ) + END SUBROUTINE CLDPROC SUBROUTINE CHEM ( CGRID, JDATE, JTIME, TSTEP ) REAL, POINTER :: CGRID( :,:,:,: ) INTEGER :: JDATE, JTIME @@ -151,6 +156,8 @@ END SUBROUTINE AERO CALL CHEM ( CGRID, JDATE, JTIME, TSTEP ) + CALL CLDPROC ( CGRID, JDATE, JTIME, TSTEP ) + if (run_aero) then CALL AERO ( CGRID, JDATE, JTIME, TSTEP ) end if diff --git a/src/shr/aqm_methods.F90 b/src/shr/aqm_methods.F90 index f4c4a8f..98f0e7f 100644 --- a/src/shr/aqm_methods.F90 +++ b/src/shr/aqm_methods.F90 @@ -1200,6 +1200,33 @@ END FUNCTION WRITE3_REAL4D ! -- dummy subroutines +SUBROUTINE DUMMY_AQ_MAP( JDATE, JTIME, WTBAR, WCBAR, TBARC, PBARC, & + CTHK1, AIRM, PRATE1, TAUCLD, POLC, CEND, & + REMOV, REMOVAC, ALFA0, ALFA2, ALFA3, DARK ) + INTEGER, INTENT( IN ) :: JDATE, JTIME + REAL, INTENT( IN ) :: WTBAR, WCBAR, TBARC, PBARC, & + CTHK1, AIRM, PRATE1, TAUCLD + REAL, INTENT( IN ) :: POLC ( : ) + REAL, INTENT( INOUT ) :: REMOVAC + REAL, INTENT( INOUT ) :: CEND( : ), REMOV( : ) + REAL, INTENT( IN ) :: ALFA0, ALFA2, ALFA3 + LOGICAL, INTENT( IN ) :: DARK +END SUBROUTINE DUMMY_AQ_MAP + +SUBROUTINE DUMMY_CONVCLD_ACM ( CGRID, JDATE, JTIME, TSTEP, & + N_SPC_WDEP, WDEP_MAP, CONV_DEP, SUBTRANS ) + REAL, POINTER :: CGRID( :,:,:,: ) + INTEGER, INTENT( IN ) :: JDATE + INTEGER, INTENT( IN ) :: JTIME + INTEGER, INTENT( IN ) :: TSTEP( 3 ) + INTEGER, INTENT( IN ) :: N_SPC_WDEP + INTEGER, INTENT( IN ) :: WDEP_MAP( : ) + REAL, INTENT( INOUT ) :: CONV_DEP( :,:,: ) + REAL, INTENT( OUT ) :: SUBTRANS( :,:,: ) + CONV_DEP = 0.0 + SUBTRANS = 0.0 +END SUBROUTINE DUMMY_CONVCLD_ACM + SUBROUTINE DUMMY_EDDYX ( EDDYV ) REAL, INTENT( OUT ) :: EDDYV ( :,:,: ) EDDYV = 0.0 From 9d67b9922db45e6ec5e1f8034fc8741db2a94f92 Mon Sep 17 00:00:00 2001 From: Raffaele Montuoro Date: Wed, 14 Sep 2022 20:41:13 +0000 Subject: [PATCH 42/90] Fix naming inconsistency for convective and nonconvective precipitation fields. --- src/shr/aqm_methods.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/shr/aqm_methods.F90 b/src/shr/aqm_methods.F90 index 98f0e7f..b3d5e65 100644 --- a/src/shr/aqm_methods.F90 +++ b/src/shr/aqm_methods.F90 @@ -155,7 +155,7 @@ LOGICAL FUNCTION DESC3( FNAME ) 'ZRUF ', & 'HFX ', 'WSPD10 ', & 'GSW ', 'RGRND ', & - 'RNA ', 'RCA ', & + 'RN ', 'RC ', & 'CFRAC ', 'CLDT ', & 'CLDB ', 'WBAR ', & 'RA ', 'RS ', & From ca5bcbc7e3e87765cf8825628249216177843589 Mon Sep 17 00:00:00 2001 From: Raffaele Montuoro Date: Wed, 14 Sep 2022 20:47:40 +0000 Subject: [PATCH 43/90] Properly set compiler flags in GNU build system for fixed source form files. --- src/io/ioapi/Makefile.am | 2 +- src/io/ioapi/Makefile.in | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/io/ioapi/Makefile.am b/src/io/ioapi/Makefile.am index a708712..5676ec8 100644 --- a/src/io/ioapi/Makefile.am +++ b/src/io/ioapi/Makefile.am @@ -7,7 +7,7 @@ libioapi_a_SOURCES += crlf.F currec.f currstep.f dt2str.f findc.f getefile.F ind poly.f promptmfile.f sec2time.f secsdiff.F setlam.f sortic.f str2real.f time2sec.f upcase.f wkday.F yr2day.F libioapi_a_SOURCES += m3exit.F90 m3mesg.F90 m3msg2.F90 m3warn.F90 m3utilio.F90 -libioapi_a_FFLAGS = $(ESMF_F90COMPILEOPTS) $(ESMF_F90COMPILEPATHS) $(ESMF_F90COMPILEFREECPP) $(ESMF_F90COMPILECPPFLAGS) +libioapi_a_FFLAGS = $(CCTM_FFLAGS) $(ESMF_F90COMPILEOPTS) $(ESMF_F90COMPILEPATHS) $(ESMF_F90COMPILEFREECPP) $(ESMF_F90COMPILECPPFLAGS) libioapi_a_FCFLAGS = $(ESMF_F90COMPILEOPTS) $(ESMF_F90COMPILEPATHS) $(ESMF_F90COMPILEFREECPP) $(ESMF_F90COMPILECPPFLAGS) libioapi_a_FCFLAGS += -DSUBST_FILES_ID=\"FILES_CTM.EXT\" diff --git a/src/io/ioapi/Makefile.in b/src/io/ioapi/Makefile.in index 1401c36..6d52ee3 100644 --- a/src/io/ioapi/Makefile.in +++ b/src/io/ioapi/Makefile.in @@ -326,7 +326,7 @@ libioapi_a_SOURCES = FDESC3.EXT PARMS3.EXT crlf.F currec.f currstep.f \ setlam.f sortic.f str2real.f time2sec.f upcase.f wkday.F \ yr2day.F m3exit.F90 m3mesg.F90 m3msg2.F90 m3warn.F90 \ m3utilio.F90 -libioapi_a_FFLAGS = $(ESMF_F90COMPILEOPTS) $(ESMF_F90COMPILEPATHS) $(ESMF_F90COMPILEFREECPP) $(ESMF_F90COMPILECPPFLAGS) +libioapi_a_FFLAGS = $(CCTM_FFLAGS) $(ESMF_F90COMPILEOPTS) $(ESMF_F90COMPILEPATHS) $(ESMF_F90COMPILEFREECPP) $(ESMF_F90COMPILECPPFLAGS) libioapi_a_FCFLAGS = $(ESMF_F90COMPILEOPTS) $(ESMF_F90COMPILEPATHS) \ $(ESMF_F90COMPILEFREECPP) $(ESMF_F90COMPILECPPFLAGS) \ -DSUBST_FILES_ID=\"FILES_CTM.EXT\" -I \ From 1a083c880c3903966b4e801d4e68f9dd844f774a Mon Sep 17 00:00:00 2001 From: Youhua Tang Date: Tue, 20 Sep 2022 00:28:37 +0000 Subject: [PATCH 44/90] enable point source per DE --- src/aqm_cap.F90 | 3 +- src/model/src/PT3D_DEFN.F | 80 ++++++++++++++++++++++++++++----------- src/shr/aqm_rc_mod.F90 | 2 +- 3 files changed, 60 insertions(+), 25 deletions(-) diff --git a/src/aqm_cap.F90 b/src/aqm_cap.F90 index 5288d62..e97086a 100644 --- a/src/aqm_cap.F90 +++ b/src/aqm_cap.F90 @@ -378,12 +378,11 @@ subroutine DataInitialize(model, rc) return ! bail out end if - call ESMF_VMGet(vm, localPet=localPet, rc=rc) + call ESMF_VMGet(vm, localPet=mylocalPet, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, & file=__FILE__)) & return ! bail out - do localDe = 0, localDeCount-1 de = localDeToDeMap(localDe+1) + 1 tile = deToTileMap(de) diff --git a/src/model/src/PT3D_DEFN.F b/src/model/src/PT3D_DEFN.F index 3759b4c..f47352f 100644 --- a/src/model/src/PT3D_DEFN.F +++ b/src/model/src/PT3D_DEFN.F @@ -169,8 +169,8 @@ SUBROUTINE GET_PT3D_EMIS ( JDATE, JTIME, TSTEP ) USE AQM_EMIS_MOD USE AQM_FIRES_MOD USE AQM_RC_MOD -c use aqm_model_mod, only : aqm_config_type, aqm_state_type, -c & aqm_model_get, aqm_model_domain_get + use aqm_model_mod, only : aqm_config_type, aqm_state_type, + & aqm_model_get, aqm_model_domain_get USE RXNS_DATA, ONLY : MECHNAME !Get Chemical Mechanism Name USE GRID_CONF ! horizontal & vertical domain specifications @@ -178,7 +178,8 @@ SUBROUTINE GET_PT3D_EMIS ( JDATE, JTIME, TSTEP ) USE AERO_DATA, ONLY : N_EMIS_PM, PMEM_MAP_NAME USE PTMAP ! defines pt src species mapping to VDEMIS* arrays USE UTILIO_DEFN - + use esmf + use nuopc IMPLICIT NONE @@ -226,7 +227,11 @@ SUBROUTINE GET_PT3D_EMIS ( JDATE, JTIME, TSTEP ) INTEGER LSTK ! first L: ZF(L) > STKHT REAL LFRC ! intermediate LFRAC character(len=NF90_MAX_NAME) :: path_in - + + type(ESMF_VM) :: VM_ESMF + integer myrc, my_mpi_comm,my_ntasks, is, ie, js, je + character(200) :: aline + real zf0,zf1,mxzplm integer, save :: ntimes,itstep,ncid,iddim_stack,nstack,idvar,nvars,idlists(200), & id_em_gc(200),id_em_pm(200),indx_gc(200),indx_pm(200), nvars_gc,nvars_pm,ndims, @@ -296,11 +301,18 @@ END SUBROUTINE PLMRIS ! temporarily, plume top height IF ( FIRSTIME ) THEN FIRSTIME = .FALSE. LOGDEV = SETUP_LOGDEV() + + call aqm_model_domain_get(ids=is, ide=ie, jds=js, jde=je, rc=myrc) + if (aqm_rc_check(myrc, msg="Failure to retrieve grid coordinates in PT3D", + & file=__FILE__, line=__LINE__)) return - L=nf90_open('NEXUS/PT.nc',nf90_nowrite, ncid) + write(logdev,*)'LOCALPET, is, ie, js, je=',mylocalpet, is, ie, js, je + write(aline,"('PT/pt-',i4.4,'.nc')")mylocalpet + L=nf90_open(trim(aline),nf90_nowrite, ncid) if(L.ne.nf90_noerr) then - write(logdev,*)'error openning NEXUS/PT.nc' - stop + IF ( AQM_RC_CHECK( L, + & MSG='failed to open '//trim(aline), + & FILE=__FILE__, LINE=__LINE__ ) ) RETURN endif call check(nf90_inq_dimid(ncid,'nlocs',iddim_stack)) call check(nf90_inquire_dimension(ncid,iddim_stack,len=nstack)) @@ -347,7 +359,9 @@ END SUBROUTINE PLMRIS ! temporarily, plume top height if(ndims.ne.2) then write(logdev,*)'ndims wrong',ndims,vname - stop + IF ( AQM_RC_CHECK( 1, + & MSG='gaseous ndims wrong '//trim(vname), + & FILE=__FILE__, LINE=__LINE__ ) ) RETURN endif if( PTEM_MAP( L ) .gt.0) then nvars_gc=nvars_gc+1 @@ -360,7 +374,9 @@ END SUBROUTINE PLMRIS ! temporarily, plume top height if (L > 0) then if(ndims.ne.2) then write(logdev,*)'ndims wrong',ndims,vname - stop + IF ( AQM_RC_CHECK( 1, + & MSG='aerosol ndims wrong '//trim(vname), + & FILE=__FILE__, LINE=__LINE__ ) ) RETURN endif do S=1, N_SPC_PTPM if(PTPM_MAP(S).eq.L) exit @@ -374,10 +390,14 @@ END SUBROUTINE PLMRIS ! temporarily, plume top height endif enddo - write(logdev,*)'Point Sources nvars_gc, nvars_pm=',nvars_gc, nvars_pm + write(logdev,*)'Point Sources nstack, nvars_gc, nvars_pm=',nstack,nvars_gc, nvars_pm write(logdev,*)'ncols,nrows,my_ncols,my_nrows=',ncols,nrows,my_ncols,my_nrows allocate(my_area(my_ncols,my_nrows)) - if(.not.interpx(GRID_CRO_2D,'AREA','emis',1,my_ncols,1,my_nrows,1,1,jdate,jtime,my_area)) stop + if(.not.interpx(GRID_CRO_2D,'AREA','emis',1,my_ncols,1,my_nrows,1,1,jdate,jtime,my_area)) then + IF ( AQM_RC_CHECK( 1, + & MSG='failed to get area '//trim(aline), + & FILE=__FILE__, LINE=__LINE__ ) ) RETURN + endif allocate(stkemis(nstack,nvars_gc+nvars_pm),uwind(my_ncols,my_nrows,emlyrs), vwind(my_ncols,my_nrows,emlyrs), & stk_ddzf(emlyrs),stk_pres(emlyrs),stk_dens(emlyrs),stk_qv(emlyrs),stk_ta(emlyrs),stk_wspd(emlyrs),stk_zf(emlyrs), @@ -398,12 +418,13 @@ END SUBROUTINE PLMRIS ! temporarily, plume top height C--- anthropogenic point sources itstep=secsdiff(jstartdate,jstarttime,jdate,jtime)/3600+1 - write(logdev,*)'process PT emission ',jdate,jtime,tstep(1),itstep + write(logdev,*)'process PT emission ',jdate,jtime,tstep(1),itstep, mylocalpet,nstack n=nf90_inq_path(ncid,L,path_in) - if(n.ne.nf90_noerr.or.trim(path_in).ne.'NEXUS/PT.nc') then - write(logdev,*)itstep,'ncid wrong, reopen it ',trim(nf90_strerror(n)) - L=nf90_close(ncid) - call check(nf90_open('NEXUS/PT.nc',nf90_nowrite, ncid)) + if(n.ne.nf90_noerr) then + write(logdev,*)itstep,'ncid wrong ',trim(nf90_strerror(n)) + IF ( AQM_RC_CHECK( 1, + & MSG='ncid wrong ', + & FILE=__FILE__, LINE=__LINE__ ) ) RETURN endif elemStart(1)=1; elemStart(2)=itstep @@ -418,8 +439,10 @@ END SUBROUTINE PLMRIS ! temporarily, plume top height write(logdev,*)'also error 1-step reading PT emission of gas ',v,trim(nf90_strerror(S)),id_em_gc(v) else write(logdev,*)'OK for 1-step reading PT emission of gas ',v,trim(nf90_strerror(S)),id_em_gc(v) - endif - stop + endif + IF ( AQM_RC_CHECK( 1, + & MSG='failed to read PT gas emission ', + & FILE=__FILE__, LINE=__LINE__ ) ) RETURN endif enddo @@ -428,13 +451,23 @@ END SUBROUTINE PLMRIS ! temporarily, plume top height L=nf90_get_var(ncid,id_em_pm(v),stkemis(:,v+nvars_gc),start=elemStart,count=elemCount) if(L.ne.nf90_noerr) then write(logdev,*)'error reading PT emission of pm ',v,itstep,nstack,id_em_pm(v) - stop + IF ( AQM_RC_CHECK( 1, + & MSG='failed to read PT aerosol emission ', + & FILE=__FILE__, LINE=__LINE__ ) ) RETURN endif enddo c call check(nf90_close(ncid)) - if(.not.interpx(MET_CRO_3D,'UWINDA','PT3D_DEFN',1,my_ncols,1,my_nrows,1,emlyrs,jdate,jtime,uwind)) stop - if(.not.interpx(MET_CRO_3D,'VWINDA','PT3D_DEFN',1,my_ncols,1,my_nrows,1,emlyrs,jdate,jtime,vwind)) stop + if(.not.interpx(MET_CRO_3D,'UWINDA','PT3D_DEFN',1,my_ncols,1,my_nrows,1,emlyrs,jdate,jtime,uwind)) then + IF ( AQM_RC_CHECK( 1, + & MSG='failed to read wind field ', + & FILE=__FILE__, LINE=__LINE__ ) ) RETURN + endif + if(.not.interpx(MET_CRO_3D,'VWINDA','PT3D_DEFN',1,my_ncols,1,my_nrows,1,emlyrs,jdate,jtime,vwind)) then + IF ( AQM_RC_CHECK( 1, + & MSG='failed to read wind field ', + & FILE=__FILE__, LINE=__LINE__ ) ) RETURN + endif mxzplm=0.0 @@ -509,7 +542,10 @@ END SUBROUTINE PLMRIS ! temporarily, plume top height WRITE( LOGDEV,* ) ' Zbot: ', ZBOT, ' Ztop: ', ZTOP WRITE( LOGDEV,* ) ' Stack Top: ', STKHT( N ), & ' Plume Top: ', ZPLM - stop + IF ( AQM_RC_CHECK( 1, + & MSG='ERROR: Top of plume is less than stack height ', + & FILE=__FILE__, LINE=__LINE__ ) ) RETURN + END IF C Compute LBOT, LTOP such that diff --git a/src/shr/aqm_rc_mod.F90 b/src/shr/aqm_rc_mod.F90 index 1f9496b..96ba736 100644 --- a/src/shr/aqm_rc_mod.F90 +++ b/src/shr/aqm_rc_mod.F90 @@ -4,7 +4,7 @@ module aqm_rc_mod integer, parameter :: AQM_RC_SUCCESS = 0 integer, parameter :: AQM_RC_FAILURE = -1 - + integer :: mylocalpet public contains From 2939b88b96993bf17a86986f2eae43f56e13bbbe Mon Sep 17 00:00:00 2001 From: Youhua Tang Date: Fri, 30 Sep 2022 13:03:17 +0000 Subject: [PATCH 45/90] minor update --- src/model/src/ASX_DATA_MOD.F | 0 src/model/src/PT3D_DEFN.F | 6 +++--- 2 files changed, 3 insertions(+), 3 deletions(-) mode change 100755 => 100644 src/model/src/ASX_DATA_MOD.F diff --git a/src/model/src/ASX_DATA_MOD.F b/src/model/src/ASX_DATA_MOD.F old mode 100755 new mode 100644 diff --git a/src/model/src/PT3D_DEFN.F b/src/model/src/PT3D_DEFN.F index f47352f..3dd8aca 100644 --- a/src/model/src/PT3D_DEFN.F +++ b/src/model/src/PT3D_DEFN.F @@ -178,8 +178,8 @@ SUBROUTINE GET_PT3D_EMIS ( JDATE, JTIME, TSTEP ) USE AERO_DATA, ONLY : N_EMIS_PM, PMEM_MAP_NAME USE PTMAP ! defines pt src species mapping to VDEMIS* arrays USE UTILIO_DEFN - use esmf - use nuopc +! use esmf +! use nuopc IMPLICIT NONE @@ -228,7 +228,7 @@ SUBROUTINE GET_PT3D_EMIS ( JDATE, JTIME, TSTEP ) REAL LFRC ! intermediate LFRAC character(len=NF90_MAX_NAME) :: path_in - type(ESMF_VM) :: VM_ESMF +! type(ESMF_VM) :: VM_ESMF integer myrc, my_mpi_comm,my_ntasks, is, ie, js, je character(200) :: aline From 71ebc0af939319f97e9369e25961c2643461bcef Mon Sep 17 00:00:00 2001 From: zmoon Date: Wed, 26 Oct 2022 10:50:11 -0600 Subject: [PATCH 46/90] Wet deposition fix from @rmontuoro based on the current diff of /scratch2/NCEPDEV/naqfc/Raffaele.Montuoro/flux/dev/pr/jianping/dev/ufs-weather-model/AQM/src/shr/aqm_methods.F90 (couldn't just copy the file since we have other changes) --- src/shr/aqm_methods.F90 | 30 +++++++++++++++++++++++++++++- 1 file changed, 29 insertions(+), 1 deletion(-) diff --git a/src/shr/aqm_methods.F90 b/src/shr/aqm_methods.F90 index 0c7818d..4dc7165 100644 --- a/src/shr/aqm_methods.F90 +++ b/src/shr/aqm_methods.F90 @@ -76,7 +76,7 @@ LOGICAL FUNCTION DESC3( FNAME ) USE M3UTILIO, ONLY : & GDNAM3D, NLAYS3D, NVARS3D, VDESC3D, VGLVS3D, & VGSGPN3, VGTOP3D, VGTYP3D, VNAME3D, UNITS3D, & - NCOLS3D, NROWS3D + NCOLS3D, NROWS3D, SDATE3D, STIME3D, TSTEP3D USE aqm_emis_mod USE aqm_model_mod, ONLY : aqm_config_type, & @@ -198,6 +198,14 @@ LOGICAL FUNCTION DESC3( FNAME ) '1 ', '1 ', & '1 ', 'M/S ' /) + 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 + + 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) @@ -236,6 +244,10 @@ LOGICAL FUNCTION DESC3( FNAME ) if (aqm_rc_check(localrc, msg="Failure to retrieve model input state", & file=__FILE__, line=__LINE__)) return + SDATE3D = config % ctm_stdate + STIME3D = config % ctm_sttime + TSTEP3D = config % ctm_tstep + if (config % species % p_atm_qr > 0) then NVARS3D = NVARS3D + 1 VNAME3D( NVARS3D ) = 'QR' @@ -278,6 +290,14 @@ LOGICAL FUNCTION DESC3( FNAME ) (/ 'M/S ', 'M/S ', & 'KG/(M*S) ', 'KG/(M*S) ' /) + 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 + + SDATE3D = config % ctm_stdate + STIME3D = config % ctm_sttime + TSTEP3D = config % ctm_tstep + DESC3 = .TRUE. RETURN @@ -728,6 +748,14 @@ logical function interpx( fname, vname, pname, & p2d => stateIn % fice case ("SLTYP") p2d => stateIn % stype + k = 0 + do r = row0, row1 + do c = col0, col1 + k = k + 1 + buffer(k) = stateIn % stype(c,r) + if (buffer(k) <= 0.) buffer(k) = 99. + end do + end do case ("SNOCOV") p2d => stateIn % sncov case ("SOIM1") From 6b496a2e458eb96efb78f96768189e0bb94360fa Mon Sep 17 00:00:00 2001 From: zmoon Date: Thu, 17 Nov 2022 11:43:31 -0700 Subject: [PATCH 47/90] Revert "Wet deposition fix from @rmontuoro" This reverts commit 71ebc0af939319f97e9369e25961c2643461bcef. So that we can merge the official version more easily --- src/shr/aqm_methods.F90 | 30 +----------------------------- 1 file changed, 1 insertion(+), 29 deletions(-) diff --git a/src/shr/aqm_methods.F90 b/src/shr/aqm_methods.F90 index 4dc7165..0c7818d 100644 --- a/src/shr/aqm_methods.F90 +++ b/src/shr/aqm_methods.F90 @@ -76,7 +76,7 @@ LOGICAL FUNCTION DESC3( FNAME ) USE M3UTILIO, ONLY : & GDNAM3D, NLAYS3D, NVARS3D, VDESC3D, VGLVS3D, & VGSGPN3, VGTOP3D, VGTYP3D, VNAME3D, UNITS3D, & - NCOLS3D, NROWS3D, SDATE3D, STIME3D, TSTEP3D + NCOLS3D, NROWS3D USE aqm_emis_mod USE aqm_model_mod, ONLY : aqm_config_type, & @@ -198,14 +198,6 @@ LOGICAL FUNCTION DESC3( FNAME ) '1 ', '1 ', & '1 ', 'M/S ' /) - 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 - - 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) @@ -244,10 +236,6 @@ LOGICAL FUNCTION DESC3( FNAME ) if (aqm_rc_check(localrc, msg="Failure to retrieve model input state", & file=__FILE__, line=__LINE__)) return - SDATE3D = config % ctm_stdate - STIME3D = config % ctm_sttime - TSTEP3D = config % ctm_tstep - if (config % species % p_atm_qr > 0) then NVARS3D = NVARS3D + 1 VNAME3D( NVARS3D ) = 'QR' @@ -290,14 +278,6 @@ LOGICAL FUNCTION DESC3( FNAME ) (/ 'M/S ', 'M/S ', & 'KG/(M*S) ', 'KG/(M*S) ' /) - 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 - - SDATE3D = config % ctm_stdate - STIME3D = config % ctm_sttime - TSTEP3D = config % ctm_tstep - DESC3 = .TRUE. RETURN @@ -748,14 +728,6 @@ logical function interpx( fname, vname, pname, & p2d => stateIn % fice case ("SLTYP") p2d => stateIn % stype - k = 0 - do r = row0, row1 - do c = col0, col1 - k = k + 1 - buffer(k) = stateIn % stype(c,r) - if (buffer(k) <= 0.) buffer(k) = 99. - end do - end do case ("SNOCOV") p2d => stateIn % sncov case ("SOIM1") From 5ac639d9747fb97cf3ddf4dd000dd1e5f6b38b20 Mon Sep 17 00:00:00 2001 From: zmoon Date: Fri, 13 Jan 2023 15:27:38 -0700 Subject: [PATCH 48/90] Fix merge bug duplicate cases in select --- src/shr/aqm_methods.F90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/shr/aqm_methods.F90 b/src/shr/aqm_methods.F90 index 931fcdb..93c3b25 100644 --- a/src/shr/aqm_methods.F90 +++ b/src/shr/aqm_methods.F90 @@ -928,10 +928,6 @@ logical function interpx( fname, vname, pname, & end do end do end do - case ("UWINDA") - p3d => stateIn % uwind - case ("VWINDA") - p3d => stateIn % vwind case ("PRES") p3d => stateIn % prl case ("PRESF") From 4861c202a9495bae65e8d2774942b8146277b9f0 Mon Sep 17 00:00:00 2001 From: zmoon Date: Fri, 13 Jan 2023 15:42:49 -0700 Subject: [PATCH 49/90] Remove leftover code in PT3D_DEFN from the initial PT impl --- src/model/src/PT3D_DEFN.F | 32 -------------------------------- 1 file changed, 32 deletions(-) diff --git a/src/model/src/PT3D_DEFN.F b/src/model/src/PT3D_DEFN.F index 2497553..0a7163d 100644 --- a/src/model/src/PT3D_DEFN.F +++ b/src/model/src/PT3D_DEFN.F @@ -118,37 +118,5 @@ SUBROUTINE GET_PT3D_EMIS ( JDATE, JTIME, TSTEP ) CALL GET_PT3D_STKS_EMIS ( JDATE, JTIME ) END SUBROUTINE GET_PT3D_EMIS - - function to_radian(degree) result(rad) - ! degrees to radians - real,intent(in) :: degree - real, parameter :: deg_to_rad = atan(1.0)/45 ! exploit intrinsic atan to generate pi/180 runtime constant - real :: rad - - rad = degree*deg_to_rad - end function to_radian - - function haversine(deglat1,deglon1,deglat2,deglon2) result (dist) - real,intent(in) :: deglat1,deglon1,deglat2,deglon2 - real :: a,c,dist,dlat,dlon,lat1,lat2 - real,parameter :: radius = 6372.8 ! in km - - dlat = to_radian(deglat2-deglat1) - dlon = to_radian(deglon2-deglon1) - lat1 = to_radian(deglat1) - lat2 = to_radian(deglat2) - a = (sin(dlat/2))**2 + cos(lat1)*cos(lat2)*(sin(dlon/2))**2 - c = 2*asin(sqrt(a)) - dist = radius*c - end function haversine - - subroutine check(status) - integer, intent ( in) :: status - - if(status /= nf90_noerr) then - print *, 'netcdf error in PT3D_DEFN.F ', trim(nf90_strerror(status)) - stop "Stopped" - end if - end subroutine check END MODULE PT3D_DEFN From f72f8e96cfb4d8299cd465d5825d185d70c59ccf Mon Sep 17 00:00:00 2001 From: zmoon Date: Wed, 18 Jan 2023 19:46:03 -0700 Subject: [PATCH 50/90] Remove duplicate (and non-guarded) `CLDPROC` call seems was leftover when the new guarded one was merged in --- src/drv/cmaq_mod.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/drv/cmaq_mod.F90 b/src/drv/cmaq_mod.F90 index 90f7a3b..ac47610 100644 --- a/src/drv/cmaq_mod.F90 +++ b/src/drv/cmaq_mod.F90 @@ -165,8 +165,6 @@ END SUBROUTINE AERO CALL CHEM ( CGRID, JDATE, JTIME, TSTEP ) - CALL CLDPROC ( CGRID, JDATE, JTIME, TSTEP ) - if (run_aero) then CALL AERO ( CGRID, JDATE, JTIME, TSTEP ) end if From 754c7e6e478bfb3e4035e8df62cca51b9300e61d Mon Sep 17 00:00:00 2001 From: zmoon Date: Wed, 18 Jan 2023 19:52:43 -0700 Subject: [PATCH 51/90] style reduce diff wrt. upstream --- src/shr/aqm_methods.F90 | 3 +-- src/shr/aqm_state_mod.F90 | 2 +- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/src/shr/aqm_methods.F90 b/src/shr/aqm_methods.F90 index 93c3b25..ec0dab0 100644 --- a/src/shr/aqm_methods.F90 +++ b/src/shr/aqm_methods.F90 @@ -821,7 +821,7 @@ logical function interpx( fname, vname, pname, & k = k + 1 buffer(k) = 0.01 * stateIn % zorl(c,r) end do - end do + end do case ("CLAYF","DRAG","SANDF","UTHR") ! -- fengsha variables call aqm_emis_read("fengsha", vname, buffer, rc=localrc) @@ -838,7 +838,6 @@ logical function interpx( fname, vname, pname, & else buffer(1:lbuf) = 0. end if - case default ! return end select diff --git a/src/shr/aqm_state_mod.F90 b/src/shr/aqm_state_mod.F90 index 1f2d87f..0dff89d 100644 --- a/src/shr/aqm_state_mod.F90 +++ b/src/shr/aqm_state_mod.F90 @@ -59,7 +59,7 @@ module aqm_state_mod ! -- diagnostics real(AQM_KIND_R8), dimension(:,:), pointer :: aod => null() - + end type aqm_state_type public From 3fef8af9246c54b1e78f24287a9ad786ff8bca77 Mon Sep 17 00:00:00 2001 From: zmoon Date: Wed, 18 Jan 2023 19:58:54 -0700 Subject: [PATCH 52/90] Remove duplicate get-config in `aqm_methods` --- src/shr/aqm_methods.F90 | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/shr/aqm_methods.F90 b/src/shr/aqm_methods.F90 index ec0dab0..d5b8e1f 100644 --- a/src/shr/aqm_methods.F90 +++ b/src/shr/aqm_methods.F90 @@ -722,11 +722,6 @@ logical function interpx( fname, vname, pname, & 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 From a1cf98c42e2744637b9240564c73f0f4dacf8baf Mon Sep 17 00:00:00 2001 From: zmoon Date: Wed, 18 Jan 2023 20:02:58 -0700 Subject: [PATCH 53/90] Remove 'AREA' case in `interpx` was added by Youhua but is not present in upstream --- src/shr/aqm_methods.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/shr/aqm_methods.F90 b/src/shr/aqm_methods.F90 index d5b8e1f..a3c8787 100644 --- a/src/shr/aqm_methods.F90 +++ b/src/shr/aqm_methods.F90 @@ -679,8 +679,6 @@ logical function interpx( fname, vname, pname, & select case (trim(vname)) case ('HT') p2d => stateIn % ht - case ('AREA') - p2d => stateIN % area case ('LAT') p2d => lat case ('LON') From c7992a2325d0e1bd650e0297b437cbb310d78634 Mon Sep 17 00:00:00 2001 From: zmoon Date: Thu, 19 Jan 2023 09:17:01 -0700 Subject: [PATCH 54/90] Remove fenghsa `em%dens_flag` block upstream doesn't have it --- src/shr/aqm_emis_mod.F90 | 6 ------ 1 file changed, 6 deletions(-) diff --git a/src/shr/aqm_emis_mod.F90 b/src/shr/aqm_emis_mod.F90 index ad902e7..711264d 100644 --- a/src/shr/aqm_emis_mod.F90 +++ b/src/shr/aqm_emis_mod.F90 @@ -1606,12 +1606,6 @@ subroutine aqm_emis_grd_read(em, spcname, buffer, localDe, rc) em % dens_flag(item) = 1 end if - if (trim(em % type) == "fengsha") then - ! -- ensure fengsha input 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 From 25119722e6647882a21f7f2468ccece4b209f23c Mon Sep 17 00:00:00 2001 From: Patrick Campbell Date: Mon, 23 Jan 2023 11:34:24 -0500 Subject: [PATCH 55/90] Uncommenting diagnostic prints phot.F Quick check of canopy inputs and photolysis attenuation factors. --- src/model/src/phot.F | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/model/src/phot.F b/src/model/src/phot.F index 655f965..2885252 100644 --- a/src/model/src/phot.F +++ b/src/model/src/phot.F @@ -1017,11 +1017,11 @@ END SUBROUTINE O3TOTCOL !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) + 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 @@ -1119,9 +1119,9 @@ END SUBROUTINE O3TOTCOL !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 ) + 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 From b4808e887ca9a4bcbba0c208fd50e08e566f1354 Mon Sep 17 00:00:00 2001 From: Patrick Campbell Date: Mon, 23 Jan 2023 12:18:26 -0500 Subject: [PATCH 56/90] Update phot.F --- src/model/src/phot.F | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/model/src/phot.F b/src/model/src/phot.F index 2885252..655f965 100644 --- a/src/model/src/phot.F +++ b/src/model/src/phot.F @@ -1017,11 +1017,11 @@ END SUBROUTINE O3TOTCOL !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) +! 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 @@ -1119,9 +1119,9 @@ END SUBROUTINE O3TOTCOL !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 ) +! 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 From d577615112f6371b6e108779715350341aa770ff Mon Sep 17 00:00:00 2001 From: Patrick Campbell Date: Tue, 24 Jan 2023 10:41:39 -0500 Subject: [PATCH 57/90] Update phot.F Fixed bug on integrating though ZCAN=ZFL, and rolled back to FCH > 0.5 m canopy condition to be consistent with initial implementation. --- src/model/src/phot.F | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/model/src/phot.F b/src/model/src/phot.F index 655f965..9afa062 100644 --- a/src/model/src/phot.F +++ b/src/model/src/phot.F @@ -1026,8 +1026,8 @@ END SUBROUTINE O3TOTCOL !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 - & .OR. Met_Data%FCH( COL,ROW ) .LT. 10.0 + & .OR. Met_Data%FCH( COL,ROW ) .LT. 0.5 +! & .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 @@ -1052,8 +1052,8 @@ END SUBROUTINE O3TOTCOL !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 + 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 From 6d4fc2732fdb02f33c7d262dc4c5f934e5f722f5 Mon Sep 17 00:00:00 2001 From: Patrick Campbell Date: Tue, 24 Jan 2023 10:42:35 -0500 Subject: [PATCH 58/90] Update phot.F Fixed bug on integrating though ZCAN=ZFL, and rolled back to FCH > 0.5 m canopy condition to be consistent with initial implementation. --- src/model/src/phot.F | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/model/src/phot.F b/src/model/src/phot.F index 655f965..9afa062 100644 --- a/src/model/src/phot.F +++ b/src/model/src/phot.F @@ -1026,8 +1026,8 @@ END SUBROUTINE O3TOTCOL !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 - & .OR. Met_Data%FCH( COL,ROW ) .LT. 10.0 + & .OR. Met_Data%FCH( COL,ROW ) .LT. 0.5 +! & .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 @@ -1052,8 +1052,8 @@ END SUBROUTINE O3TOTCOL !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 + 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 From db3e48d08006e4626fb71f88996820c3110e2bf3 Mon Sep 17 00:00:00 2001 From: Brian Curtis <64433609+BrianCurtis-NOAA@users.noreply.github.com> Date: Tue, 7 Feb 2023 15:46:25 -0500 Subject: [PATCH 59/90] Revert fixes to get debug mode working with UFSWM debug run (#57) --- aqm_files.cmake | 2 +- src/model/src/vdiffacmx.F | 58 +++++++++++++++++---------------------- 2 files changed, 26 insertions(+), 34 deletions(-) diff --git a/aqm_files.cmake b/aqm_files.cmake index 67709fd..692c7d0 100644 --- a/aqm_files.cmake +++ b/aqm_files.cmake @@ -87,6 +87,7 @@ set(VDIFF "${CCTM_ROOT}/vdiff/acm2") set(localCCTM "src/model/src") list(APPEND aqm_CCTM_files ${AERO}/AERO_DATA.F + ${AERO}/aero_depv.F ${AERO}/aero_driver.F ${AERO}/AERO_EMIS.F ${AERO}/AEROMET_DATA.F @@ -242,5 +243,4 @@ list(APPEND aqm_CCTM_files ${localCCTM}/ASX_DATA_MOD.F ${localCCTM}/DUST_EMIS.F ${localCCTM}/AERO_PHOTDATA.F - ${localCCTM}/aero_depv.F ) diff --git a/src/model/src/vdiffacmx.F b/src/model/src/vdiffacmx.F index 1cdb48e..06954c4 100644 --- a/src/model/src/vdiffacmx.F +++ b/src/model/src/vdiffacmx.F @@ -65,19 +65,19 @@ SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, ICMP, DDEPJ, DDEPJ_FST, CNGRD ) CHARACTER( 120 ) :: XMSG = ' ' C Arguments: - REAL*8, INTENT( IN ) :: DTSEC ! model time step in seconds + REAL, INTENT( IN ) :: DTSEC ! model time step in seconds C--- SEDDY is strictly an input, but it gets modified here - REAL*8, INTENT( INOUT ) :: SEDDY ( :,:,: ) ! flipped EDDYV - REAL*8, INTENT( INOUT ) :: DDEP ( :,:,: ) ! ddep accumulator - REAL*8, INTENT( INOUT ) :: ICMP ( :,:,: ) ! component flux accumlator - REAL*8, INTENT( INOUT ), OPTIONAL :: DDEPJ ( :,:,:,: ) ! ddep for mosaic - REAL*8, INTENT( INOUT ), OPTIONAL :: DDEPJ_FST( :,:,:,: ) ! ddep for stomtal/cuticular pathway + 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: C explicit, THETA = 0, implicit, THETA = 1 ! Crank-Nicholson: THETA = 0.5 - REAL*8, PARAMETER :: THETA = 0.5, + REAL, PARAMETER :: THETA = 0.5, & THBAR = 1.0 - THETA C External Functions: None @@ -88,26 +88,26 @@ SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, ICMP, DDEPJ, DDEPJ_FST, CNGRD ) LOGICAL, SAVE :: FIRSTIME = .TRUE. - REAL*8, ALLOCATABLE, SAVE :: DD_FAC ( : ) ! combined subexpression - REAL*8, ALLOCATABLE, SAVE :: DDBF ( : ) ! secondary DDEP - REAL*8, ALLOCATABLE, SAVE :: CMPF ( : ) ! intermediate CMP - REAL*8, ALLOCATABLE, SAVE :: CONC ( :,: ) ! secondary CGRID expression - REAL*8, ALLOCATABLE, SAVE :: EMIS ( :,: ) ! emissions subexpression - REAL*8 DTDENS1 ! DT * layer 1 air density + REAL, ALLOCATABLE, SAVE :: DD_FAC ( : ) ! combined subexpression + REAL, ALLOCATABLE, SAVE :: DDBF ( : ) ! secondary DDEP + 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*8 DFACP, DFACQ - REAL*8 RP, RQ - REAL*8, ALLOCATABLE, SAVE :: DEPVCR ( : ) ! dep vel in one cell - REAL*8, ALLOCATABLE, SAVE :: EFAC1 ( : ) - REAL*8, ALLOCATABLE, SAVE :: EFAC2 ( : ) - REAL*8, ALLOCATABLE, SAVE :: POL ( : ) ! prodn/lossrate = PLDV/DEPV - REAL*8 PLDV_HONO ! PLDV for HONO - REAL*8 DEPV_NO2 ! dep vel of NO2 - REAL*8 DEPV_HNO3 ! dep vel of HNO3 + REAL DFACP, DFACQ + REAL RP, RQ + REAL, ALLOCATABLE, SAVE :: DEPVCR ( : ) ! dep vel in one cell + 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*8 DTS + REAL DTS INTEGER, SAVE :: LOGDEV INTEGER ASTAT @@ -222,11 +222,7 @@ SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, ICMP, DDEPJ, DDEPJ_FST, CNGRD ) IF ( V .EQ. HNO3_HIT ) THEN S = HNO3_MAP CONC( S,1 ) = POL( V ) + ( CONC( S,1 ) - POL( V ) ) * EFAC1( V ) - IF (CONC( NO2_MAP,1 ) .NE. 0) THEN - DEPV_HNO3 = DEPVCR( V ) + PLDV_HONO / CONC( NO2_MAP,1 ) - ELSE - DEPV_HNO3 = DEPVCR( V ) - END IF + 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 ) @@ -237,11 +233,7 @@ SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, ICMP, DDEPJ, DDEPJ_FST, CNGRD ) C reduce the NO2 conc. in the atmosphere without affecting the depositional loss. ELSE IF ( V .EQ. NO2_HIT ) THEN S = NO2_MAP - IF (CONC( S,1 ) .NE. 0) THEN - DEPV_NO2 = DEPVCR( V ) + 2.0 * PLDV_HONO / CONC( S,1 ) - ELSE - DEPV_NO2 = DEPVCR( V ) - END IF + DEPV_NO2 = DEPVCR( V ) + 2.0 * PLDV_HONO / CONC( S,1 ) EFAC1 ( V ) = EXP( -DEPV_NO2 * RP ) EFAC2 ( V ) = EXP( -DEPV_NO2 * RQ ) POL ( V ) = PLDV( V,C,R ) / DEPV_NO2 From ebe14d58bc78bf67a1fd1a3efdf27dfb613dc64e Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Fri, 10 Feb 2023 12:50:36 -0500 Subject: [PATCH 60/90] Restricted to FCH and LAI only to match CCPP physics. --- src/model/src/phot.F | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/model/src/phot.F b/src/model/src/phot.F index 9afa062..e621104 100644 --- a/src/model/src/phot.F +++ b/src/model/src/phot.F @@ -1027,11 +1027,12 @@ END SUBROUTINE O3TOTCOL !a continuous forest canopy IF ( Met_Data%LAIE( COL,ROW ) .LT. 0.1 & .OR. Met_Data%FCH( COL,ROW ) .LT. 0.5 +! Only using LAI and FCH conditions now consistent with CCPP PBL ! & .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 +! & .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. From 61ce18a0a3881c871e8ea93333a80048426499c8 Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Fri, 10 Feb 2023 13:01:46 -0500 Subject: [PATCH 61/90] Fixed bug in IF statement for canopy conditions. --- src/model/src/phot.F | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/model/src/phot.F b/src/model/src/phot.F index e621104..99862a3 100644 --- a/src/model/src/phot.F +++ b/src/model/src/phot.F @@ -1026,8 +1026,7 @@ END SUBROUTINE O3TOTCOL !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 -! Only using LAI and FCH conditions now consistent with CCPP PBL + & .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 From d1d28c18d56e00fece0554ad37d3c7898f243062 Mon Sep 17 00:00:00 2001 From: Barry Baker Date: Wed, 26 Apr 2023 15:31:17 -0400 Subject: [PATCH 62/90] Update CMAQ --- src/model/CMAQ | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/model/CMAQ b/src/model/CMAQ index be5d28f..6494bf2 160000 --- a/src/model/CMAQ +++ b/src/model/CMAQ @@ -1 +1 @@ -Subproject commit be5d28fd1b60522e6fc98aefeead20e6aac3530b +Subproject commit 6494bf25106c70aea8dd8ac1137af886fbf8575f From 0a000fee2220b46fe6083095cdf011845368cf63 Mon Sep 17 00:00:00 2001 From: Youhua Tang Date: Sun, 14 May 2023 13:36:22 +0000 Subject: [PATCH 63/90] update CMAQ respository --- src/model/CMAQ | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/model/CMAQ b/src/model/CMAQ index 6494bf2..642e813 160000 --- a/src/model/CMAQ +++ b/src/model/CMAQ @@ -1 +1 @@ -Subproject commit 6494bf25106c70aea8dd8ac1137af886fbf8575f +Subproject commit 642e81395472d5887b54f601b60ee607ed39bf09 From 938a34013f3b32feae3091eb58d9e3069eb1eab8 Mon Sep 17 00:00:00 2001 From: Wei Li Date: Fri, 21 Jul 2023 16:29:18 -0500 Subject: [PATCH 64/90] update aqm_files.cmake with corresponding code changes in the local /model/src folder --- aqm_files.cmake | 92 +- src/model/src/AERO_EMIS.F | 579 ++ src/model/src/AERO_PHOTDATA.F | 213 +- src/model/src/ASX_DATA_MOD.F | 1406 ++-- src/model/src/DUST_EMIS.F | 696 +- src/model/src/RUNTIME_VARS.F | 1201 ++++ src/model/src/centralized_io_module.F | 6987 ++++++++++++++++++++ src/model/src/centralized_io_util_module.F | 112 +- src/model/src/o3totcol.f | 330 +- src/model/src/phot.F | 929 ++- src/shr/aqm_methods.F90 | 114 +- 11 files changed, 10668 insertions(+), 1991 deletions(-) create mode 100644 src/model/src/AERO_EMIS.F create mode 100644 src/model/src/RUNTIME_VARS.F create mode 100644 src/model/src/centralized_io_module.F diff --git a/aqm_files.cmake b/aqm_files.cmake index 6727dc8..b23a84f 100644 --- a/aqm_files.cmake +++ b/aqm_files.cmake @@ -68,46 +68,42 @@ list(APPEND aqm_ioapi_files set(CCTM_ROOT "src/model/CMAQ/CCTM/src") set(AERO "${CCTM_ROOT}/aero/aero6") -set(BIOG "${CCTM_ROOT}/biog/beis3") +set(BIOG "${CCTM_ROOT}/biog/beis4") set(CLOUD "${CCTM_ROOT}/cloud/acm_ae6") set(DEPV "${CCTM_ROOT}/depv/m3dry") set(EMIS "${CCTM_ROOT}/emis/emis") -set(GAS "${CCTM_ROOT}/gas/ebi_cb6r3_ae6_aq") +set(GAS "${CCTM_ROOT}/gas/ebi_cb6r5_ae7_aq") set(GRID "${CCTM_ROOT}/grid/cartesian") set(ICL "${CCTM_ROOT}/ICL/fixed") -set(INIT "${CCTM_ROOT}/init/yamo") -set(MECHS "${CCTM_ROOT}/MECHS/cb6r3_ae6_aq") +set(INIT "${CCTM_ROOT}/init") +set(MECHS "${CCTM_ROOT}/MECHS/cb6r5_ae7_aq") set(PA "${CCTM_ROOT}/procan/pa") set(PHOT "${CCTM_ROOT}/phot/inline") set(PLRISE "${CCTM_ROOT}/plrise/smoke") set(SPCS "${CCTM_ROOT}/spcs/cgrid_spcs_nml") +set(STM "${CCTM_ROOT}/stm") set(STENEX "${CCTM_ROOT}/STENEX/noop") set(UTIL "${CCTM_ROOT}/util/util") -set(VDIFF "${CCTM_ROOT}/vdiff/acm2") +set(VDIFF "${CCTM_ROOT}/vdiff/acm2_m3dry") +set(DRIV "${CCTM_ROOT}/driver") set(localCCTM "src/model/src") list(APPEND aqm_CCTM_files ${AERO}/AERO_DATA.F ${AERO}/aero_driver.F - ${AERO}/AERO_EMIS.F + ${AERO}/aero_nml_modes.F ${AERO}/AEROMET_DATA.F ${AERO}/AEROSOL_CHEMISTRY.F ${AERO}/aero_subs.F - ${AERO}/aero_depv.F - ${AERO}/AOD_DEFN.F ${AERO}/coags.f ${AERO}/getpar.f ${AERO}/isocom.f ${AERO}/isofwd.f ${AERO}/isorev.f ${AERO}/isrpia.inc - ${AERO}/opvis.F - ${AERO}/opavis.F - ${AERO}/oppmdiag.F - ${AERO}/opapmdiag.F + ${AERO}/AERO_BUDGET.F ${AERO}/PRECURSOR_DATA.F - ${AERO}/PMDIAG_DATA.F ${AERO}/SOA_DEFN.F - ${BIOG}/beis3.F + ${BIOG}/beis.F ${BIOG}/checkmem.f ${BIOG}/czangle.F ${BIOG}/getparb.f @@ -131,31 +127,31 @@ list(APPEND aqm_CCTM_files ${DEPV}/gas_depv_map.F ${DEPV}/HGSIM.F ${DEPV}/LSM_MOD.F - ${DEPV}/MOSAIC_MOD.F + ${DEPV}/depv_data_module.F ${DEPV}/opdepv_diag.F - ${DEPV}/opdepv_mos.F - ${DEPV}/opdepv_fst.F ${DEPV}/m3dry.F ${EMIS}/BEIS_DEFN.F ${EMIS}/BIOG_EMIS.F ${EMIS}/cropcal.F - ${EMIS}/EMIS_DEFN.F + ${EMIS}/crop_data_module.F ${EMIS}/LTNG_DEFN.F ${EMIS}/LUS_DEFN.F ${EMIS}/MGEMIS.F - ${EMIS}/opemis.F ${EMIS}/PTBILIN.F ${EMIS}/SSEMIS.F ${EMIS}/STK_EMIS.F ${EMIS}/STK_PRMS.F - ${EMIS}/tfabove.F - ${EMIS}/tfbelow.F ${EMIS}/UDTYPES.F - ${GAS}/degrade_data.F - ${GAS}/degrade.F - ${GAS}/DEGRADE_SETUP_TOX.F - ${GAS}/final_degrade.F - ${GAS}/find_degraded.F + ${EMIS}/biog_emis_param_module.F + ${EMIS}/CMAQ_Control_DESID.nml + #${EMIS}/desid_module.F + ${EMIS}/desid_param_module.F + ${EMIS}/desid_util.F + ${EMIS}/desid_vars.F + ${EMIS}/lus_data_module.F + ${EMIS}/stack_group_data_module.F + ${GAS}/../../reactive_tracers/DEGRADE_PARAMETERS.F + ${GAS}/../../reactive_tracers/DEGRADE_ROUTINES.F ${GAS}/hrdata_mod.F ${GAS}/hrdriver.F ${GAS}/hrg1.F @@ -166,7 +162,7 @@ list(APPEND aqm_CCTM_files ${GAS}/hrprodloss.F ${GAS}/hrrates.F ${GAS}/hrsolver.F - ${GAS}/init_degrade.F + ${GAS}/../../reactive_tracers/DEGRADE_SETUP_TOX.F ${GRID}/GRID_CONF.F ${GRID}/HGRD_DEFN.F ${GRID}/VGRD_DEFN.F @@ -181,11 +177,15 @@ list(APPEND aqm_CCTM_files ${MECHS}/RXNS_DATA_MODULE.F90 ${MECHS}/RXNS_FUNC_MODULE.F90 ${PA}/PA_DEFN.F + ${PA}/budget_defn.F + ${PA}/../../hadv/ppm/xy_budget.F ${PA}/pa_update.F + ${PA}/PA_IRR_module.F + ${PA}/PA_IRR_CTL.F ${PHOT}/CLOUD_OPTICS.F ${PHOT}/complex_number_module.F90 ${PHOT}/CSQY_DATA.F - ${PHOT}/OMI_1979_to_2015.dat + ${PHOT}/OMI_1979_to_2019.dat ${PHOT}/opphot.F ${PHOT}/PHOT_MET_DATA.F ${PHOT}/PHOT_MOD.F @@ -193,6 +193,7 @@ list(APPEND aqm_CCTM_files ${PHOT}/PHOT_OPTICS.dat ${PHOT}/SEAS_STRAT_O3_MIN.F ${PHOT}/twoway_rrtmg_aero_optics.F90 + ${PHOT}/concld_prop_acm.F ${PLRISE}/delta_zs.f ${PLRISE}/fire_plmris.F ${PLRISE}/openlayout.F @@ -200,9 +201,11 @@ list(APPEND aqm_CCTM_files ${PLRISE}/plmris.F ${PLRISE}/plsprd.f ${PLRISE}/preplm.f - ${PLRISE}/ungridb2.f ${PLRISE}/write3_distr.f ${SPCS}/CGRID_SPCS.F + ${SPCS}/CGRID_SPCS_TYPES.F + ${STM}/STM_VARS.F + ${STM}/STM_MODULE.F ${STENEX}/noop_comm_module.f ${STENEX}/noop_data_copy_module.f ${STENEX}/noop_gather_module.f @@ -214,34 +217,41 @@ list(APPEND aqm_CCTM_files ${STENEX}/noop_slice_module.f ${STENEX}/noop_term_module.f ${STENEX}/noop_util_module.f - ${UTIL}/bmatvec.F ${UTIL}/findex.f - ${UTIL}/get_envlist.f + ${UTIL}/log_header.F + ${UTIL}/get_env_mod.f90 ${UTIL}/setup_logdev.F ${UTIL}/subhdomain.F ${UTIL}/UTILIO_DEFN.F + ${UTIL}/util_family_module.F + ${UTIL}/CMAQ_Control_Misc.nml + ${DRIV}/ELMO_PROC.F + ${DRIV}/ELMO_DATA.F ${VDIFF}/aero_sedv.F + ${VDIFF}/aero_depv.F ${VDIFF}/conv_cgrid.F ${VDIFF}/matrix1.F ${VDIFF}/opddep.F - ${VDIFF}/opddep_fst.F - ${VDIFF}/opddep_mos.F - ${VDIFF}/rddepv.F ${VDIFF}/SEDIMENTATION.F ${VDIFF}/tri.F + ${VDIFF}/VDIFF_DATA.F ${VDIFF}/VDIFF_DIAG.F ${VDIFF}/VDIFF_MAP.F - ${VDIFF}/vdiffproc.F + ${VDIFF}/vdiffacmx.F + #${VDIFF}/vdiffproc.F + ${VDIFF}/../../biog/megan3/BDSNP_MOD.F ${localCCTM}/o3totcol.f - ${localCCTM}/vdiffacmx.F - ${localCCTM}/PTMAP.F - ${localCCTM}/PT3D_DATA_MOD.F - ${localCCTM}/PT3D_DEFN.F - ${localCCTM}/PT3D_FIRE_DEFN.F - ${localCCTM}/PT3D_STKS_DEFN.F + ${localCCTM}/AERO_EMIS.F + ${localCCTM}/RUNTIME_VARS.F + #${localCCTM}/PTMAP.F + #${localCCTM}/PT3D_DATA_MOD.F + #${localCCTM}/PT3D_DEFN.F + #${localCCTM}/PT3D_FIRE_DEFN.F + #${localCCTM}/PT3D_STKS_DEFN.F ${localCCTM}/ASX_DATA_MOD.F ${localCCTM}/DUST_EMIS.F ${localCCTM}/AERO_PHOTDATA.F ${localCCTM}/phot.F + ${localCCTM}/centralized_io_module.F ${localCCTM}/centralized_io_util_module.F ) diff --git a/src/model/src/AERO_EMIS.F b/src/model/src/AERO_EMIS.F new file mode 100644 index 0000000..0088145 --- /dev/null +++ b/src/model/src/AERO_EMIS.F @@ -0,0 +1,579 @@ + +!------------------------------------------------------------------------! +! The Community Multiscale Air Quality (CMAQ) system software is in ! +! continuous development by various groups and is based on information ! +! from these groups: Federal Government employees, contractors working ! +! within a United States Government contract, and non-Federal sources ! +! including research institutions. These groups give the Government ! +! permission to use, prepare derivative works of, and distribute copies ! +! of their work in the CMAQ system to the public and to permit others ! +! to do so. The United States Environmental Protection Agency ! +! therefore grants similar permission to use the CMAQ system software, ! +! but users are requested to provide copies of derivative works or ! +! products designed to operate in the CMAQ system to the United States ! +! Government without restrictions as to use by others. Software ! +! that is used with the CMAQ system but distributed under the GNU ! +! General Public License or the GNU Lesser General Public License is ! +! subject to their copyright restrictions. ! +!------------------------------------------------------------------------! + +C::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: + MODULE AERO_EMIS + +C Emissions data and code required for the modal aerosol module in CMAQ +C Based on original codes by Dr. Francis S. Binkowski and J. Young + +C Dependent Upon: NONE + +C Revision History: + +C 30 Aug 01 J.Young: dyn alloc - Use HGRD_DEFN +C 09 Oct 03 J.Gipson: added MW array for AE emis species to module contents +C 31 Jan 05 J.Young: dyn alloc - establish both horizontal & vertical +C domain specifications in one module, GRID_CONF +C 26 Apr 05 P.Bhave: removed code supporting the "old type" of emission +C files that had unspeciated PM10 and PM2.5 only +C removed need for 'AERO_SPC.EXT' by declaring the +C required variables locally +C 13 Jun 05 P.Bhave: added vars needed for sea-salt emission processing +C inherit N_AE_EMIS,AE_EMIS,AE_EMIS_MAP from AE_EMIS.EXT +C moved RHO* parameters from RDEMIS_AE to this module +C for use by SSEMIS routine +C 24 Aug 07 J.Young: Modified to enable in-line plume rise calculation for +C 3D pt source emissions. Distinguish between PM (primary, +C unspeciated, file data) and AE (model speciated). Re- +C named RDEMIS_AE to GET_AERO_EMIS. +C 11 Apr 08 J.Kelly: added code to emit coarse surface area +C 4 Jan 10 J.Young: restructure; eliminate ref to older AERO versions +C 21 Feb 10 J.Young: move sea salt emissions to its own module (SSEMIS) +C 23 Apr 10 J.Young: replace include files with mechanism namelists +C 30 Apr 10 J.Young: update to use aero_reeng by Steve Howard, Prakash Bhave, +C Jeff Young, and Sergey Napelenok +C 23 Jul 10 D.Wong: remove CLOSE3 and BARRIER +C 24 Feb 11 J.Young: Reorganized module with initialization and timestepping +C procedures +C 25 Feb 11 J.Young: add windblown dust module +C 25 Mar 11 S.Roselle: replaced I/O API include files with UTILIO_DEFN +C 11 May 11 D.Wong: incorporated twoway model implementation +C 18 Aug 11 David Wong: In the merge inline point source PM species calculation, +C arrays EMBUFF and PMEMIS_PT have incorrect index values +C 17 Apr 13 J.Young: replace "SPFC ASO4" (found by Havala Pye) with "SPFC_ASO4" +C 07 Nov 14 J.Bash: Updated for the ASX_DATA_MOD shared data module. +C----------------------------------------------------------------------- + + USE AERO_DATA, ONLY: DESID_N_AERO_REF, N_MODE + USE DESID_VARS, ONLY: DESID_LAYS, DESID_STREAM_AERO, DESID_N_SRM, CELLVOL + + IMPLICIT NONE + SAVE +C aerosol emissions: [ppmv/s] for mass & number spcs, [m2/mol/s] for surface area spcs + PUBLIC DESID_SIZE_DIST, AERO_EMIS_INIT, DESID_INIT_SIZE_DIST, + & MAP_ISTRtoAERO, MAP_ISTRtoMODE, MAP_NUMtoISTR, MAP_SRFtoISTR, + & MAP_ISTRtoNUM, MAP_ISTRtoSRF, MAP_ISTRtoSD, DESID_STREAM_AERO, + & SD_SPLIT + PRIVATE + +C Variables for converting mass emissions rate to number emissions rate + REAL :: FACNUM( DESID_N_AERO_REF,N_MODE ) + +C Variables for converting mass emissions rate to 2nd moment emissions rate + REAL :: FACSRF( DESID_N_AERO_REF,N_MODE ) + +C Variables for Saving split factors between emission modes + REAL, ALLOCATABLE :: SD_SPLIT( :,: ) + +C Emission rate of all aerosol species interpolated to current time + INTEGER, ALLOCATABLE :: MAP_ISTRtoAERO( : ) + INTEGER, ALLOCATABLE :: MAP_ISTRtoMODE( : ) + INTEGER, ALLOCATABLE :: MAP_NUMtoISTR ( : ) + INTEGER, ALLOCATABLE :: MAP_SRFtoISTR ( : ) + INTEGER, ALLOCATABLE :: MAP_ISTRtoNUM ( : ) + INTEGER, ALLOCATABLE :: MAP_ISTRtoSRF ( : ) + INTEGER, ALLOCATABLE :: MAP_ISTRtoSD ( :,: ) + INTEGER, ALLOCATABLE :: MAP_AEROtoDIFF( :,: ) ! indices of aero species to CGRID + +C Miscellaneous variables + CHARACTER( 200 ) :: XMSG = ' ' + + CONTAINS + +C----------------------------------------------------------------------- + FUNCTION AERO_EMIS_INIT ( JDATE, JTIME, TSTEP ) RESULT ( SUCCESS) + +C Revision History: + +C 30 Aug 01 J.Young: dynamic allocation - Use INTERPX +C 29 Jul 03 P.Bhave: added compatibility with emission files that contain +C PM10, PEC, POA, PNO3, PSO4, and PMF, but do not +C contain PMC +C 20 Aug 03 J.Young: return aero emissions in molar mixing ratio, ppm units +C 09 Oct 03 J.Gipson: added MW array for AE emis species to module contents +C 01 Sep 04 P.Bhave: changed MW for primary organics from 120 to 220 g/mol, +C to match MWPOA in subroutine ORGAER3. +C 31 Jan 05 J.Young: dyn alloc - removed HGRD_ID, VGRID_ID, and COORD_ID +C include files because those parameters are now +C inherited from the GRID_CONF module +C 26 Apr 05 P.Bhave: removed code supporting the "old type" of emission +C files that had unspeciated PM10 and PM2.5 only +C removed need for 'AERO_CONST.EXT' by declaring the +C required variables locally +C simplified the CONVM, CONVN, CONVS calculations +C updated and enhanced in-line documentation +C 03 May 05 P.Bhave: fixed bug in the H2SO4 unit conversion, initially +C identified by Jinyou Liang of CARB +C 13 Jun 05 P.Bhave: calculate sea-salt emissions; execute if MECHNAME = AE4 +C read input fields from new OCEAN_1 file +C read extra input fields from MET_CRO_2D and MET_CRO_3D +C write diagnostic sea-salt emission file +C added TSTEP to call vector for diagnostic output file +C inherit MWs from AE_SPC.EXT instead of hardcoding +C find pointers to CGRID indices instead of hardcoding +C 08 Mar 07 P.Bhave& added capability for emission files that contain +C S.Roselle: POC or POA +C 30 Jan 08 P.Bhave: added compatibility with AE5 mechanisms +C 23 Mar 08 J.Young: modifications to allow for in-line point source emissions +C 11 Apr 08 J.Kelly: added code to emit coarse surface area +C 09 Sep 08 P.Bhave: backward compatibility with AE4 mechanisms +C 20 Feb 10 J.Young: move ssemis out to its own F90 module +C 24 Feb 11 J.Young: add windblown dust emissions option +C 25 Mar 11 S.Roselle: Replaced I/O API include files with UTILIO_DEFN +C 07 Jul 14 B.Hutzell: replaced mechanism include file(s) with fortran module +C 17 Sep 14 K.Fahey: Changed geometric mean diameter and geometric +C standard deviation of emitted particles according to +C Elleman and Covert (2010) +C 15 Apr 16 J.Young: Use aerosol factors from the AERO_DATA module's named constants; +C Moved K.Fahey's mods to geometric mean diameter and standard +C deviation to the AERO_DATA module + +C References: +C CRC76, "CRC Handbook of Chemistry and Physics (76th Ed)", +C CRC Press, 1995 +C Elleman & Covert, "Aerosol size distribution modeling with the Community +C Multiscale Air Quality modeling system in the Pacific +C Northwest: 3. Size distribution of particles emitted +C into a mesoscale model", J. Geophys. Res., Vol 115, +C No D3, doi:10.1029/2009JD012401, 2010 +C Hobbs, P.V. "Basic Physical Chemistry for the Atmospheric Sciences", +C Cambridge Univ. Press, 206 pp, 1995. +C Snyder, J.P. "Map Projections-A Working Manual", U.S. Geological Survey +C Paper 1395 U.S.GPO, Washington, DC, 1987. +C Binkowski & Roselle Models-3 Community Multiscale Air Quality (CMAQ) +C model aerosol component 1: Model Description. +C J. Geophys. Res., Vol 108, No D6, 4183 +C doi:10.1029/2001JD001409, 2003 +C----------------------------------------------------------------------- + + USE AERO_DATA, ONLY: DESID_AERO_REF, N_AEROSPC, AEROSPC, + & AERO_MISSING, MAP_AERO + USE GRID_CONF, ONLY: GDTYP_GD, XCELL_GD, YCELL_GD, YORIG_GD, GL_NROWS, X3FACE_GD + USE DUST_EMIS, ONLY: DUST_EMIS_INIT + USE DESID_VARS, ONLY: MAP_ISTRtoEMVAR + USE PRECURSOR_DATA, ONLY: MAP_PRECURSOR + USE RUNTIME_VARS, ONLY: OCEAN_CHEM, WB_DUST + USE SSEMIS, ONLY: SSEMIS_INIT + USE UTILIO_DEFN !(Wei Li), ONLY: INDEX1, M3EXIT, LATGRD3, XSTAT1, XSTAT2 + USE VDIFF_MAP, ONLY : N_SPC_DIFF, DIFF_SPC + + INCLUDE SUBST_CONST ! physical and mathematical constants + INCLUDE SUBST_FILES_ID ! file name parameters + +C Arguments: + + INTEGER, INTENT( IN ) :: JDATE ! current model date, coded YYYYDDD + INTEGER, INTENT( IN ) :: JTIME ! current model time, coded HHMMSS + INTEGER, INTENT( IN ) :: TSTEP ! time step vector (HHMMSS) + ! TSTEP(1) = local output step + LOGICAL SUCCESS + +C External Functions: + INTEGER, EXTERNAL :: FINDEX ! looks up number in table. + +C Local Variables: + REAL DGV, SG, SPLIT_ACCUM + +C Domain decomposition info from emission and meteorology files + INTEGER GXOFF, GYOFF ! origin offset + +C Miscellaneous variables + INTEGER STATUS ! ENV..., ALLOCATE status + CHARACTER( 16 ), SAVE :: PNAME = 'AERO_EMIS_INIT ' + CHARACTER( 16 ) :: VNAME ! temp var for species names + CHARACTER( 50 ) :: VARDESC ! variable for reading environ. variables + INTEGER L, N, S, V, IAERO, ISRM, ! Loop indices + & IEM, IDIFF, ISPC + +C ---------------------------------------------------------------------- + + SUCCESS = .TRUE. + +C *** Map data modules + CALL MAP_AERO() + CALL MAP_PRECURSOR() + +C *** set up for sea-spray emission processing + IF ( OCEAN_CHEM ) THEN + IF ( .NOT. SSEMIS_INIT( JDATE, JTIME, TSTEP ) ) THEN + XMSG = 'Failure initializing sea-spray emission processing' + CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT2 ) + END IF + END IF + +C *** set up for dust emission processing + IF ( WB_DUST ) THEN + IF ( .NOT. DUST_EMIS_INIT( JDATE, JTIME, TSTEP ) ) THEN + XMSG = 'Failure initializing dust emission processing' + CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT2 ) + END IF + END IF + +C *** Set up emissions size distribution arrays + ! Calculate factors for converting 3rd moment emission rates into + ! number and surface area emission rates. See Equation 7b of + ! Binkowski & Roselle (2003) + DO IEM = 1,DESID_N_AERO_REF + DO N = 1, N_MODE + DGV = DESID_AERO_REF( IEM )%DGVEM( N ) + SG = DESID_AERO_REF( IEM )%SGEM ( N ) + + IF ( DESID_AERO_REF( IEM )%SPLIT( N ) .GT. 0.0 ) THEN + FACNUM( IEM,N ) = EXP( 4.5 * LOG( SG ) ** 2 ) / DGV ** 3 + FACSRF( IEM,N ) = PI * EXP( 0.5 * LOG( SG ) ** 2 ) / DGV + ELSE + FACNUM( IEM,N ) = 0.0 + FACSRF( IEM,N ) = 0.0 + END IF + END DO + + END DO + + ! Map the Modal-Dependent Names to Transported Species + ALLOCATE ( MAP_AEROtoDIFF( N_AEROSPC, N_MODE ) ) + DO ISPC = 1,N_AEROSPC + DO N = 1,N_MODE + MAP_AEROtoDIFF( ISPC, N ) = INDEX1( AEROSPC( ISPC )%name( N ), + & N_SPC_DIFF, DIFF_SPC ) + END DO + END DO + + + ! Modify the reference emissions splits based on what transported + ! aerosol species are actually available. For example, if the aerosol + ! namelist only includes the accumulation mode (J) but not the + ! Aitken mode (I) for a particular species, then the split for + ! Aitken mode should be added to the Accumulation mode. Save + ! these scale factors as a function of transported species and + ! mode. + ALLOCATE( SD_SPLIT( N_SPC_DIFF, DESID_N_AERO_REF ) ) + SD_SPLIT = 0.0 + DO IEM = 1,DESID_N_AERO_REF + ! For the Fine Mode Reference Distribution, lump Aitken + ! with Accumulation mode if Aitken Mode does not exist + IF ( DESID_AERO_REF( IEM )%NAME .EQ. 'FINE_REF' ) THEN + DO ISPC = 1,N_AEROSPC + SPLIT_ACCUM = 0.0 + DO N = 1,N_MODE-1 + IF ( AERO_MISSING( ISPC,N ) ) THEN + SPLIT_ACCUM = SPLIT_ACCUM + DESID_AERO_REF( IEM )%SPLIT( N ) + ELSE + SD_SPLIT( MAP_AEROtoDIFF( ISPC,N ),IEM ) = + & SD_SPLIT( MAP_AEROtoDIFF( ISPC,N ),IEM ) + + & DESID_AERO_REF( IEM )%SPLIT( N ) + SPLIT_ACCUM + SPLIT_ACCUM = 0.0 + END IF + END DO + END DO + ELSE + ! Arbitrary Distribution -> Apply factor to species + ! if it exists in each mode + DO ISPC = 1, N_AEROSPC + DO N = 1, N_MODE + IF ( .NOT. AERO_MISSING( ISPC,N ) ) THEN + SD_SPLIT( MAP_AEROtoDIFF( ISPC,N ),IEM ) = + & DESID_AERO_REF( IEM )%SPLIT( N ) + END IF + END DO + END DO + END IF + END DO + + ALLOCATE ( MAP_NUMtoISTR ( N_MODE ), + & MAP_SRFtoISTR ( N_MODE ), STAT = STATUS ) + CALL CHECKMEM( STATUS, 'MAP_NUMtoEM', PNAME ) + CALL CHECKMEM( STATUS, 'MAP_SRFtoEM', PNAME ) + + END FUNCTION AERO_EMIS_INIT + +C----------------------------------------------------------------------- + + SUBROUTINE DESID_INIT_SIZE_DIST ( JDATE, JTIME ) + +C EM_SD_INIT initializes the structures that map modes and streams to +C reference modes including splits, diameters, and standard deviations. + +C----------------------------------------------------------------------- + USE AERO_DATA, ONLY: DESID_AERO_REF, DESID_N_AERO_REF + USE DESID_VARS, ONLY: DESID_SD_NML + USE DESID_UTIL, ONLY: DESID_GET_RULE_STREAMS + USE UTILIO_DEFN, ONLY: INDEX1, XSTAT1 + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: JDATE ! current model date, coded YYYYDDD + INTEGER, INTENT( IN ) :: JTIME ! current model time, coded HHMMSS + INTEGER ISRM + + INTEGER :: N_SD_RULE + INTEGER :: N_SD( DESID_N_SRM ) + CHARACTER( 16 ) :: SD_NAME( DESID_N_SRM, 10 ) + INTEGER :: SD( DESID_N_SRM, 10 ) + LOGICAL :: RULE_STREAM( DESID_N_SRM ) + CHARACTER( 16 ) :: CSUR + CHARACTER( 16 ), SAVE :: PNAME = 'EM_SD_INIT ' + CHARACTER( 20 ) :: DESID_AERO_REF_CAPS( DESID_N_AERO_REF ) + + INTEGER IRULE, ISUR, N, NLEN, ISD, IM, IEM, NRULE + LOGICAL :: LREMOVE + + ! Find Total Number of Size Distribution Registries + N_SD_RULE = 0 + DO IRULE = 1,SIZE( DESID_SD_NML ) + IF ( DESID_SD_NML( IRULE )%STREAM .EQ. '' ) EXIT + N_SD_RULE = IRULE + END DO + + ! First Load all of the Streams with the Default FINE, COARSE, and + ! AERO Mode references + SD = 0 + SD_NAME = '' + + ! Capitalize EM_AERO_REF(:)%NAME + DO IM = 1,DESID_N_AERO_REF + DESID_AERO_REF_CAPS( IM ) = DESID_AERO_REF( IM )%NAME + CALL UPCASE( DESID_AERO_REF_CAPS( IM ) ) + ENDDO + + DO ISRM = 1,DESID_N_SRM + N_SD( ISRM ) = 2 + SD_NAME( ISRM,1 ) = 'FINE' + SD( ISRM,1 ) = INDEX1( 'FINE_REF', DESID_N_AERO_REF, DESID_AERO_REF_CAPS( : ) ) + SD_NAME( ISRM,2 ) = 'COARSE' + SD( ISRM,2 ) = INDEX1( 'COARSE_REF', DESID_N_AERO_REF, DESID_AERO_REF_CAPS( : ) ) + END DO + + ! Now Modify those defaults or add new modes to desired streams + DO IRULE = 1, N_SD_RULE + ! Expand Size Distribution Rule to All Streams if Requested + LREMOVE = .FALSE. + IF ( DESID_SD_NML( IRULE )%STREAM .EQ. '' ) CYCLE + CALL DESID_GET_RULE_STREAMS( DESID_SD_NML( IRULE )%STREAM, IRULE, + & RULE_STREAM, LREMOVE ) + IF ( LREMOVE ) CYCLE + + ! Loop through streams, set defaults, and build map array + DO ISRM = 1, DESID_N_SRM + IF ( RULE_STREAM( ISRM ) ) THEN + ! This Stream is Being Modified by a Size Distribution + ! rule + CALL UPCASE( DESID_SD_NML( IRULE )%MODE_REF ) + IF ( DESID_SD_NML( IRULE )%MODE .EQ. 'FINE' ) THEN + ! Overwrite the FINE mode. All fine particle species + ! will go to this mode by default + SD( ISRM,1 ) = INDEX1( DESID_SD_NML( IRULE )%MODE_REF, + & DESID_N_AERO_REF, DESID_AERO_REF_CAPS( : ) ) + IF ( SD( ISRM,1 ) .EQ. 0 ) THEN + WRITE( XMSG,'(A,A,A,/,A,I2,A)' ), '*** Reference Aerosol Mode (', + & DESID_SD_NML( IRULE )%MODE_REF, 'Specified in Emissions Size ', + & 'Dist Rule ',IRULE,' does not exist in AERO_DATA.' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + ELSEIF ( DESID_SD_NML( IRULE )%MODE .EQ. 'COARSE' ) THEN + ! Overwrite the COARSE mode. All coarse particle + ! species will go to this mode by default + SD( ISRM,2 ) = INDEX1( DESID_SD_NML( IRULE )%MODE_REF, + & DESID_N_AERO_REF, DESID_AERO_REF_CAPS( : ) ) + IF ( SD( ISRM,2 ) .EQ. 0 ) THEN + WRITE( XMSG,'(A,A,A,/,A,I2,A)' ), '*** Reference Aerosol Mode (', + & DESID_SD_NML( IRULE )%MODE_REF, 'Specified in Emissions Size ', + & 'Dist Rule ',IRULE,' does not exist in AERO_DATA.' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + ELSE + ! Add a New Available Mode. For example, add a mode + ! just for BC, call it PUREBC, and make sure the AEC + ! for this stream is pointing to this mode. Also make + ! sure you set AEC for FINE mode aerosol to 0.0 if + ! you have default mapping turned on. + N_SD( ISRM ) = N_SD( ISRM ) + 1 + SD_NAME( ISRM,N_SD( ISRM ) ) = DESID_SD_NML( IRULE )%MODE + SD( ISRM,N_SD( ISRM ) ) = INDEX1( DESID_SD_NML( IRULE )%MODE_REF, + & DESID_N_AERO_REF, DESID_AERO_REF_CAPS( : ) ) + IF ( SD( ISRM,N_SD( ISRM )) .EQ. 0 ) THEN + WRITE( XMSG,'(A,A,A,/,A,I2,A)' ), '*** Reference Aerosol Mode (', + & DESID_SD_NML( IRULE )%MODE_REF, 'Specified in Emissions Size ', + & 'Dist Rule ',IRULE,' does not exist in AERO_DATA.' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + END IF + END IF + END DO + END DO + + ! Finally, transfer this data to a global variable which + ! captures and organizes the modes of each stream + ALLOCATE( DESID_STREAM_AERO( DESID_N_SRM ) ) + DO ISRM = 1,DESID_N_SRM + N = N_SD( ISRM ) + DESID_STREAM_AERO( ISRM )%LEN = N + 1 + ALLOCATE( DESID_STREAM_AERO( ISRM )%NAME( N+1 ) ) + ALLOCATE( DESID_STREAM_AERO( ISRM )%REF( N+1 ) ) + ALLOCATE( DESID_STREAM_AERO( ISRM )%FACNUM( N+1,N_MODE ) ) + ALLOCATE( DESID_STREAM_AERO( ISRM )%FACSRF( N+1,N_MODE ) ) + + DESID_STREAM_AERO( ISRM )%NAME( 2:N+1 ) = SD_NAME( ISRM,1:N ) + DESID_STREAM_AERO( ISRM )%REF( 2:N+1 ) = SD( ISRM,1:N ) + DESID_STREAM_AERO( ISRM )%NAME( 1 ) = 'GAS' + DESID_STREAM_AERO( ISRM )%REF( 1 ) = 0 + + ! Map Factors for Converting Aerosol Mass to Number and + ! Surface Area to each Emission Stream + DESID_STREAM_AERO( ISRM )%FACNUM( :,: ) = 0.0 + DESID_STREAM_AERO( ISRM )%FACSRF( :,: ) = 0.0 + DO ISD = 2,N+1 + IEM = DESID_STREAM_AERO( ISRM )%REF( ISD ) + DO IM = 1,N_MODE + DESID_STREAM_AERO( ISRM )%FACNUM( ISD,IM ) = FACNUM( IEM,IM ) + DESID_STREAM_AERO( ISRM )%FACSRF( ISD,IM ) = FACSRF( IEM,IM ) + END DO + END DO + END DO + + END SUBROUTINE DESID_INIT_SIZE_DIST + + +C----------------------------------------------------------------------- + + SUBROUTINE DESID_SIZE_DIST ( ISRM, VDEMIS, NL ) + +C EMISS_SIZE_DIST distributes bulk aerosol emissions into size space +C using parameters precompiled in the AERO_DATA module. +C +C Revision History: + +C 16 AUG 17 BMURPHY: Created +C +C ---------------------------------------------------------------------- + + USE AERO_DATA, ONLY: AEROSPC, N_AEROSPC, AEROSPC_MWINV + USE AEROMET_DATA, ONLY: F6DPI + USE ASX_DATA_MOD, ONLY: MET_DATA + USE DESID_VARS, ONLY: DESID_N_ISTR, IDUSTSRM, ISEASRM + USE GRID_CONF, ONLY: NCOLS, NROWS + USE SSEMIS, ONLY: SEA_FACTNUM, SEA_FACTSRF + + INTEGER, INTENT( IN ) :: ISRM, NL + REAL, INTENT( INOUT ) :: VDEMIS ( :,:,:,: ) + + INTEGER :: N, S, IAERO, IM, ISD, ISTR ! Looping Variables + INTEGER :: ROW, COL, LAY, N_SD, INUM, ISRF + REAL :: FACNUM, FACSRF, MW_FAC + REAL, ALLOCATABLE :: EMISM3( :,:,:,:,: ) + REAL, ALLOCATABLE, SAVE :: GSFAC( :,:,: ) + REAL, ALLOCATABLE, SAVE :: DENS_FAC( : ) + REAL, PARAMETER :: F6DPIM9 = 1.0E-9 * F6DPI ! 1.0E-9 = Kg/ug + LOGICAL, SAVE :: FIRST_TIME = .TRUE. + +C *** Initialize Variables + IF ( FIRST_TIME ) THEN + FIRST_TIME = .FALSE. + ALLOCATE( GSFAC ( DESID_LAYS,NCOLS,NROWS ) ) + + ALLOCATE( DENS_FAC( N_AEROSPC ) ) + DO IAERO = 1,N_AEROSPC + DENS_FAC( IAERO ) = F6DPIM9 / AEROSPC( IAERO )%DENSITY + END DO + + END IF + + N_SD = DESID_STREAM_AERO( ISRM )%LEN + ALLOCATE( EMISM3( DESID_LAYS,NCOLS,NROWS,N_MODE,N_SD ) ) + EMISM3 = 0.0 + +C *** Calculate scaling factor for converting mass emissions into [ug/m3/s] +C note: RJACM converts grid heights from sigma coordinates to meters +C Also calculate scaling factors for converting to molar-mixing-ratio units + DO LAY = 1,NL + GSFAC( LAY,:,: ) = Met_Data%RJACM( :,:,LAY ) / CELLVOL( :,:,LAY ) ![ug/s] to [ug/m3/s] + END DO + +C *** Apply Aerosol Size Distribution + DO ISTR = 1, DESID_N_ISTR + ! Find which Size Distribution or Phase this emissions species belongs + ! to for this stream. If the value is a 0, then there are no emissions + ! for this species from this stream. If it is a 1, then this species is + ! a gas and the following aerosol conversions should be skipped. + ISD = MAP_ISTRtoSD( ISTR,ISRM ) + IF ( ISD .LE. 1 ) CYCLE + + ! Look up Aerosol Species and Mode of Interest + IAERO = MAP_ISTRtoAERO( ISTR ) !This maps to the CMAQ aerosol + ! species so we can retrieve density + IM = MAP_ISTRtoMODE( ISTR ) !This maps to the internal CMAQ modes + ! (ie. I, J, and K) + !DENS_FAC = F6DPIM9 / AEROSPC( IAERO )%DENSITY + + ! Convert Aerosol from [g/s] to [ug/m3/s] for all streams + ! except Dust and Sea Spray. For those streams, convert + ! [g/m3/s] to [ug/m3/s] + VDEMIS( ISTR,1:NL,:,: ) = VDEMIS( ISTR,1:NL,:,: ) * 1.0E6 + IF ( ISRM .NE. ISEASRM .AND. ISRM .NE. IDUSTSRM ) THEN + VDEMIS( ISTR,1:NL,:,: ) = VDEMIS( ISTR,1:NL,:,: ) * GSFAC( 1:NL,:,: ) + END IF + + ! Sum Total Volume of Mode N [m3/m3/s] + IF ( .NOT. AEROSPC( IAERO )%TRACER ) + & EMISM3( 1:NL,:,:,IM,ISD ) = EMISM3( 1:NL,:,:,IM,ISD ) + + & VDEMIS( ISTR,1:NL,:,: ) * DENS_FAC( IAERO ) + + ! Convert Mass Emission Rates from [ug/m3/s] to [umol/m3/s] + VDEMIS( ISTR,1:NL,:,: ) = VDEMIS( ISTR,1:NL,:,: ) * AEROSPC_MWINV( IAERO ) + END DO + +C *** Calculate the number emissions rate for each mode [1/m3/s], using +C Equation 7b of Binkowski & Roselle (2003). +C Calculate the surface area emissions rate for the fine modes [m2/m3/s], +C using Equation 7c of Binkowski & Roselle (2003). Multiplying by PI +C converts 2nd moment to surface area. + + DO ISD = 2, N_SD ! Skip the Index for the Gas Phase + IF ( ISRM .EQ. ISEASRM ) THEN + ! Apply Spatially-Dependent Number and Surface Area Scale Factors + DO IM = 1, N_MODE + INUM = MAP_NUMtoISTR(IM) + VDEMIS( INUM,1,:,: ) = VDEMIS( INUM,1,:,: ) + & + EMISM3( 1,:,:,IM,ISD ) * SEA_FACTNUM( IM,:,: ) + + ISRF = MAP_SRFtoISTR(IM) + VDEMIS( ISRF,1,:,: ) = VDEMIS( ISRF,1,:,: ) + & + EMISM3( 1,:,:,IM,ISD ) * SEA_FACTSRF( IM,:,: ) + END DO + ELSE + ! Apply Homogeneous Scale Factors Consistent with this Stream + DO IM = 1, N_MODE + INUM = MAP_NUMtoISTR(IM) + FACNUM = DESID_STREAM_AERO( ISRM )%FACNUM( ISD,IM ) + VDEMIS( INUM,1:NL,:,: ) = VDEMIS( INUM,1:NL,:,: ) + EMISM3( 1:NL,:,:,IM,ISD ) * FACNUM + + ISRF = MAP_SRFtoISTR(IM) + FACSRF = DESID_STREAM_AERO( ISRM )%FACSRF( ISD,IM ) + VDEMIS( ISRF,1:NL,:,: ) = VDEMIS( ISRF,1:NL,:,: ) + EMISM3( 1:NL,:,:,IM,ISD ) * FACSRF + END DO + END IF + END DO + + END SUBROUTINE DESID_SIZE_DIST + + END MODULE AERO_EMIS + diff --git a/src/model/src/AERO_PHOTDATA.F b/src/model/src/AERO_PHOTDATA.F index ba1de04..e7acd25 100644 --- a/src/model/src/AERO_PHOTDATA.F +++ b/src/model/src/AERO_PHOTDATA.F @@ -38,16 +38,13 @@ MODULE AERO_PHOTDATA REAL, ALLOCATABLE :: BLK_AE_NI ( :,:,: ) ! mean aerosol imaginary part of refractive index REAL, ALLOCATABLE :: AERO_ASYM_FAC ( :,: ) ! aerosol modal averaged asymmetry factor - REAL, ALLOCATABLE :: AERO_EXTI_COEF( :,: ) ! aerosol modal averaged extinction coeff. - REAL, ALLOCATABLE :: AERO_SCAT_COEF( :,: ) ! aerosol modal averaged scattering coeff. + REAL, ALLOCATABLE :: AERO_EXTI_COEF( :,: ) ! aerosol modal averaged extinction coeff., 1/m + REAL, ALLOCATABLE :: AERO_SCAT_COEF( :,: ) ! aerosol modal averaged scattering coeff., 1/m + REAL, ALLOCATABLE :: AERO_EXTI_550 ( : ) ! aerosol modal averaged extinction coeff. at 550nm, 1/m - LOGICAL :: CORE_SHELL - LOGICAL :: MIE_CALC - PUBLIC :: AERO_ASYM_FAC, AERO_EXTI_COEF, AERO_SCAT_COEF, & INIT_AERO_DATA, GET_AERO_DATA, AERO_OPTICS_INTERNAL - INTEGER, PRIVATE :: LOGDEV ! unit number for the log file INTEGER, ALLOCATABLE, PRIVATE :: REFRACT_INDX_MAP( : ) ! map array for refactive index REAL, ALLOCATABLE, PRIVATE :: VOL_MINS( : ) ! minmum volume permode @@ -56,6 +53,16 @@ MODULE AERO_PHOTDATA INTEGER, PARAMETER, PRIVATE :: NUMB_COR_SPCS = 3 ! number species in core + LOGICAL :: CALCULATE_EXT_550 = .FALSE. ! flag to get extinction at 550 nm + LOGICAL :: USE_ANGSTROM_INTERP = .FALSE. ! flag to use angstrom exponents for 550 nm + + INTEGER :: IWL_ANGSTROM_LOWER = 0 ! index for wavelength less than 550 nm + INTEGER :: IWL_ANGSTROM_UPPER = 0 ! index for wavelength greater than 550 nm + REAL( 8 ) :: ANGSTROM_RATIO = 1.0D0 ! wavelength less than 550 nm divided by 550 nm + REAL( 8 ) :: LOG_ANGSTROM_RATIO = 0.0D0 + REAL( 8 ) :: ANGSTROM_SPAN = 1.0D0 ! reciprocal of log ((wavelength < 550 nm)/(wavelength > 550 nm) + REAL( 8 ) :: ANGSTROM_EXPONENT = 1.0D0 ! Angstrom exponent used to interpolate extinction at 550 nm + C *** Species in aerosol core CHARACTER( 16 ), PARAMETER, PRIVATE :: CORE_SPCS( NUMB_COR_SPCS ) = @@ -84,8 +91,6 @@ SUBROUTINE INIT_AERO_DATA( ) C Local: CHARACTER( 32 ) :: PNAME = 'INIT_AERO_DATA' - CHARACTER( 16 ) :: CORE_SHELL_OPTICS = 'CORESHELL_OPTICS' - CHARACTER( 16 ) :: OPTICS_MIE_CALC = 'MIE_OPTICS' CHARACTER( 120 ) :: XMSG INTEGER :: ALLOCSTAT @@ -103,45 +108,10 @@ SUBROUTINE INIT_AERO_DATA( ) RETURN END IF - LOGDEV = INIT3() JDATE = 0 JTIME = 0 -!...Get flag to use core-shell mixing model for aerosol optical properties - - CORE_SHELL = .FALSE. ! default - XMSG = 'Use core-shell mixing model for aerosol optical properties' - CORE_SHELL = ENVYN( CORE_SHELL_OPTICS, XMSG, CORE_SHELL, ESTAT ) - IF ( ESTAT .NE. 0 ) WRITE( LOGDEV, '(5X, A)' ) XMSG - IF ( ESTAT .EQ. 1 ) THEN - XMSG = 'Environment variable improperly formatted' - CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT2 ) - ELSE IF ( ESTAT .EQ. -1 ) THEN - XMSG = - & 'Environment variable set, but empty ... Using default:' - WRITE( LOGDEV, '(5X, A, L5)' ) XMSG, CORE_SHELL - ELSE IF ( ESTAT .EQ. -2 ) THEN - XMSG = 'Environment variable not set ... Using default:' - WRITE( LOGDEV, '(5X, A, L5)' ) XMSG, CORE_SHELL - END IF -!...Get flag to use fast optics for volume mixing model for aerosol optical properties - - MIE_CALC = .FALSE. ! default - XMSG = 'Use Mie theory for aerosol optical properties of Internal mixing model' - MIE_CALC = ENVYN( OPTICS_MIE_CALC, XMSG, MIE_CALC, ESTAT ) - IF ( ESTAT .NE. 0 ) WRITE( LOGDEV, '(5X, A)' ) XMSG - IF ( ESTAT .EQ. 1 ) THEN - XMSG = 'Environment variable improperly formatted' - CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT2 ) - ELSE IF ( ESTAT .EQ. -1 ) THEN - XMSG = - & 'Environment variable set, but empty ... Using default:' - WRITE( LOGDEV, '(5X, A, L5)' ) XMSG, MIE_CALC - ELSE IF ( ESTAT .EQ. -2 ) THEN - XMSG = 'Environment variable not set ... Using default:' - WRITE( LOGDEV, '(5X, A, L5)' ) XMSG, MIE_CALC - END IF C...Allocate needed arrays ALLOCATE ( VOL_MINS( N_MODE ), STAT = ALLOCSTAT ) @@ -220,6 +190,15 @@ SUBROUTINE INIT_AERO_DATA( ) AERO_EXTI_COEF = 0.0 AERO_ASYM_FAC = 0.0 + IF( CALCULATE_EXT_550 )THEN + ALLOCATE ( AERO_EXTI_550( NLAYS ), STAT = ALLOCSTAT ) + IF ( ALLOCSTAT .NE. 0 ) THEN + XMSG = 'Failure allocating AERO_EXTI_550' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + AERO_EXTI_550 = 0.0 + END IF + CALL MAP_AERO() ALLOCATE( M3_FACTOR( N_AEROSPC ), STAT = ALLOCSTAT ) @@ -330,6 +309,38 @@ SUBROUTINE INIT_AERO_DATA( ) END IF END DO + IF( CALCULATE_EXT_550 )THEN ! locate 550 nm in wavebands and set-up interpolation + IF ( WAVELENGTH( 1 ) .GE. 550.0 ) THEN + IWL_ANGSTROM_LOWER = 1 + ELSE IF ( WAVELENGTH( NWL ) .LE. 550.0 ) THEN + IWL_ANGSTROM_LOWER = NWL + ELSE + LOOP_FINDW: DO V = 1, NWL - 1 + IF ( WAVELENGTH( V ) .LT. 550.0 .AND. WAVELENGTH( V+1 ) .GT. 550.0 ) THEN + IWL_ANGSTROM_LOWER = V + IWL_ANGSTROM_UPPER = V+1 + ANGSTROM_SPAN = REAL( 1.0 / LOG( WAVELENGTH( V ) / WAVELENGTH( V+1 ) ), 8 ) + ANGSTROM_RATIO = REAL( (WAVELENGTH( V ) / 550.0), 8) +! ANGSTROM_RATIO = REAL( (WAVELENGTH( V ) / WAVELENGTH( V+1 )), 8) + LOG_ANGSTROM_RATIO = LOG( ANGSTROM_RATIO ) +! WRITE(LOGDEV,'(A,2(F7.3,1X))')'Angstrom Interpolation Wavelengths: ', +! & WAVELENGTH( IWL_ANGSTROM_LOWER ), WAVELENGTH( IWL_ANGSTROM_UPPER ) +! WRITE(LOGDEV,'(A,2(ES12.4,1X))')'Angstrom Span, Ratio: ', +! & ANGSTROM_SPAN, ANGSTROM_RATIO + USE_ANGSTROM_INTERP = .TRUE. + EXIT LOOP_FINDW + ELSE IF ( WAVELENGTH( V ) .EQ. 550.0 ) THEN + IWL_ANGSTROM_LOWER = V + EXIT LOOP_FINDW + END IF + END DO LOOP_FINDW + END IF + IF( .NOT. USE_ANGSTROM_INTERP )THEN + WRITE(LOGDEV,'(A,2(F7.3,1X))')'No Angstrom Inpolation Used 550 Extinction used at ', + & WAVELENGTH( IWL_ANGSTROM_LOWER ) + END IF + END IF + RETURN 5000 FORMAT(2X,'NR_',I3.3,7X,'NI_',I3.3,5X) @@ -339,7 +350,7 @@ SUBROUTINE INIT_AERO_DATA( ) END SUBROUTINE INIT_AERO_DATA C::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - SUBROUTINE GET_AERO_DATA ( COL, ROW, NLAYS, CGRID ) + SUBROUTINE GET_AERO_DATA ( COL, ROW, NLAYS, DENS, CGRID ) C----------------------------------------------------------------------- C FUNCTION: This subroutine calculates the volume, the natural logs of @@ -404,6 +415,7 @@ SUBROUTINE GET_AERO_DATA ( COL, ROW, NLAYS, CGRID ) INTEGER, INTENT( IN ) :: COL ! specified column index INTEGER, INTENT( IN ) :: ROW ! specified row index INTEGER, INTENT( IN ) :: NLAYS ! # of vertical layers + REAL, INTENT( IN ) :: DENS( :,:,: ) REAL, POINTER :: CGRID( :,:,:,: ) C Parameters: @@ -463,7 +475,9 @@ SUBROUTINE GET_AERO_DATA ( COL, ROW, NLAYS, CGRID ) INTEGER MODE ! aerosol mode loop counter LOGICAL SUCCESS LOGICAL TROUBLE - + LOGICAL, SAVE :: FIRSTCALL = .TRUE. + + #ifdef verbose_phot character( 26 ), allocatable :: lambda_list( : ) #endif @@ -486,16 +500,24 @@ SUBROUTINE GET_AERO_DATA ( COL, ROW, NLAYS, CGRID ) AE_DGN_CORE = 0.0 SUCCESS = .TRUE. - LAY_LOOP1: DO L = 1, NLAYS C *** extract grid cell concentrations of aero species from CGRID into aerospc_conc C *** in aero_data module C Also converts dry surface area to wet second moment +#ifdef sens + CALL EXTRACT_AERO ( CGRID( COL,ROW,L,: ), .TRUE., CGRID( COL,ROW,:,: ), .FALSE. ) +#else CALL EXTRACT_AERO ( CGRID( COL,ROW,L,: ), .TRUE. ) +#endif C *** extract soa concentrations from CGRID + AIRDENS = DENS ( COL,ROW,L ) +#ifdef sens + CALL EXTRACT_SOA ( CGRID( COL,ROW,L,: ), CGRID( COL,ROW,:,: ), .FALSE. ) +#else CALL EXTRACT_SOA ( CGRID( COL,ROW,L,: ) ) +#endif C *** Calculate geometric mean diameters and standard deviations of "wet" size distribution CALL GETPAR ( .FALSE. ) @@ -816,11 +838,11 @@ SUBROUTINE GET_AERO_DATA ( COL, ROW, NLAYS, CGRID ) END DO OPTICS_LOOP AERO_SCAT_COEF( L,V ) = BSCAT - AERO_EXTI_COEF( L,V ) = BEXT + AERO_EXTI_COEF( L,V ) = MAX( BEXT, 1.0E-30 ) AERO_ASYM_FAC ( L,V ) = G_BAR / MAX( BSCAT, 1.0E-30 ) #ifdef verbose_phot_extra - if( l .eq. 1 .and. v .eq. 1 )then + if( l .eq. 1 .and. v .eq. 1)then write(logdev, 9502)l, wavelength( V ), dgn_core, dgn_shell, bext_mode, & bscat_mode, gbar_mode, ae_nr_shell( l, mode, v ), ae_ni_shell( v, mode, v ), & ae_nr_core( l, mode, iv ), ae_ni_core( l, mode, v ) @@ -833,6 +855,37 @@ SUBROUTINE GET_AERO_DATA ( COL, ROW, NLAYS, CGRID ) END DO LAY_LOOP2 END DO LOOP_WAVE + + IF( CALCULATE_EXT_550 )THEN +! IF( USE_ANGSTROM_INTERP .AND. FIRSTCALL )THEN +! WRITE(LOGDEV,'(A,2(F7.3,1X))')'Angstrom Interpolation Wavelengths: ', +! & WAVELENGTH( IWL_ANGSTROM_LOWER ), WAVELENGTH( IWL_ANGSTROM_UPPER ) +! WRITE(LOGDEV,'(A,2(ES12.4,1X))')'Angstrom Span, Ratio: ', +! & ANGSTROM_SPAN, ANGSTROM_RATIO +! END IF + LOOP_550NM: DO L = 1, NLAYS + IF( USE_ANGSTROM_INTERP )THEN + ANGSTROM_EXPONENT = - REAL( LOG( AERO_EXTI_COEF( L,IWL_ANGSTROM_LOWER ) + & / AERO_EXTI_COEF( L,IWL_ANGSTROM_UPPER ) ), 8 ) + & * ANGSTROM_SPAN +! AERO_EXTI_550( L ) = LOG( AERO_EXTI_COEF( L,IWL_ANGSTROM_LOWER ) ) +! & + REAL( ANGSTROM_EXPONENT * LOG_ANGSTROM_RATIO, 4 ) +! AERO_EXTI_550( L ) = EXP( AERO_EXTI_550( L ) ) + AERO_EXTI_550( L ) = AERO_EXTI_COEF( L,IWL_ANGSTROM_LOWER ) + & * REAL( ANGSTROM_RATIO ** ANGSTROM_EXPONENT, 4 ) +! IF ( FIRSTCALL ) THEN +! WRITE( LOGDEV,'(I3,A,7(ES12.4,1X))')L, +! & ' AERO_EXT_LOWER,AERO_EXT_UPPER,EXPONENT,EXPONENT*LOG(RATIO),EXT_550_1,EXT_550_2: ', +! & AERO_EXTI_COEF( L,IWL_ANGSTROM_LOWER ), AERO_EXTI_COEF( L,IWL_ANGSTROM_UPPER ), +! & ANGSTROM_EXPONENT,REAL( ANGSTROM_EXPONENT * LOG_ANGSTROM_RATIO,4),AERO_EXTI_550( L ), +! & AERO_EXTI_COEF( L,IWL_ANGSTROM_LOWER)*ANGSTROM_RATIO ** ANGSTROM_EXPONENT +! END IF + ELSE + AERO_EXTI_550( L ) = AERO_EXTI_COEF( L,IWL_ANGSTROM_LOWER ) + END IF + END DO LOOP_550NM +! IF ( FIRSTCALL ) FIRSTCALL = .FALSE. + END IF #ifdef verbose_phot if ( col .eq. 1 .and. row .eq. 1 ) then @@ -1003,10 +1056,18 @@ SUBROUTINE AERO_OPTICS_INTERNAL ( COL, ROW, NLAYS, CGRID ) C *** extract grid cell concentrations of aero species from CGRID into aerospc_conc C *** in aero_data module C Also converts surface area to wet second moment +#ifdef sens + CALL EXTRACT_AERO ( CGRID( COL,ROW,L,: ), .TRUE., CGRID( COL,ROW,:,: ), .FALSE. ) +#else CALL EXTRACT_AERO ( CGRID( COL,ROW,L,: ), .TRUE. ) +#endif C *** extract soa concentrations from CGRID +#ifdef sens + CALL EXTRACT_SOA ( CGRID( COL,ROW,L,: ), CGRID( COL,ROW,:,: ), .FALSE. ) +#else CALL EXTRACT_SOA ( CGRID( COL,ROW,L,: ) ) +#endif C *** Calculate geometric mean diameters and standard deviations of "wet" size distribution CALL GETPAR ( .FALSE. ) @@ -1336,7 +1397,7 @@ SUBROUTINE FASTER_OPTICS ( NR, NI, ALPHV, XLNSIG, BETA_EXT, BETA_SCAT, G ) REAL T1F1, T2F1, T1F2, T2F2, T1F3, T2F3 REAL T1G1, T2G1, T1G2, T2G2, T1G3, T2G3, T1G4, T2G4 REAL T1G5, T2G5 - REAL(8) T1P1, T2P1 + REAL(8) T1P1, T2P1 !(Wei Li) C***the following are for calculating the Penndorff Coefficients @@ -1425,7 +1486,7 @@ SUBROUTINE FASTER_OPTICS ( NR, NI, ALPHV, XLNSIG, BETA_EXT, BETA_SCAT, G ) REAL QQSUM, QQF1,QQF2, QQF3, QQCORR REAL, PARAMETER :: DEGTORAD = PI180 - REAL(8), PARAMETER :: THREE_PI_TWO = 3.0 * PI / 2.0 + REAL(8), PARAMETER :: THREE_PI_TWO = 3.0 * PI / 2.0 !(Wei Li) C***FSB start calculation SIGMA_G = EXP( XLNSIG ) @@ -1473,11 +1534,11 @@ SUBROUTINE FASTER_OPTICS ( NR, NI, ALPHV, XLNSIG, BETA_EXT, BETA_SCAT, G ) ALPHA_I = F2 BEXT = B BSCAT = B - PENN1 = DBLE(0.0) - PENN2 = DBLE(0.0) + PENN1 = DBLE(0.0) !(Wei Li) + PENN2 = DBLE(0.0) !(Wei Li) - ALPHV2 = DBLE(ALPHV * ALPHV) - ALPHV3 = DBLE(ALPHV2 * ALPHV) + ALPHV2 = DBLE(ALPHV * ALPHV) !(Wei Li) + ALPHV3 = DBLE(ALPHV2 * ALPHV) !(Wei Li) IF ( NI .GT. 0.0 ) THEN @@ -1544,14 +1605,14 @@ SUBROUTINE FASTER_OPTICS ( NR, NI, ALPHV, XLNSIG, BETA_EXT, BETA_SCAT, G ) EXPFAC2 = EXP( 2.0 * XLNSIG2 ) EXPFAC3 = EXP( 4.5 * XLNSIG2 ) - T1P1 = DBLE(A1 + A2 * ALPHV2 * EXPFAC2) - T2P1 = DBLE(A3 * ALPHV3 * EXPFAC3) + T1P1 = DBLE(A1 + A2 * ALPHV2 * EXPFAC2) !(Wei Li) + T2P1 = DBLE(A3 * ALPHV3 * EXPFAC3) !(Wei Li) C***PENN1 is the analytic integral of the Pendorff formulae over C*** a log normal particle size distribution. - PENN1 = DBLE(THREE_PI_TWO * ( T1P1 + T2P1 )) - PENN2 = DBLE(THREE_PI_TWO * T2P1) + PENN1 = DBLE(THREE_PI_TWO * ( T1P1 + T2P1 ) ) !(Wei Li) + PENN2 = DBLE(THREE_PI_TWO * T2P1) !(Wei Li) END IF ! test for ni > 0.0 @@ -1791,7 +1852,7 @@ SUBROUTINE FAST_OPTICS( NR, NI, LAMBDA, DGN, SIGMA_G, BETA_EXT, BETA_SCAT, G ) REAL C, CEXT, CSCAT REAL B, BEXT, BSCAT REAL BBFAC - REAL(8) ALPHV + REAL(8) ALPHV !(Wei Li) REAL ALPHA_I REAL A, LOGX2, XLNSIG, XLNSIG2, MM1 @@ -1805,7 +1866,7 @@ SUBROUTINE FAST_OPTICS( NR, NI, LAMBDA, DGN, SIGMA_G, BETA_EXT, BETA_SCAT, G ) REAL LARGEEXT ! large sphere limit for extinction REAL SMALL_G, LARGE_G - REAL(8) ALPHV2, ALPHV3 + REAL(8) ALPHV2, ALPHV3 !(Wei Li) REAL X_ALPHA, X_ALPHA2, X_ALPHA3 REAL FCORR REAL EXPFAC2, EXPFAC3 @@ -1818,12 +1879,12 @@ SUBROUTINE FAST_OPTICS( NR, NI, LAMBDA, DGN, SIGMA_G, BETA_EXT, BETA_SCAT, G ) REAL T1F1, T2F1, T1F2, T2F2, T1F3, T2F3 REAL T1G1, T2G1, T1G2, T2G2, T1G3, T2G3, T1G4, T2G4 REAL T1G5, T2G5 - REAL(8) T1P1, T2P1 + REAL(8) T1P1, T2P1 !(Wei Li) C***the following are for calculating the Penndorff Coefficients REAL A1, A2, A3 - REAL(8) PENN1, PENN2 + REAL(8) PENN1, PENN2 !(Wei Li) REAL XNR, XNI, XNR2, XNI2, XNRI, XNRI2, XNRMI REAL XRI, XRI2, XRI36, XNX, XNX2 REAL Z1, Z12, Z2, XC1 @@ -1908,7 +1969,7 @@ SUBROUTINE FAST_OPTICS( NR, NI, LAMBDA, DGN, SIGMA_G, BETA_EXT, BETA_SCAT, G ) REAL QQSUM, QQF1,QQF2, QQF3, QQCORR REAL, PARAMETER :: DEGTORAD = PI180 - REAL(8), PARAMETER :: THREE_PI_TWO = 3.0 * PI / 2.0 + REAL(8), PARAMETER :: THREE_PI_TWO = 3.0 * PI / 2.0 !(Wei Li) REAL, PARAMETER :: SCALE = 1.00E+9 @@ -1921,9 +1982,9 @@ SUBROUTINE FAST_OPTICS( NR, NI, LAMBDA, DGN, SIGMA_G, BETA_EXT, BETA_SCAT, G ) C***FSB start calculation XLNSIG = LOG( SIGMA_G ) - ALPHV = DBLE(SCALE * PI * DGN * EXP( 3.0 * XLNSIG * XLNSIG ) / LAMBDA) - ALPHV2 = DBLE( ALPHV * ALPHV ) - ALPHV3 = DBLE( ALPHV * ALPHV * ALPHV ) + ALPHV = DBLE(SCALE * PI * DGN * EXP( 3.0 * XLNSIG * XLNSIG ) / LAMBDA) !(Wei Li) + ALPHV2 = DBLE(ALPHV * ALPHV) !(Wei Li) + ALPHV3 = DBLE(ALPHV * ALPHV * ALPHV) !(Wei Li) XLNSIG2 = XLNSIG * XLNSIG A = 0.5 / XLNSIG2 @@ -1963,8 +2024,8 @@ SUBROUTINE FAST_OPTICS( NR, NI, LAMBDA, DGN, SIGMA_G, BETA_EXT, BETA_SCAT, G ) ALPHA_I = F2 BEXT = B BSCAT = B - PENN1 = DBLE(0.0) - PENN2 = DBLE(0.0) + PENN1 = DBLE(0.0) !(Wei Li) + PENN2 = DBLE(0.0) !(Wei Li) IF ( NI .GT. 0.0 ) THEN @@ -2018,25 +2079,25 @@ SUBROUTINE FAST_OPTICS( NR, NI, LAMBDA, DGN, SIGMA_G, BETA_EXT, BETA_SCAT, G ) Z12 = Z1 * Z1 Z2 = 4.0 * XNRI2 + 12.0 * XNRMI + 9.0 XC1 = 8.0 / ( 3.0 * Z12 ) - A1 = DBLE(24.0 * XRI / Z1) + A1 = DBLE(24.0 * XRI / Z1) !(Wei Li) - A2 = DBLE(4.0 * XRI / 15.0 + 20.0 * XRI / ( 3.0 * Z2 ) + + A2 = DBLE(44.0 * XRI / 15.0 + 20.0 * XRI / ( 3.0 * Z2 ) + & 4.8 * XRI * ( 7.0 * XNRI2 + - & 4.0 * ( XNRMI - 5.0 ) ) / Z12) + & 4.0 * ( XNRMI - 5.0 ) ) / Z12 ) !(Wei Li) - A3 = DBLE(XC1 * ( XNX2 - XRI36 )) + A3 = DBLE(XC1 * ( XNX2 - XRI36 )) !(Wei Li) EXPFAC2 = EXP( 2.0 * XLNSIG2 ) EXPFAC3 = EXP( 4.5 * XLNSIG2 ) - T1P1 = DBLE(A1 + A2 * ALPHV2 * EXPFAC2) - T2P1 = DBLE(A3 * ALPHV3 * EXPFAC3) + T1P1 = DBLE(A1 + A2 * ALPHV2 * EXPFAC2) !(Wei Li) + T2P1 = DBLE(A3 * ALPHV3 * EXPFAC3) !(Wei Li) C***PENN1 is the analytic integral of the Pendorff formulae over C*** a log normal particle size distribution. - PENN1 = DBLE( THREE_PI_TWO * ( T1P1 + T2P1 ) ) - PENN2 = DBLE( THREE_PI_TWO * T2P1 ) + PENN1 = DBLE(THREE_PI_TWO * ( T1P1 + T2P1 )) !(Wei Li) + PENN2 = DBLE(THREE_PI_TWO * T2P1 ) !(Wei Li) END IF ! test of ni > 0.0 diff --git a/src/model/src/ASX_DATA_MOD.F b/src/model/src/ASX_DATA_MOD.F index 48d9258..8270f49 100644 --- a/src/model/src/ASX_DATA_MOD.F +++ b/src/model/src/ASX_DATA_MOD.F @@ -30,6 +30,8 @@ Module ASX_DATA_MOD C Increased ar for ozone from 8 to 12. C Change meso from 0.1 to 0 for some org. nitrates C Changes based on Nguyen et al. 2015 PNAS and SOAS +C 07 May 2018 D. Schwede: Added call to CZANGLE here and removed call +C to CZANGLE in other modules C C---------Notes C * Updates based on literature review 7/96 JEP @@ -70,12 +72,20 @@ Module ASX_DATA_MOD C formulas. W. Hutzell (04/08) C %% G. Sarwar: added data for iodine and bromine species (03/2016) C %% B. Hutzell: added dry deposition data for methane, acrylic acid, methyl chloride, -C and acetonitrile (09/2016) +C and acetonitrile (09/2016) +C G. Sarwar: added ClNO3 and FMBR, and updated INO3 and BRNO3 name changes (07/2018) +C G. Sarwar: removed NACL (07/2018) +C G. Sarwar: made minor changes to halogen species and added several iodine species (12/2018) +C D. Wong: Implemented centralized I/O approach, removed all MY_N clauses, removed +C unnecessary SAVE attribute (02/2019) +C G. Sarwar: Removed CH3BR (03/2021) +C R. Gilliam: Include PX soil texture information when available (03/2022) C------------------------------------------------------------------------------- - + Use RUNTIME_VARS Use GRID_CONF ! horizontal & vertical domain specifications Use LSM_MOD ! Land surface data Use DEPVVARS, Only: ltotg + Use CENTRALIZED_IO_MODULE Implicit None @@ -83,16 +93,16 @@ Module ASX_DATA_MOD Type :: MET_Type !> 2-D meteorological fields: - Real, Allocatable :: RDEPVHT ( :,: ) ! air dens / dep vel ht + Real, Allocatable :: RDEPVHT ( :,: ) ! reciprocal layer 1 height [m-1] Real, Allocatable :: DENS1 ( :,: ) ! layer 1 air density Real, Allocatable :: PRSFC ( :,: ) ! surface pressure [Pa] Real, Allocatable :: Q2 ( :,: ) ! 2 meter water vapor mixing ratio [kg/kg] Real, Allocatable :: QSS_GRND ( :,: ) ! ground saturation water vapor mixing ratio [kg/kg] - Real, Allocatable :: RH ( :,: ) ! relative humidity [ratio] - Real, Allocatable :: RA ( :,: ) ! aerodynamic resistnace [s/m] - Real, Allocatable :: RS ( :,: ) ! stomatal resistnace [s/m] + Real, Allocatable :: RH2 ( :,: ) ! relative humidity [percent] + Real, Allocatable :: RA ( :,: ) ! aerodynamic resistance [s/m] + Real, Allocatable :: RS ( :,: ) ! stomatal resistance [s/m] Real, Allocatable :: RC ( :,: ) ! convective precipitation [cm] - Real, Allocatable :: RN ( :,: ) ! non-convective precipitation [mc] + Real, Allocatable :: RN ( :,: ) ! non-convective precipitation [cm] Real, Allocatable :: RGRND ( :,: ) ! Solar radiation at the ground [W/m**2] Real, Allocatable :: HFX ( :,: ) ! Sensible heat flux [W/m**2] Real, Allocatable :: LH ( :,: ) ! Latent heat flux [W/m**2] @@ -119,9 +129,11 @@ Module ASX_DATA_MOD Integer, Allocatable :: LPBL ( :,: ) ! PBL layer Logical, Allocatable :: CONVCT ( :,: ) ! convection flag Real, Allocatable :: PBL ( :,: ) ! pbl height (m) - Real, Allocatable :: NACL_EMIS( :,: ) ! NACL mass emission rate of particles with d <10 um (g/m2/s) +! Real, Allocatable :: NACL_EMIS( :,: ) ! NACL mass emission rate of particles with d <10 um (g/m2/s) + Real, Allocatable :: COSZEN ( :,: ) ! Cosine of the zenith angle + Real, Allocatable :: CFRAC ( :,: ) ! cloud fraction -!> Inline Canopy Processes +!> Inline Canopy Processes (Wei Li) Real, Allocatable :: FCH ( :,: ) ! Forest Canopy Height (m) Real, Allocatable :: FRT ( :,: ) ! Forest Fraction Real, Allocatable :: CLU ( :,: ) ! Clumping Index @@ -132,9 +144,9 @@ Module ASX_DATA_MOD Real, Allocatable :: C3R ( :,: ) ! cumulative LAI fraction hc to 0.35 * hc Real, Allocatable :: C4R ( :,: ) ! cumulative LAI fraction hc to 0.20 * hc -!> FENGSHA option - Real, Allocatable :: CLAYF ( :,: ) ! Fractional Clay Content - Real, Allocatable :: SANDF ( :,: ) ! Fractional Sand Content +!> FENGSHA option (Wei Li) + Real, Allocatable :: CLAYF ( :,: ) ! Fractional Clay Content + Real, Allocatable :: SANDF ( :,: ) ! Fractional Sand Content Real, Allocatable :: DRAG ( :,: ) ! Drag Partion Real, Allocatable :: UTHR ( :,: ) ! Dry Threshold Friction Velocity @@ -143,21 +155,22 @@ Module ASX_DATA_MOD Real, Allocatable :: VWIND ( :,:,: ) ! [m/s] !> 3-D meteorological fields: Real, Allocatable :: KZMIN ( :,:,: ) ! minimum Kz [m**2/s] - Real, Allocatable :: PRES ( :,:,: ) ! layer 1 pressure [Pa] - Real, Allocatable :: PRESF ( :,:,: ) ! full layer pressure [Pa] + Real, Allocatable :: PRES ( :,:,: ) ! pressure [Pa] + Real, Allocatable :: PRESF ( :,:,: ) ! full layer pressure [Pa] (Wei Li) Real, Allocatable :: QV ( :,:,: ) ! water vapor mixing ratio Real, Allocatable :: QC ( :,:,: ) ! cloud water mixing ratio Real, Allocatable :: THETAV ( :,:,: ) ! potential temp Real, Allocatable :: TA ( :,:,: ) ! temperature (K) + Real, Allocatable :: RH ( :,:,: ) ! relative humidity [ratio] Real, Allocatable :: ZH ( :,:,: ) ! mid-layer height above ground [m] Real, Allocatable :: ZF ( :,:,: ) ! layer height [m] - Real, Allocatable :: DZF ( :,:,: ) ! layer surface thickness + Real, Allocatable :: DZF ( :,:,: ) ! layer thickness Real, Allocatable :: DENS ( :,:,: ) ! air density Real, Allocatable :: RJACM ( :,:,: ) ! reciprocal mid-layer Jacobian Real, Allocatable :: RJACF ( :,:,: ) ! reciprocal full-layer Jacobian Real, Allocatable :: RRHOJ ( :,:,: ) ! reciprocal density X Jacobian - Real, Allocatable :: UWINDA ( :,:,: ) ! [m/s] - Real, Allocatable :: VWINDA ( :,:,: ) ! [m/s] + Real, Allocatable :: UWINDA ( :,:,: ) ! [m/s] (Wei Li) + Real, Allocatable :: VWINDA ( :,:,: ) ! [m/s] (Wei Li) End Type MET_Type Type :: GRID_Type @@ -171,61 +184,28 @@ Module ASX_DATA_MOD Real, Allocatable :: LON ( :,: ) ! longitude Real, Allocatable :: LAT ( :,: ) ! latitude Real, Allocatable :: LWMASK ( :,: ) ! land water mask - Real, Allocatable :: OCEAN ( :,: ) ! Open ocean - Real, Allocatable :: SZONE ( :,: ) ! Surf zone + Real, Allocatable :: OCEAN ( :,: ) ! Open ocean fraction + Real, Allocatable :: SZONE ( :,: ) ! Surf zone fraction Real, Allocatable :: PURB ( :,: ) ! percent urban [%] Integer, Allocatable :: SLTYP ( :,: ) ! soil type [category] - Real, Allocatable :: WSAT ( :,: ) ! soil wilting point + Real, Allocatable :: WSAT ( :,: ) ! volumetric soil saturation concentration Real, Allocatable :: WWLT ( :,: ) ! soil wilting point Real, Allocatable :: BSLP ( :,: ) ! B Slope Real, Allocatable :: WRES ( :,: ) ! Soil residual moisture point Real, Allocatable :: WFC ( :,: ) ! soil field capacity + Real, Allocatable :: CLAY_PX ( :,: ) ! Clay fraction from PX LSM + Real, Allocatable :: CSAND_PX ( :,: ) ! Coarse sand fraction from PX LSM + Real, Allocatable :: FMSAND_PX( :,: ) ! Fine-medium sand fraction from PX LSM ! Real, Allocatable :: RHOB ( :,: ) ! soil bulk density - Real, Allocatable :: LUFRAC ( :,:,: ) ! land use fraction (col,row,lu_type)[ratio] + Real, Allocatable :: LUFRAC ( :,:,: ) ! land use fraction (col,row,lu_type)[ratio] C Land use information: Character( 16 ), Allocatable :: NAME ( : ) ! LU name Character( 16 ), Allocatable :: LU_Type ( : ) ! general land use type e.g. water, forest, etc. End Type GRID_Type - Type :: MOSAIC_Type ! (col,row,lu) - Character( 16 ), Allocatable :: NAME ( : ) ! LU name - Character( 16 ), Allocatable :: LU_Type ( : ) ! general land use type e.g. water, forest, etc. -!> Sub grid cell meteorological variables: - Real, Allocatable :: USTAR ( :,:,: ) ! surface friction velocity [m/s] - Real, Allocatable :: LAI ( :,:,: ) ! leaf area index [m**2/m**2] - Real, Allocatable :: VEG ( :,:,: ) ! vegetation fraction [ratio] - Real, Allocatable :: Z0 ( :,:,: ) ! vegetation fraction [ratio] - Real, Allocatable :: DELTA ( :,:,: ) ! Surface wetness [ratio] -!> Sub grid cell resistances - Real, Allocatable :: RA ( :,:,: ) ! aerodynamic resistance [s/m] - Real, Allocatable :: RSTW ( :,:,: ) ! Stomatal Resistance of water [s/m] - Real, Allocatable :: RINC ( :,:,: ) ! In-canopy resistance [s/m] - End Type MOSAIC_Type - - Type :: ChemMos_Type ! (col,row,lu,spc) - Character( 16 ), Allocatable :: NAME ( : ) ! LU name - Character( 16 ), Allocatable :: Lu_Type ( : ) ! general land use type e.g. water, forest, etc. - Character( 16 ), Allocatable :: SubName ( : ) ! Deposition species name -!> Sub grid cell chemically dependent resistances - Real, Allocatable :: Rb ( :,:,:,: ) ! quasi-laminar boundary layer resistance [s/m] - Real, Allocatable :: Rst ( :,:,:,: ) ! stomatal resistance [s/m] - Real, Allocatable :: Rgc ( :,:,:,: ) ! Canopy covered soil resistance [s/m] - Real, Allocatable :: Rgb ( :,:,:,: ) ! Barron soil resistance [s/m] - Real, Allocatable :: Rcut ( :,:,:,: ) ! soil resistance [s/m] - Real, Allocatable :: Rwat ( :,:,:,: ) ! surface water resistance [s/m] -!> Sub grid cell compensation point - Real, Allocatable :: Catm ( :,:,:,: ) ! Atmospheric [ppm] - Real, Allocatable :: CZ0 ( :,:,:,: ) ! compensation point at Z0 [ppm] - Real, Allocatable :: Cleaf( :,:,:,: ) ! Leaf compensation point [ppm] - Real, Allocatable :: Cstom( :,:,:,: ) ! Stomatal compensation point [ppm] - Real, Allocatable :: Ccut ( :,:,:,: ) ! Cuticular compensation point [ppm] - Real, Allocatable :: Csoil( :,:,:,: ) ! Soil compensation point [ppm] - End Type ChemMos_Type - - Type( MET_Type ), Save :: Met_Data - Type( GRID_Type ), Save :: Grid_Data - Type( MOSAIC_Type ), Save :: Mosaic_Data - Type( ChemMos_Type ), Save :: ChemMos_Data + + Type( MET_Type ) :: Met_Data + Type( GRID_Type ) :: Grid_Data Integer, Save :: n_spc_m3dry = ltotg ! from DEPVVARS module !> M3 asx constants @@ -245,7 +225,7 @@ Module ASX_DATA_MOD Real, Parameter :: rg0 = 1000.0 ! [s/m] Real, Parameter :: rgwet0 = 25000.0 ! [s/m] Real, Parameter :: rsndiff = 10.0 ! snow diffusivity fac - Real, Parameter :: rsnow0 = 1000.0 + Real, Parameter :: rsnow0 = 10000.0 ! Changed from 1000 to 10000 - Helmig et al 2012 Real, Parameter :: svp2 = 17.67 ! from MM5 and WRF Real, Parameter :: svp3 = 29.65 ! from MM5 and WRF Real, Parameter :: rt25inK = 1.0/(stdtemp + 25.0) ! 298.15K = 25C @@ -268,154 +248,293 @@ Module ASX_DATA_MOD Character( 16 ) :: subname ( ltotg ) ! for subroutine HLCONST Logical, Save :: MET_INITIALIZED = .false. - Real, Save :: CONVPA ! Pressure conversion factor file units to Pa - Logical, Save :: MINKZ Logical, Save :: CSTAGUV ! Winds are available with C stagger? - Logical, Save :: ifwr = .false. +! Logical, Save :: ifwr = .false. - Public :: INIT_MET + Public :: INIT_MET, GET_MET - Logical, Private, Save :: ifsst = .false. - Logical, Private, Save :: ifq2 = .false. - Logical, Private, Save :: rinv = .True. - Logical, Private, Save :: iflh = .false. - Integer, Private :: C, R, L, S ! loop induction variables Integer, Private :: SPC Character( 16 ), Private, Save :: vname_rc, vname_rn, vname_uc, vname_vc - Real, Private, Save :: P0 ! reference pressure (100000.0 Pa) for Potential Temperature, note that in meteorology they do not use the SI 1 ATM. - - Integer, Private, Save :: LOGDEV - Integer, Private, Save :: GXOFF, GYOFF ! global origin offset from file - Integer, Private, Save :: STRTCOLMC3, ENDCOLMC3, STRTROWMC3, ENDROWMC3 ! MET_CRO_3D - Integer, Private, Save :: STRTCOLMD3, ENDCOLMD3, STRTROWMD3, ENDROWMD3 ! MET_DOT_3D - Integer, Private, Save :: STRTCOLMC2, ENDCOLMC2, STRTROWMC2, ENDROWMC2 ! MET_CRO_2D - Integer, Private, Save :: STRTCOL_O1, ENDCOL_O1, STRTROW_O1, ENDROW_O1 ! OCEAN_1 - Real, Pointer, Private :: BUFF1D( : ) ! 1D temp var number of layers - Real, Pointer, Private :: BUFF2D( :,: ) ! 2D temp var - Real, Pointer, Private :: BUFF3D( :,:,: ) ! 3D temp var + Real, allocatable, private :: BUFF1D( : ) ! 1D temp var number of layers + Real, allocatable, private :: BUFF2D( :,: ) ! 2D temp var + Real, allocatable, private :: BUFF3D( :,:,: ) ! 3D temp var -! Canopy option control +! Canopy option control (Wei Li) CHARACTER( 20 ), SAVE :: CTM_CANOPY_SHADE = 'CTM_CANOPY_SHADE '! env var for in-line LOGICAL, PUBLIC, SAVE :: CANOPY_SHADE ! flag in-lining canopy shading -! FENGSHA option control +! FENGSHA option control (Wei Li) CHARACTER( 18 ), SAVE :: CTM_WBDUST_FENGSHA = 'CTM_WBDUST_FENGSHA' ! env var for in-line LOGICAL, PUBLIC, SAVE :: FENGSHA ! flag for fengsha option INTEGER IOSX ! i/o and allocate memory status - DATA subname( 1), dif0( 1), ar( 1), meso( 1), lebas( 1) / 'SO2 ', 0.1089, 10.0, 0.0, 35.0/ - DATA subname( 2), dif0( 2), ar( 2), meso( 2), lebas( 2) / 'H2SO4 ', 0.1091, 8000.0, 0.0, 49.0/ - DATA subname( 3), dif0( 3), ar( 3), meso( 3), lebas( 3) / 'NO2 ', 0.1361, 2.0, 0.1, 21.0/ - DATA subname( 4), dif0( 4), ar( 4), meso( 4), lebas( 4) / 'NO ', 0.1802, 2.0, 0.0, 14.0/ - DATA subname( 5), dif0( 5), ar( 5), meso( 5), lebas( 5) / 'O3 ', 0.1444, 12.0, 1.0, 21.0/ - DATA subname( 6), dif0( 6), ar( 6), meso( 6), lebas( 6) / 'HNO3 ', 0.1067, 8000.0, 0.0, 35.0/ - DATA subname( 7), dif0( 7), ar( 7), meso( 7), lebas( 7) / 'H2O2 ', 0.1300,34000.0, 1.0, 28.0/ !ar=34,000 such that r_cut=0.7 s/m as in Nguyen et al. 2015 - DATA subname( 8), dif0( 8), ar( 8), meso( 8), lebas( 8) / 'ACETALDEHYDE ', 0.1111, 10.0, 0.0, 56.0/ - DATA subname( 9), dif0( 9), ar( 9), meso( 9), lebas( 9) / 'FORMALDEHYDE ', 0.1554, 10.0, 0.0, 35.0/ - DATA subname( 10), dif0( 10), ar( 10), meso( 10), lebas( 10) / 'METHYLHYDROPEROX', 0.1179, 10.0, 0.3, 49.0/ !meso change from 0.1 to 0.3, Wolfe and Thornton 2011 ACP per J. Bash - DATA subname( 11), dif0( 11), ar( 11), meso( 11), lebas( 11) / 'PEROXYACETIC_ACI', 0.0868, 20.0, 0.1, 70.0/ - DATA subname( 12), dif0( 12), ar( 12), meso( 12), lebas( 12) / 'ACETIC_ACID ', 0.0944, 20.0, 0.0, 63.0/ - DATA subname( 13), dif0( 13), ar( 13), meso( 13), lebas( 13) / 'NH3 ', 0.1978, 20.0, 0.0, 28.0/ - DATA subname( 14), dif0( 14), ar( 14), meso( 14), lebas( 14) / 'PAN ', 0.0687, 16.0, 0.1, 91.0/ - DATA subname( 15), dif0( 15), ar( 15), meso( 15), lebas( 15) / 'HNO2 ', 0.1349, 20.0, 0.1, 28.0/ - DATA subname( 16), dif0( 16), ar( 16), meso( 16), lebas( 16) / 'CO ', 0.1807, 5.0, 0.0, 14.0/ - DATA subname( 17), dif0( 17), ar( 17), meso( 17), lebas( 17) / 'METHANOL ', 0.1329, 2.0, 0.0, 42.0/ - DATA subname( 18), dif0( 18), ar( 18), meso( 18), lebas( 18) / 'N2O5 ', 0.0808, 5000.0, 0.0, 49.0/ - DATA subname( 19), dif0( 19), ar( 19), meso( 19), lebas( 19) / 'NO3 ', 0.1153, 5000.0, 0.0, 28.0/ - DATA subname( 20), dif0( 20), ar( 20), meso( 20), lebas( 20) / 'GENERIC_ALDEHYDE', 0.0916, 10.0, 0.0, 56.0/ - DATA subname( 21), dif0( 21), ar( 21), meso( 21), lebas( 21) / 'CL2 ', 0.1080, 10.0, 0.0, 49.0/ - DATA subname( 22), dif0( 22), ar( 22), meso( 22), lebas( 22) / 'HOCL ', 0.1300, 10.0, 0.0, 38.5/ - DATA subname( 23), dif0( 23), ar( 23), meso( 23), lebas( 23) / 'HCL ', 0.1510, 8000.0, 0.0, 31.5/ - DATA subname( 24), dif0( 24), ar( 24), meso( 24), lebas( 24) / 'FMCL ', 0.1094, 10.0, 0.0, 45.5/ - DATA subname( 25), dif0( 25), ar( 25), meso( 25), lebas( 25) / 'HG ', 0.1194, 0.1, 0.0, 14.8/ ! lebas not used - DATA subname( 26), dif0( 26), ar( 26), meso( 26), lebas( 26) / 'HGIIGAS ', 0.0976, 8000.0, 0.0, 95.0/ ! estimation from back calculating to get dw25 = 1.04e-5 (Garland et al, 1965) - DATA subname( 27), dif0( 27), ar( 27), meso( 27), lebas( 27) / 'TECDD_2378 ', 0.0525, 2.0, 0.0, 217.0/ - DATA subname( 28), dif0( 28), ar( 28), meso( 28), lebas( 28) / 'PECDD_12378 ', 0.0508, 2.0, 0.0, 234.5/ - DATA subname( 29), dif0( 29), ar( 29), meso( 29), lebas( 29) / 'HXCDD_123478 ', 0.0494, 2.0, 0.0, 252.0/ - DATA subname( 30), dif0( 30), ar( 30), meso( 30), lebas( 30) / 'HXCDD_123678 ', 0.0494, 2.0, 0.0, 252.0/ - DATA subname( 31), dif0( 31), ar( 31), meso( 31), lebas( 31) / 'HXCDD_123478 ', 0.0494, 2.0, 0.0, 252.0/ - DATA subname( 32), dif0( 32), ar( 32), meso( 32), lebas( 32) / 'HPCDD_1234678 ', 0.0480, 2.0, 0.0, 269.5/ - DATA subname( 33), dif0( 33), ar( 33), meso( 33), lebas( 33) / 'OTCDD ', 0.0474, 2.0, 0.0, 287.0/ - DATA subname( 34), dif0( 34), ar( 34), meso( 34), lebas( 34) / 'TECDF_2378 ', 0.0534, 2.0, 0.0, 210.0/ - DATA subname( 35), dif0( 35), ar( 35), meso( 35), lebas( 35) / 'PECDF_12378 ', 0.0517, 2.0, 0.0, 227.5/ - DATA subname( 36), dif0( 36), ar( 36), meso( 36), lebas( 36) / 'PECDF_23478 ', 0.0517, 2.0, 0.0, 227.5/ - DATA subname( 37), dif0( 37), ar( 37), meso( 37), lebas( 37) / 'HXCDF_123478 ', 0.0512, 2.0, 0.0, 245.0/ - DATA subname( 38), dif0( 38), ar( 38), meso( 38), lebas( 38) / 'HXCDF_123678 ', 0.0512, 2.0, 0.0, 245.0/ - DATA subname( 39), dif0( 39), ar( 39), meso( 39), lebas( 39) / 'HXCDF_234678 ', 0.0512, 2.0, 0.0, 245.0/ - DATA subname( 40), dif0( 40), ar( 40), meso( 40), lebas( 40) / 'HXCDF_123789 ', 0.0512, 2.0, 0.0, 245.0/ - DATA subname( 41), dif0( 41), ar( 41), meso( 41), lebas( 41) / 'HPCDF_1234678 ', 0.0487, 2.0, 0.0, 262.5/ - DATA subname( 42), dif0( 42), ar( 42), meso( 42), lebas( 42) / 'HPCDF_1234789 ', 0.0487, 2.0, 0.0, 262.5/ - DATA subname( 43), dif0( 43), ar( 43), meso( 43), lebas( 43) / 'OTCDF ', 0.0474, 2.0, 0.0, 280.0/ - DATA subname( 44), dif0( 44), ar( 44), meso( 44), lebas( 44) / 'NAPHTHALENE ', 0.0778, 4.0, 0.0, 119.0/ - DATA subname( 45), dif0( 45), ar( 45), meso( 45), lebas( 45) / '1NITRONAPHTHALEN', 0.0692, 4.0, 0.0, 133.0/ - DATA subname( 46), dif0( 46), ar( 46), meso( 46), lebas( 46) / '2NITRONAPHTHALEN', 0.0692, 4.0, 0.0, 133.0/ - DATA subname( 47), dif0( 47), ar( 47), meso( 47), lebas( 47) / '14NAPHTHOQUINONE', 0.0780, 4.0, 0.0, 119.0/ - DATA subname( 48), dif0( 48), ar( 48), meso( 48), lebas( 48) / 'HEXAMETHYLE_DIIS', 0.0380, 10.0, 0.0, 196.0/ - DATA subname( 49), dif0( 49), ar( 49), meso( 49), lebas( 49) / 'HYDRAZINE ', 0.4164, 20.0, 0.0, 42.0/ - DATA subname( 50), dif0( 50), ar( 50), meso( 50), lebas( 50) / 'MALEIC_ANHYDRIDE', 0.0950, 10.0, 0.0, 70.0/ - DATA subname( 51), dif0( 51), ar( 51), meso( 51), lebas( 51) / '24-TOLUENE_DIIS ', 0.0610, 10.0, 0.0, 154.0/ - DATA subname( 52), dif0( 52), ar( 52), meso( 52), lebas( 52) / 'TRIETHYLAMINE ', 0.0881, 20.0, 0.0, 154.0/ - DATA subname( 53), dif0( 53), ar( 53), meso( 53), lebas( 53) / 'ORG_NTR ', 0.0607, 16.0, 0.0, 160.0/ ! assumes 58.2% C5H11O4N and 41.8% C5H11O3N - DATA subname( 54), dif0( 54), ar( 54), meso( 54), lebas( 54) / 'HYDROXY_NITRATES', 0.0609, 16.0, 0.0, 156.1/ - DATA subname( 55), dif0( 55), ar( 55), meso( 55), lebas( 55) / 'MPAN ', 0.0580, 16.0, 0.1, 133.0/ - DATA subname( 56), dif0( 56), ar( 56), meso( 56), lebas( 56) / 'PPN ', 0.0631, 16.0, 0.1, 118.2/ - DATA subname( 57), dif0( 57), ar( 57), meso( 57), lebas( 57) / 'MVK ', 0.0810, 8.0, 1.0, 88.8/ - DATA subname( 58), dif0( 58), ar( 58), meso( 58), lebas( 58) / 'DINTR ', 0.0617, 16.0, 0.1, 169.8/ - DATA subname( 59), dif0( 59), ar( 59), meso( 59), lebas( 59) / 'NTR_ALK ', 0.0688, 16.0, 0.1, 133.0/ - DATA subname( 60), dif0( 60), ar( 60), meso( 60), lebas( 60) / 'NTR_OH ', 0.0665, 16.0, 0.1, 140.4/ - DATA subname( 61), dif0( 61), ar( 61), meso( 61), lebas( 61) / 'HYDROXY_NITRATES', 0.0646, 16.0, 0.0, 147.8/ - DATA subname( 62), dif0( 62), ar( 62), meso( 62), lebas( 62) / 'PROPNN ', 0.0677, 16.0, 0.0, 133.0/ - DATA subname( 63), dif0( 63), ar( 63), meso( 63), lebas( 63) / 'NITRYL_CHLORIDE ', 0.0888, 8.0, 0.0, 45.5/ ! dif0 estimated following Erickson III et al., JGR, 104, D7, 8347-8372, 1999 - DATA subname( 64), dif0( 64), ar( 64), meso( 64), lebas( 64) / 'ISOPNN ',0.0457, 8.0, 0.0, 206.8/ - DATA subname( 65), dif0( 65), ar( 65), meso( 65), lebas( 65) / 'MTNO3 ',0.0453, 8.0, 0.0, 251.2/ - DATA subname( 66), dif0( 66), ar( 66), meso( 66), lebas( 66) / 'IEPOX ',0.0579, 8.0, 0.0, 110.8/ - DATA subname( 67), dif0( 67), ar( 67), meso( 67), lebas( 67) / 'HACET ',0.1060, 8.0, 0.0, 72.6/ ! dif0 from Nguyen 2015 PNAS - DATA subname( 68), dif0( 68), ar( 68), meso( 68), lebas( 68) / 'SVALK1 ',0.0514, 20.0, 0.0, 280.5/ - DATA subname( 69), dif0( 69), ar( 69), meso( 69), lebas( 69) / 'SVALK2 ',0.0546, 20.0, 0.0, 275.6/ - DATA subname( 70), dif0( 70), ar( 70), meso( 70), lebas( 70) / 'SVBNZ1 ',0.0642, 20.0, 0.0, 134.1/ - DATA subname( 71), dif0( 71), ar( 71), meso( 71), lebas( 71) / 'SVBNZ2 ',0.0726, 20.0, 0.0, 127.5/ - DATA subname( 72), dif0( 72), ar( 72), meso( 72), lebas( 72) / 'SVISO1 ',0.0733, 20.0, 0.0, 126.3/ - DATA subname( 73), dif0( 73), ar( 73), meso( 73), lebas( 73) / 'SVISO2 ',0.0729, 20.0, 0.0, 123.8/ - DATA subname( 74), dif0( 74), ar( 74), meso( 74), lebas( 74) / 'SVPAH1 ',0.0564, 20.0, 0.0, 235.7/ - DATA subname( 75), dif0( 75), ar( 75), meso( 75), lebas( 75) / 'SVPAH2 ',0.0599, 20.0, 0.0, 231.5/ - DATA subname( 76), dif0( 76), ar( 76), meso( 76), lebas( 76) / 'SVSQT ',0.0451, 20.0, 0.0, 346.5/ - DATA subname( 77), dif0( 77), ar( 77), meso( 77), lebas( 77) / 'SVTOL1 ',0.0637, 20.0, 0.0, 153.7/ - DATA subname( 78), dif0( 78), ar( 78), meso( 78), lebas( 78) / 'SVTOL2 ',0.0607, 20.0, 0.0, 194.1/ - DATA subname( 79), dif0( 79), ar( 79), meso( 79), lebas( 79) / 'SVTRP1 ',0.0603, 20.0, 0.0, 194.9/ - DATA subname( 80), dif0( 80), ar( 80), meso( 80), lebas( 80) / 'SVTRP2 ',0.0559, 20.0, 0.0, 218.8/ - DATA subname( 81), dif0( 81), ar( 81), meso( 81), lebas( 81) / 'SVXYL1 ',0.0610, 20.0, 0.0, 154.6/ - DATA subname( 82), dif0( 82), ar( 82), meso( 82), lebas( 82) / 'SVXYL2 ',0.0585, 20.0, 0.0, 194.6/ - DATA subname( 83), dif0( 83), ar( 83), meso( 83), lebas( 83) / 'IO ',0.1002, 8.0, 0.0, 44.4/ - DATA subname( 84), dif0( 84), ar( 84), meso( 84), lebas( 84) / 'OIO ',0.0938, 8.0, 0.0, 51.8/ - DATA subname( 85), dif0( 85), ar( 85), meso( 85), lebas( 85) / 'I2O2 ',0.0732, 8.0, 0.0, 88.8/ - DATA subname( 86), dif0( 86), ar( 86), meso( 86), lebas( 86) / 'I2O3 ',0.0707, 8.0, 0.0, 96.2/ - DATA subname( 87), dif0( 87), ar( 87), meso( 87), lebas( 87) / 'I2O4 ',0.0684, 8.0, 0.0, 103.6/ - DATA subname( 88), dif0( 88), ar( 88), meso( 88), lebas( 88) / 'HI ',0.1045, 8.0, 0.0, 40.7/ - DATA subname( 89), dif0( 89), ar( 89), meso( 89), lebas( 89) / 'HOI ',0.0972, 8.0, 0.0, 48.1/ - DATA subname( 90), dif0( 90), ar( 90), meso( 90), lebas( 90) / 'INO ',0.0882, 8.0, 0.0, 60.9/ - DATA subname( 91), dif0( 91), ar( 91), meso( 91), lebas( 91) / 'INO2 ',0.0883, 20.0, 0.0, 69.2/ - DATA subname( 92), dif0( 92), ar( 92), meso( 92), lebas( 92) / 'IONO2 ',0.0792, 8.0, 0.0, 77.5/ - DATA subname( 93), dif0( 93), ar( 93), meso( 93), lebas( 93) / 'BRO ',0.1144, 1.0, 0.0, 34.4/ - DATA subname( 94), dif0( 94), ar( 94), meso( 94), lebas( 94) / 'HOBR ',0.1101, 1.0, 0.0, 38.1/ - DATA subname( 95), dif0( 95), ar( 95), meso( 95), lebas( 95) / 'HBR ',0.1216, 2.0, 0.0, 30.7/ - DATA subname( 96), dif0( 96), ar( 96), meso( 96), lebas( 96) / 'BRONO2 ',0.0855, 1.0, 0.0, 67.5/ - DATA subname( 97), dif0( 97), ar( 97), meso( 97), lebas( 97) / 'BRNO2 ',0.0909, 1.0, 0.0, 59.2/ - DATA subname( 98), dif0( 98), ar( 98), meso( 98), lebas( 98) / 'BRCL ',0.0966, 1.0, 0.0, 51.6/ - DATA subname( 99), dif0( 99), ar( 99), meso( 99), lebas( 99) / 'DMS ',0.0926, 2.0, 0.0, 77.4/ - DATA subname(100), dif0(100), ar(100), meso(100), lebas(100) / 'MSA ',0.0896, 2.0, 0.0, 77.4/ - DATA subname(101), dif0(101), ar(101), meso(101), lebas(101) / 'METHANE ',0.2107, 2.0, 0.0, 29.6/ ! dif0, equation 9-22. Scwarzenbach et. (1993) Env. Org. Chem. - DATA subname(102), dif0(102), ar(102), meso(102), lebas(102) / 'ACRYACID ',0.0908, 2.0, 0.0, 63.2/ - DATA subname(103), dif0(103), ar(103), meso(103), lebas(103) / 'CARBSULFIDE ',0.1240, 5.0, 0.0, 51.5/ - DATA subname(104), dif0(104), ar(104), meso(104), lebas(104) / 'ACETONITRILE ',0.1280, 5.0, 0.0, 52.3/ - DATA subname(105), dif0(105), ar(105), meso(105), lebas(105) / '6_NITRO_O_CRESOL',0.0664, 16.0, 0.0, 155.0/ ! dif0, equation 9-22. Scwarzenbach et. (1993) Env. Org. Chem. + DATA subname( 1), dif0( 1), ar( 1), meso( 1), lebas( 1) / 'SO2 ', 0.1089, 10.0, 0.0, 35.0 / + DATA subname( 2), dif0( 2), ar( 2), meso( 2), lebas( 2) / 'H2SO4 ', 0.1091, 8000.0, 0.0, 49.0 / + DATA subname( 3), dif0( 3), ar( 3), meso( 3), lebas( 3) / 'NO2 ', 0.1361, 2.0, 0.1, 21.0 / + DATA subname( 4), dif0( 4), ar( 4), meso( 4), lebas( 4) / 'NO ', 0.1802, 2.0, 0.0, 14.0 / + DATA subname( 5), dif0( 5), ar( 5), meso( 5), lebas( 5) / 'O3 ', 0.1444, 12.0, 1.0, 21.0 / + DATA subname( 6), dif0( 6), ar( 6), meso( 6), lebas( 6) / 'HNO3 ', 0.1067, 8000.0, 0.0, 35.0 / + DATA subname( 7), dif0( 7), ar( 7), meso( 7), lebas( 7) / 'H2O2 ', 0.1300,34000.0, 1.0, 28.0 / !ar=34,000 such that r_cut=0.7 s/m as in Nguyen et al. 2015 + DATA subname( 8), dif0( 8), ar( 8), meso( 8), lebas( 8) / 'ACETALDEHYDE ', 0.1111, 10.0, 0.0, 56.0 / + DATA subname( 9), dif0( 9), ar( 9), meso( 9), lebas( 9) / 'FORMALDEHYDE ', 0.1554, 10.0, 0.0, 35.0 / + DATA subname( 10), dif0( 10), ar( 10), meso( 10), lebas( 10) / 'METHYLHYDROPEROX', 0.1179, 10.0, 0.3, 49.0 / !meso change from 0.1 to 0.3, Wolfe and Thornton 2011 ACP per J. Bash + DATA subname( 11), dif0( 11), ar( 11), meso( 11), lebas( 11) / 'PEROXYACETIC_ACI', 0.0868, 20.0, 0.1, 70.0 / + DATA subname( 12), dif0( 12), ar( 12), meso( 12), lebas( 12) / 'ACETIC_ACID ', 0.0944, 20.0, 0.0, 63.0 / + DATA subname( 13), dif0( 13), ar( 13), meso( 13), lebas( 13) / 'NH3 ', 0.1978, 20.0, 0.0, 28.0 / + DATA subname( 14), dif0( 14), ar( 14), meso( 14), lebas( 14) / 'PAN ', 0.0687, 16.0, 0.1, 91.0 / + DATA subname( 15), dif0( 15), ar( 15), meso( 15), lebas( 15) / 'HNO2 ', 0.1349, 20.0, 0.1, 28.0 / + DATA subname( 16), dif0( 16), ar( 16), meso( 16), lebas( 16) / 'CO ', 0.1807, 5.0, 0.0, 14.0 / + DATA subname( 17), dif0( 17), ar( 17), meso( 17), lebas( 17) / 'METHANOL ', 0.1329, 2.0, 0.0, 42.0 / + DATA subname( 18), dif0( 18), ar( 18), meso( 18), lebas( 18) / 'N2O5 ', 0.0808, 5000.0, 0.0, 49.0 / + DATA subname( 19), dif0( 19), ar( 19), meso( 19), lebas( 19) / 'NO3 ', 0.1153, 5000.0, 0.0, 28.0 / + DATA subname( 20), dif0( 20), ar( 20), meso( 20), lebas( 20) / 'GENERIC_ALDEHYDE', 0.0916, 10.0, 0.0, 56.0 / + DATA subname( 21), dif0( 21), ar( 21), meso( 21), lebas( 21) / 'CL2 ', 0.1080, 10.0, 0.0, 49.0 / + DATA subname( 22), dif0( 22), ar( 22), meso( 22), lebas( 22) / 'HOCL ', 0.1300, 10.0, 0.0, 38.5 / ! used value of HCL + DATA subname( 23), dif0( 23), ar( 23), meso( 23), lebas( 23) / 'HCL ', 0.1510, 8000.0, 0.0, 31.5 / + DATA subname( 24), dif0( 24), ar( 24), meso( 24), lebas( 24) / 'FMCL ', 0.1094, 10.0, 0.0, 45.5 / ! default value + DATA subname( 25), dif0( 25), ar( 25), meso( 25), lebas( 25) / 'HG ', 0.1194, 0.1, 0.0, 14.8 / ! lebas not used + DATA subname( 26), dif0( 26), ar( 26), meso( 26), lebas( 26) / 'HGIIGAS ', 0.0976, 8000.0, 0.0, 95.0 / ! estimation from back calculating to get dw25 = 1.04e-5 (Garland et al, 1965) + DATA subname( 27), dif0( 27), ar( 27), meso( 27), lebas( 27) / 'TECDD_2378 ', 0.0525, 2.0, 0.0, 217.0 / + DATA subname( 28), dif0( 28), ar( 28), meso( 28), lebas( 28) / 'PECDD_12378 ', 0.0508, 2.0, 0.0, 234.5 / + DATA subname( 29), dif0( 29), ar( 29), meso( 29), lebas( 29) / 'HXCDD_123478 ', 0.0494, 2.0, 0.0, 252.0 / + DATA subname( 30), dif0( 30), ar( 30), meso( 30), lebas( 30) / 'HXCDD_123678 ', 0.0494, 2.0, 0.0, 252.0 / + DATA subname( 31), dif0( 31), ar( 31), meso( 31), lebas( 31) / 'HXCDD_123478 ', 0.0494, 2.0, 0.0, 252.0 / + DATA subname( 32), dif0( 32), ar( 32), meso( 32), lebas( 32) / 'HPCDD_1234678 ', 0.0480, 2.0, 0.0, 269.5 / + DATA subname( 33), dif0( 33), ar( 33), meso( 33), lebas( 33) / 'OTCDD ', 0.0474, 2.0, 0.0, 287.0 / + DATA subname( 34), dif0( 34), ar( 34), meso( 34), lebas( 34) / 'TECDF_2378 ', 0.0534, 2.0, 0.0, 210.0 / + DATA subname( 35), dif0( 35), ar( 35), meso( 35), lebas( 35) / 'PECDF_12378 ', 0.0517, 2.0, 0.0, 227.5 / + DATA subname( 36), dif0( 36), ar( 36), meso( 36), lebas( 36) / 'PECDF_23478 ', 0.0517, 2.0, 0.0, 227.5 / + DATA subname( 37), dif0( 37), ar( 37), meso( 37), lebas( 37) / 'HXCDF_123478 ', 0.0512, 2.0, 0.0, 245.0 / + DATA subname( 38), dif0( 38), ar( 38), meso( 38), lebas( 38) / 'HXCDF_123678 ', 0.0512, 2.0, 0.0, 245.0 / + DATA subname( 39), dif0( 39), ar( 39), meso( 39), lebas( 39) / 'HXCDF_234678 ', 0.0512, 2.0, 0.0, 245.0 / + DATA subname( 40), dif0( 40), ar( 40), meso( 40), lebas( 40) / 'HXCDF_123789 ', 0.0512, 2.0, 0.0, 245.0 / + DATA subname( 41), dif0( 41), ar( 41), meso( 41), lebas( 41) / 'HPCDF_1234678 ', 0.0487, 2.0, 0.0, 262.5 / + DATA subname( 42), dif0( 42), ar( 42), meso( 42), lebas( 42) / 'HPCDF_1234789 ', 0.0487, 2.0, 0.0, 262.5 / + DATA subname( 43), dif0( 43), ar( 43), meso( 43), lebas( 43) / 'OTCDF ', 0.0474, 2.0, 0.0, 280.0 / + DATA subname( 44), dif0( 44), ar( 44), meso( 44), lebas( 44) / 'NAPHTHALENE ', 0.0778, 4.0, 0.0, 119.0 / !Julin et al. 2014 doi:10.1021/es501816h + DATA subname( 45), dif0( 45), ar( 45), meso( 45), lebas( 45) / '1NITRONAPHTHALEN', 0.0692, 4.0, 0.0, 133.0 / + DATA subname( 46), dif0( 46), ar( 46), meso( 46), lebas( 46) / '2NITRONAPHTHALEN', 0.0692, 4.0, 0.0, 133.0 / + DATA subname( 47), dif0( 47), ar( 47), meso( 47), lebas( 47) / '14NAPHTHOQUINONE', 0.0780, 4.0, 0.0, 119.0 / + DATA subname( 48), dif0( 48), ar( 48), meso( 48), lebas( 48) / 'HEXAMETHYLE_DIIS', 0.0380, 10.0, 0.0, 196.0 / + DATA subname( 49), dif0( 49), ar( 49), meso( 49), lebas( 49) / 'HYDRAZINE ', 0.4164, 20.0, 0.0, 42.0 / + DATA subname( 50), dif0( 50), ar( 50), meso( 50), lebas( 50) / 'MALEIC_ANHYDRIDE', 0.0950, 10.0, 0.0, 70.0 / + DATA subname( 51), dif0( 51), ar( 51), meso( 51), lebas( 51) / '24-TOLUENE_DIIS ', 0.0610, 10.0, 0.0, 154.0 / + DATA subname( 52), dif0( 52), ar( 52), meso( 52), lebas( 52) / 'TRIETHYLAMINE ', 0.0881, 20.0, 0.0, 154.0 / + DATA subname( 53), dif0( 53), ar( 53), meso( 53), lebas( 53) / 'ORG_NTR ', 0.0607, 16.0, 0.0, 160.0 / ! assumes 58.2% C5H11O4N and 41.8% C5H11O3N + DATA subname( 54), dif0( 54), ar( 54), meso( 54), lebas( 54) / 'HYDROXY_NITRATES', 0.0609, 16.0, 0.0, 156.1 / + DATA subname( 55), dif0( 55), ar( 55), meso( 55), lebas( 55) / 'MPAN ', 0.0580, 16.0, 0.1, 133.0 / + DATA subname( 56), dif0( 56), ar( 56), meso( 56), lebas( 56) / 'PPN ', 0.0631, 16.0, 0.1, 118.2 / + DATA subname( 57), dif0( 57), ar( 57), meso( 57), lebas( 57) / 'METHACROLEIN ', 0.0810, 8.0, 1.0, 88.8 / + DATA subname( 58), dif0( 58), ar( 58), meso( 58), lebas( 58) / 'DINTR ', 0.0617, 16.0, 0.1, 169.8 / + DATA subname( 59), dif0( 59), ar( 59), meso( 59), lebas( 59) / 'NTR_ALK ', 0.0688, 16.0, 0.1, 133.0 / + DATA subname( 60), dif0( 60), ar( 60), meso( 60), lebas( 60) / 'NTR_OH ', 0.0665, 16.0, 0.1, 140.4 / + DATA subname( 61), dif0( 61), ar( 61), meso( 61), lebas( 61) / 'HYDROXY_NITRATES', 0.0646, 16.0, 0.0, 147.8 / + DATA subname( 62), dif0( 62), ar( 62), meso( 62), lebas( 62) / 'PROPNN ', 0.0677, 16.0, 0.0, 133.0 / + DATA subname( 63), dif0( 63), ar( 63), meso( 63), lebas( 63) / 'NITRYL_CHLORIDE ', 0.0888, 8.0, 0.0, 45.5 / ! dif0 estimated following Erickson III et al., JGR, 104, D7, 8347-8372, 1999 + DATA subname( 64), dif0( 64), ar( 64), meso( 64), lebas( 64) / 'ISOPNN ',0.0457, 275.9, 0.0, 206.8 / + DATA subname( 65), dif0( 65), ar( 65), meso( 65), lebas( 65) / 'MTNO3 ',0.0453, 96.2, 0.0, 251.2 / + DATA subname( 66), dif0( 66), ar( 66), meso( 66), lebas( 66) / 'IEPOX ',0.0579, 8.0, 0.0, 110.8 / + DATA subname( 67), dif0( 67), ar( 67), meso( 67), lebas( 67) / 'HACET ',0.1060, 8.0, 0.0, 72.6 / ! dif0 from Nguyen 2015 PNAS + DATA subname( 68), dif0( 68), ar( 68), meso( 68), lebas( 68) / 'SVALK1 ',0.0514, 4572.8, 0.0, 280.5 / ! Pye et al. doi:10.5194/acp-17-343-2017; rel. reactivity per J. Bash + DATA subname( 69), dif0( 69), ar( 69), meso( 69), lebas( 69) / 'SVALK2 ',0.0546, 12.9, 0.0, 275.6 / + DATA subname( 70), dif0( 70), ar( 70), meso( 70), lebas( 70) / 'SVBNZ1 ',0.0642,20671.2, 0.0, 134.1 / + DATA subname( 71), dif0( 71), ar( 71), meso( 71), lebas( 71) / 'SVBNZ2 ',0.0726, 52.5, 0.0, 127.5 / + DATA subname( 72), dif0( 72), ar( 72), meso( 72), lebas( 72) / 'SVISO1 ',0.0733, 50.6, 0.0, 126.3 / + DATA subname( 73), dif0( 73), ar( 73), meso( 73), lebas( 73) / 'SVISO2 ',0.0729,10009.0, 0.0, 123.8 / + DATA subname( 74), dif0( 74), ar( 74), meso( 74), lebas( 74) / 'SVPAH1 ',0.0564, 772.1, 0.0, 235.7 / + DATA subname( 75), dif0( 75), ar( 75), meso( 75), lebas( 75) / 'SVPAH2 ',0.0599, 4.8, 0.0, 231.5 / + DATA subname( 76), dif0( 76), ar( 76), meso( 76), lebas( 76) / 'SVSQT ',0.0451, 10.3, 0.0, 346.5 / + DATA subname( 77), dif0( 77), ar( 77), meso( 77), lebas( 77) / 'SVTOL1 ',0.0637, 1928.3, 0.0, 153.7 / + DATA subname( 78), dif0( 78), ar( 78), meso( 78), lebas( 78) / 'SVTOL2 ',0.0607, 111.6, 0.0, 194.1 / + DATA subname( 79), dif0( 79), ar( 79), meso( 79), lebas( 79) / 'SVTRP1 ',0.0603, 160.1, 0.0, 194.9 / + DATA subname( 80), dif0( 80), ar( 80), meso( 80), lebas( 80) / 'SVTRP2 ',0.0559, 13.0, 0.0, 218.8 / + DATA subname( 81), dif0( 81), ar( 81), meso( 81), lebas( 81) / 'SVXYL1 ',0.0610, 3586.7, 0.0, 154.6 / + DATA subname( 82), dif0( 82), ar( 82), meso( 82), lebas( 82) / 'SVXYL2 ',0.0585, 72.2, 0.0, 194.6 / + DATA subname( 83), dif0( 83), ar( 83), meso( 83), lebas( 83) / 'IO ',0.1004, 8.0, 0.0, 45.5 / + DATA subname( 84), dif0( 84), ar( 84), meso( 84), lebas( 84) / 'OIO ',0.0940, 8.0, 0.0, 52.5 / + DATA subname( 85), dif0( 85), ar( 85), meso( 85), lebas( 85) / 'I2O2 ',0.0734, 8.0, 0.0, 91.0 / + DATA subname( 86), dif0( 86), ar( 86), meso( 86), lebas( 86) / 'I2O3 ',0.0709, 8.0, 0.0, 98.0 / + DATA subname( 87), dif0( 87), ar( 87), meso( 87), lebas( 87) / 'I2O4 ',0.0686, 8.0, 0.0, 105.0 / + DATA subname( 88), dif0( 88), ar( 88), meso( 88), lebas( 88) / 'HI ',0.1047, 8.0, 0.0, 45.5 / + DATA subname( 89), dif0( 89), ar( 89), meso( 89), lebas( 89) / 'HOI ',0.0974, 8.0, 0.0, 52.5 / + DATA subname( 90), dif0( 90), ar( 90), meso( 90), lebas( 90) / 'INO ',0.0885, 8.0, 0.0, 52.5 / + DATA subname( 91), dif0( 91), ar( 91), meso( 91), lebas( 91) / 'INO2 ',0.0835, 20.0, 0.0, 59.5 / + DATA subname( 92), dif0( 92), ar( 92), meso( 92), lebas( 92) / 'INO3 ',0.0794, 8.0, 0.0, 66.5 / + DATA subname( 93), dif0( 93), ar( 93), meso( 93), lebas( 93) / 'BRO ',0.1146, 1.0, 0.0, 38.5 / + DATA subname( 94), dif0( 94), ar( 94), meso( 94), lebas( 94) / 'HOBR ',0.1104, 1.0, 0.0, 45.5 / + DATA subname( 95), dif0( 95), ar( 95), meso( 95), lebas( 95) / 'HBR ',0.1219, 2.0, 0.0, 38.5 / + DATA subname( 96), dif0( 96), ar( 96), meso( 96), lebas( 96) / 'BRNO3 ',0.0871, 1.0, 0.0, 59.5 / + DATA subname( 97), dif0( 97), ar( 97), meso( 97), lebas( 97) / 'BRNO2 ',0.0922, 1.0, 0.0, 52.5 / + DATA subname( 98), dif0( 98), ar( 98), meso( 98), lebas( 98) / 'BRCL ',0.0968, 1.0, 0.0, 56.0 / + DATA subname( 99), dif0( 99), ar( 99), meso( 99), lebas( 99) / 'DMS ',0.0896, 2.0, 0.0, 77.0 / + DATA subname(100), dif0(100), ar(100), meso(100), lebas(100) / 'MSA ',0.0844, 2.0, 0.0, 77.0 / + DATA subname(101), dif0(101), ar(101), meso(101), lebas(101) / 'METHANE ',0.2107, 2.0, 0.0, 29.6 / ! dif0, eqn 9-22 Schwarzenbach Gschwend & Imboden (1993) Env Org Chem + DATA subname(102), dif0(102), ar(102), meso(102), lebas(102) / 'ACRYACID ',0.0908, 2.0, 0.0, 63.2 / + DATA subname(103), dif0(103), ar(103), meso(103), lebas(103) / 'CARBSULFIDE ',0.1240, 5.0, 0.0, 51.5 / + DATA subname(104), dif0(104), ar(104), meso(104), lebas(104) / 'ACETONITRILE ',0.1280, 5.0, 0.0, 52.3 / + DATA subname(105), dif0(105), ar(105), meso(105), lebas(105) / '6_NITRO_O_CRESOL',0.0664, 16.0, 0.0, 155.0 / ! dif0, eqn 9-22 Schwarzenbach Gschwend & Imboden (1993) Env Org Chem + DATA subname(106), dif0(106), ar(106), meso(106), lebas(106) / 'GENERIC_ALDEHYDE',0.0646, 10.0, 0.0, 56.0 / ! PCVOC + DATA subname(107), dif0(107), ar(107), meso(107), lebas(107) / 'NTR_OH ',0.0722, 16.0, 0.1, 140.4 / ! INTR + DATA subname(108), dif0(108), ar(108), meso(108), lebas(108) / 'METHYLHYDROPEROX',0.0853, 10.0, 0.3, 49.0 / ! ISPX diffusion should be ~ 0.0710 according to Wolfe and thornton 2011 ACP + DATA subname(109), dif0(109), ar(109), meso(109), lebas(109) / 'METHYLHYDROPEROX',0.1371, 10.0, 0.3, 49.0 / ! ROOH diffusion should be ~ 0.0710 according to Wolfe and thornton 2011 ACP + DATA subname(110), dif0(110), ar(110), meso(110), lebas(110) / 'ADIPIC_ACID ',0.0646,90000.0, 0.0, 63.0 / ! LVPCSOG + DATA subname(111), dif0(111), ar(111), meso(111), lebas(111) / 'ADIPIC_ACID ',0.0456, 4.2, 0.0, 63.0 / ! VIVPO1 + DATA subname(112), dif0(112), ar(112), meso(112), lebas(112) / 'ADIPIC_ACID ',0.0766,71624.8, 0.0, 63.0 / ! VLVOO1 + DATA subname(113), dif0(113), ar(113), meso(113), lebas(113) / 'ADIPIC_ACID ',0.0766, 9042.0, 0.0, 63.0 / ! VLVOO2 + DATA subname(114), dif0(114), ar(114), meso(114), lebas(114) / 'ADIPIC_ACID ',0.0533,13818.0, 0.0, 63.0 / ! VLVPO1 + DATA subname(115), dif0(115), ar(115), meso(115), lebas(115) / 'ADIPIC_ACID ',0.0771, 1133.9, 0.0, 63.0 / ! VSVOO1 + DATA subname(116), dif0(116), ar(116), meso(116), lebas(116) / 'ADIPIC_ACID ',0.0771, 18.1, 0.0, 63.0 / ! VSVOO2 + DATA subname(117), dif0(117), ar(117), meso(117), lebas(117) / 'ADIPIC_ACID ',0.0775, 2.3, 0.0, 63.0 / ! VSVOO3 + DATA subname(118), dif0(118), ar(118), meso(118), lebas(118) / 'ADIPIC_ACID ',0.0511, 1830.5, 0.0, 63.0 / ! VSVPO1 + DATA subname(119), dif0(119), ar(119), meso(119), lebas(119) / 'ADIPIC_ACID ',0.0493, 241.0, 0.0, 63.0 / ! VSVPO2 + DATA subname(120), dif0(120), ar(120), meso(120), lebas(120) / 'ADIPIC_ACID ',0.0474, 31.8, 0.0, 63.0 / ! VSVPO3 + DATA subname(121), dif0(121), ar(121), meso(121), lebas(121) / 'FORMIC_ACID ',0.1411, 20.0, 0.0, 63.0 / ! FACD + DATA subname(122), dif0(122), ar(122), meso(122), lebas(122) / 'MEK ',0.0859, 1.0, 0.0, 108.2 / ! KET different in different mechanisms + DATA subname(123), dif0(123), ar(123), meso(123), lebas(123) / 'ETHENE ',0.1366, 1.0, 0.0, 58.1 / ! ETH + DATA subname(124), dif0(124), ar(124), meso(124), lebas(124) / 'HNO4 ',0.1233, 1.0, 0.0, 45.2 / ! PNA + DATA subname(125), dif0(125), ar(125), meso(125), lebas(125) / 'GLYOXAL ',0.1188, 1.0, 0.0, 56.2 / ! GLY + DATA subname(126), dif0(126), ar(126), meso(126), lebas(126) / 'GLYOXAL ',0.1181, 1.0, 0.0, 56.4 / ! GLYD + DATA subname(127), dif0(127), ar(127), meso(127), lebas(127) / 'METHYL_GLYOXAL ',0.1038, 1.0, 0.0, 72.5 / ! MGLY + DATA subname(128), dif0(128), ar(128), meso(128), lebas(128) / 'ETHANE ',0.1312, 1.0, 0.0, 61.5 / ! ETHA + DATA subname(129), dif0(129), ar(129), meso(129), lebas(129) / 'ETHANOL ',0.1213, 1.0, 0.0, 59.1 / ! ETOH + DATA subname(130), dif0(130), ar(130), meso(130), lebas(130) / 'ETHANE ',0.0870, 1.0, 0.0, 111.1 / ! PAR as Pentane + DATA subname(131), dif0(131), ar(131), meso(131), lebas(131) / 'ACETONE ',0.1057, 1.0, 0.0, 75.2 / ! ACET + DATA subname(132), dif0(132), ar(132), meso(132), lebas(132) / 'PROPANE ',0.1095, 1.0, 0.0, 78.1 / ! PRPA + DATA subname(133), dif0(133), ar(133), meso(133), lebas(133) / 'ACETYLENE ',0.1523, 1.0, 0.0, 45.8 / ! ETHY + DATA subname(134), dif0(134), ar(134), meso(134), lebas(134) / 'ETHENE ',0.1135, 1.0, 0.0, 73.1 / ! OLE as Propene + DATA subname(135), dif0(135), ar(135), meso(135), lebas(135) / 'ETHENE ',0.0990, 1.0, 0.0, 89.5 / ! IOLE as Isobutene + DATA subname(136), dif0(136), ar(136), meso(136), lebas(136) / 'MEK ',0.0852, 1.0, 0.0, 101.2 / ! IEPOX different scavenging H in CB05 and CB06 + DATA subname(137), dif0(137), ar(137), meso(137), lebas(137) / 'BENZENE ',0.0942, 1.0, 0.0, 89.4 / ! BENZENE + DATA subname(138), dif0(138), ar(138), meso(138), lebas(138) / '2-CRESOL ',0.0850, 1.0, 0.0, 108.1 / ! CRES + DATA subname(139), dif0(139), ar(139), meso(139), lebas(139) / 'TOLUENE ',0.0860, 1.0, 0.0, 105.7 / ! TOL + DATA subname(140), dif0(140), ar(140), meso(140), lebas(140) / 'O-XYLENE ',0.0796, 1.0, 0.0, 122.0 / ! XYLMN + DATA subname(141), dif0(141), ar(141), meso(141), lebas(141) / 'O-XYLENE ',0.0777, 1.0, 0.0, 123.5 / ! NAPH + DATA subname(142), dif0(142), ar(142), meso(142), lebas(142) / 'PHENOL ',0.0844, 1.0, 0.0, 102.6 / ! CAT1 + DATA subname(143), dif0(143), ar(143), meso(143), lebas(143) / 'PINENE ',0.0545, 1.0, 0.0, 251.5 / ! SESQ + DATA subname(144), dif0(144), ar(144), meso(144), lebas(144) / 'PINENE ',0.0700, 1.0, 0.0, 136.2 / ! TERP + DATA subname(145), dif0(145), ar(145), meso(145), lebas(145) / 'ISOPRENE ',0.0913, 1.0, 0.0, 136.2 / ! ISOP + DATA subname(146), dif0(146), ar(146), meso(146), lebas(146) / 'METHACROLEIN ',0.1033, 1.0, 0.0, 69.6 / ! OPEN C4H4O2 + DATA subname(147), dif0(147), ar(147), meso(147), lebas(147) / 'MEK ',0.0950, 1.0, 0.0, 81.7 / ! XOPN C5H6O2 + DATA subname(148), dif0(148), ar(148), meso(148), lebas(148) / 'DECANE ',0.0739, 1.0, 0.0, 142.8 / ! SOAALK as Propylcyclopentane + DATA subname(149), dif0(149), ar(149), meso(149), lebas(149) / '13-BUTADIENE ',0.1019, 1.0, 0.0, 84.8 / ! BUTADIENE13 + DATA subname(150), dif0(150), ar(150), meso(150), lebas(150) / 'ACROLEIN ',0.1092, 1.0, 0.0, 70.5 / + DATA subname(151), dif0(151), ar(151), meso(151), lebas(151) / 'SVMT1 ',0.0424, 20.0, 0.0, 355.2/ ! see Xu et al., 2018 ACPD: doi:10.5194/acp-2017-1109 + DATA subname(152), dif0(152), ar(152), meso(152), lebas(152) / 'SVMT2 ',0.0556, 20.0, 0.0, 236.8/ + DATA subname(153), dif0(153), ar(153), meso(153), lebas(153) / 'SVMT3 ',0.0583, 20.0, 0.0, 214.6/ + DATA subname(154), dif0(154), ar(154), meso(154), lebas(154) / 'SVMT4 ',0.0587, 20.0, 0.0, 229.4/ + DATA subname(155), dif0(155), ar(155), meso(155), lebas(155) / 'SVMT5 ',0.0619, 20.0, 0.0, 207.2/ + DATA subname(156), dif0(156), ar(156), meso(156), lebas(156) / 'SVMT6 ',0.0624, 20.0, 0.0, 222.0/ + DATA subname(157), dif0(157), ar(157), meso(157), lebas(157) / 'SVMT7 ',0.0661, 20.0, 0.0, 199.8/ + DATA subname(158), dif0(158), ar(158), meso(158), lebas(158) / 'SVAVB1 ',0.0560,100388.0, 0.0, 163.1/ + DATA subname(159), dif0(159), ar(159), meso(159), lebas(159) / 'SVAVB2 ',0.0600, 1461.2, 0.0, 163.2/ + DATA subname(160), dif0(160), ar(160), meso(160), lebas(160) / 'SVAVB3 ',0.0620, 175.2, 0.0, 163.0/ + DATA subname(161), dif0(161), ar(161), meso(161), lebas(161) / 'SVAVB4 ',0.0650, 20.8, 0.0, 162.7/ + DATA subname(162), dif0(162), ar(162), meso(162), lebas(162) / 'CLNO3 ',0.0902, 8.0, 0.0, 52.5/ + DATA subname(163), dif0(163), ar(163), meso(163), lebas(163) / 'FMBR ',0.0965, 10.0, 0.0, 52.5/ + DATA subname(164), dif0(164), ar(164), meso(164), lebas(164) / 'I2 ',0.0795, 4.0, 0.0, 77.0/ + DATA subname(165), dif0(165), ar(165), meso(165), lebas(165) / 'CH3I ',0.0881, 2.0, 0.0, 66.5/ + DATA subname(166), dif0(166), ar(166), meso(166), lebas(166) / 'ICL ',0.0878, 4.0, 0.0, 63.0/ + DATA subname(167), dif0(167), ar(167), meso(167), lebas(167) / 'IBR ',0.0851, 4.0, 0.0, 70.0/ + DATA subname(168), dif0(168), ar(168), meso(168), lebas(168) / 'MI2 ',0.0713, 2.0, 0.0, 98.0/ + DATA subname(169), dif0(169), ar(169), meso(169), lebas(169) / 'MIB ',0.0753, 2.0, 0.0, 91.0/ + DATA subname(170), dif0(170), ar(170), meso(170), lebas(170) / 'MIC ',0.0773, 2.0, 0.0, 84.0/ + DATA subname(171), dif0(171), ar(171), meso(171), lebas(171) / 'BR2 ',0.0925, 2.0, 0.0, 63.0/ + DATA subname(172), dif0(172), ar(172), meso(172), lebas(172) / 'MB3 ',0.0705, 2.0, 0.0, 108.5/ + DATA subname(173), dif0(173), ar(173), meso(173), lebas(173) / 'MB2 ',0.0804, 2.0, 0.0, 84.0/ + DATA subname(174), dif0(174), ar(174), meso(174), lebas(174) / 'MB2C ',0.0720, 2.0, 0.0, 101.5/ + DATA subname(175), dif0(175), ar(175), meso(175), lebas(175) / 'MBC2 ',0.0739, 2.0, 0.0, 94.5/ + DATA subname(176), dif0(176), ar(176), meso(176), lebas(176) / 'MBC ',0.0834, 2.0, 0.0, 77.0/ + DATA subname(177), dif0(177), ar(177), meso(177), lebas(177) / 'CLO ',0.1288, 8.0, 0.0, 31.5/ + DATA subname(178), dif0(178), ar(178), meso(178), lebas(178) / 'ACETALDEHYDE ',0.0975, 1.0, 0.0, 58.9/ + DATA subname(179), dif0(179), ar(179), meso(179), lebas(179) / 'ACETYLENE ',0.1212, 1.0, 0.0, 45.8/ + DATA subname(180), dif0(180), ar(180), meso(180), lebas(180) / 'ACROOPERA ',0.0869, 1.0, 0.0, 70.5/ + DATA subname(181), dif0(181), ar(181), meso(181), lebas(181) / 'ACETONE ',0.0842, 1.0, 0.0, 75.2/ + DATA subname(182), dif0(182), ar(182), meso(182), lebas(182) / 'APIOPERA ',0.0560, 1.0, 0.0, 154.9/ + DATA subname(183), dif0(183), ar(183), meso(183), lebas(183) / 'BENZALDEHYDE ',0.0688, 1.0, 0.0, 101.1/ + DATA subname(184), dif0(184), ar(184), meso(184), lebas(184) / 'BDE13OPERA ',0.0812, 1.0, 0.0, 84.8/ + DATA subname(185), dif0(185), ar(185), meso(185), lebas(185) / 'BENOPERA ',0.0751, 1.0, 0.0, 89.4/ + DATA subname(186), dif0(186), ar(186), meso(186), lebas(186) / 'CSLOPERA ',0.0590, 1.0, 0.0, 137.1/ + DATA subname(187), dif0(187), ar(187), meso(187), lebas(187) / 'METHACROLEIN ',0.0696, 1.0, 0.0, 100.6/ + DATA subname(188), dif0(188), ar(188), meso(188), lebas(188) / 'METHACROLEIN ',0.0647, 1.0, 0.0, 115.4/ + DATA subname(189), dif0(189), ar(189), meso(189), lebas(189) / 'METHACROLEIN ',0.0768, 1.0, 0.0, 82.8/ + DATA subname(190), dif0(190), ar(190), meso(190), lebas(190) / 'ETHANOL ',0.0965, 1.0, 0.0, 59.1/ + DATA subname(191), dif0(191), ar(191), meso(191), lebas(191) / 'ETHENE ',0.1085, 1.0, 0.0, 58.1/ + DATA subname(192), dif0(192), ar(192), meso(192), lebas(192) / 'ETHYLENEGLYCOL ',0.0931, 1.0, 0.0, 56.6/ + DATA subname(193), dif0(193), ar(193), meso(193), lebas(193) / 'FURANOPERA ',0.0751, 1.0, 0.0, 83.9/ + DATA subname(194), dif0(194), ar(194), meso(194), lebas(194) / 'FURANONEOPERA ',0.0820, 1.0, 0.0, 66.5/ + DATA subname(195), dif0(195), ar(195), meso(195), lebas(195) / 'HC10OPERA ',0.0505, 1.0, 0.0, 194.0/ + DATA subname(196), dif0(196), ar(196), meso(196), lebas(196) / 'HC3OPERA ',0.0872, 1.0, 0.0, 78.1/ + DATA subname(197), dif0(197), ar(197), meso(197), lebas(197) / 'HC5OPERA ',0.0694, 1.0, 0.0, 111.0/ + DATA subname(198), dif0(198), ar(198), meso(198), lebas(198) / 'HYDROXY-ACETONE ',0.0823, 1.0, 0.0, 72.7/ + DATA subname(199), dif0(199), ar(199), meso(199), lebas(199) / 'METHACROLEIN ',0.0663, 1.0, 0.3, 107.6/ + DATA subname(200), dif0(200), ar(200), meso(200), lebas(200) / 'ISOOPERA ',0.0728, 1.0, 0.0, 101.0/ + DATA subname(201), dif0(201), ar(201), meso(201), lebas(201) / '2NITRO_1BUTNL ',0.0609, 1.0, 0.1, 125.4/ + DATA subname(202), dif0(202), ar(202), meso(202), lebas(202) / 'LIMOPERA ',0.0547, 1.0, 0.0, 163.0/ + DATA subname(203), dif0(203), ar(203), meso(203), lebas(203) / 'UALDOPERA ',0.0511, 1.0, 0.0, 183.3/ + DATA subname(204), dif0(204), ar(204), meso(204), lebas(204) / 'METHACROLEIN ',0.0772, 1.0, 0.0, 86.8/ + DATA subname(205), dif0(205), ar(205), meso(205), lebas(205) / 'METHACROLEIN ',0.0745, 1.0, 0.3, 84.1/ + DATA subname(206), dif0(206), ar(206), meso(206), lebas(206) / 'MCTOPERA ',0.0672, 1.7, 0.0, 103.0/ + DATA subname(207), dif0(207), ar(207), meso(207), lebas(207) / 'MEK ',0.0752, 1.0, 0.0, 91.7/ + DATA subname(208), dif0(208), ar(208), meso(208), lebas(208) / 'METHANOL ',0.1182, 1.0, 0.0, 42.5/ + DATA subname(209), dif0(209), ar(209), meso(209), lebas(209) / 'MVK ',0.0772, 1.0, 0.0, 86.8/ + DATA subname(210), dif0(210), ar(210), meso(210), lebas(210) / '2NITRO_1BUTNL ',0.0766, 1.0, 0.1, 78.0/ + DATA subname(211), dif0(211), ar(211), meso(211), lebas(211) / 'OLIOPERA ',0.0717, 1.0, 0.0, 104.0/ + DATA subname(212), dif0(212), ar(212), meso(212), lebas(212) / 'OLTOPERA ',0.0904, 1.0, 0.0, 73.1/ + DATA subname(213), dif0(213), ar(213), meso(213), lebas(213) / 'MPAN ',0.0647, 1.0, 0.1, 114.0/ + DATA subname(214), dif0(214), ar(214), meso(214), lebas(214) / 'METHYLHYDROPEROX',0.1030, 1.0, 0.3, 48.9/ + DATA subname(215), dif0(215), ar(215), meso(215), lebas(215) / 'METHYLHYDROPEROX',0.0881, 1.0, 0.3, 65.4/ + DATA subname(216), dif0(216), ar(216), meso(216), lebas(216) / 'METHYLHYDROPEROX',0.0535, 1.0, 0.3, 162.4/ + DATA subname(217), dif0(217), ar(217), meso(217), lebas(217) / 'ORA1OPERA ',0.1119, 1.0, 0.0, 39.9/ + DATA subname(218), dif0(218), ar(218), meso(218), lebas(218) / 'ORA2OPERA ',0.0939, 1.0, 0.0, 56.2/ + DATA subname(219), dif0(219), ar(219), meso(219), lebas(219) / 'PHENOPERA ',0.0731, 3.4, 0.0, 86.3/ + DATA subname(220), dif0(220), ar(220), meso(220), lebas(220) / 'GENERIC_ALDEHYDE',0.0521, 1.0, 0.0, 175.5/ + DATA subname(221), dif0(221), ar(221), meso(221), lebas(221) / 'PROGOPERA ',0.0816, 1.0, 0.0, 73.4/ + DATA subname(222), dif0(222), ar(222), meso(222), lebas(222) / 'ROCIOXYOPERA ',0.0354, 1.0, 0.0, 384.0/ + DATA subname(223), dif0(223), ar(223), meso(223), lebas(223) / 'ADIPIC_ACID ',0.0382, 1.0, 0.0, 326.0/ + DATA subname(224), dif0(224), ar(224), meso(224), lebas(224) / 'ADIPIC_ACID ',0.0528, 1.0, 0.0, 172.0/ + DATA subname(225), dif0(225), ar(225), meso(225), lebas(225) / 'ADIPIC_ACID ',0.0431, 1.0, 0.0, 260.0/ + DATA subname(226), dif0(226), ar(226), meso(226), lebas(226) / 'ADIPIC_ACID ',0.0465, 1.0, 0.0, 221.0/ + DATA subname(227), dif0(227), ar(227), meso(227), lebas(227) / 'ADIPIC_ACID ',0.0483, 1.0, 0.0, 207.0/ + DATA subname(228), dif0(228), ar(228), meso(228), lebas(228) / 'ADIPIC_ACID ',0.0447, 1.0, 0.0, 243.0/ + DATA subname(229), dif0(229), ar(229), meso(229), lebas(229) / 'ADIPIC_ACID ',0.0484, 1.0, 0.0, 205.0/ + DATA subname(230), dif0(230), ar(230), meso(230), lebas(230) / 'ADIPIC_ACID ',0.0530, 1.0, 0.0, 174.0/ + DATA subname(231), dif0(231), ar(231), meso(231), lebas(231) / 'N-PROPANOL ',0.0836, 1.0, 0.0, 75.6/ + DATA subname(232), dif0(232), ar(232), meso(232), lebas(232) / 'SLOWROCOPERA ',0.1041, 1.0, 0.1, 38.9/ + DATA subname(233), dif0(233), ar(233), meso(233), lebas(233) / '2NITRO_1BUTNL ',0.0597, 18.6, 0.1, 123.5/ + DATA subname(234), dif0(234), ar(234), meso(234), lebas(234) / 'UALDOPERA ',0.0704, 1.0, 0.0, 102.0/ + DATA subname(235), dif0(235), ar(235), meso(235), lebas(235) / 'XYEOPERA ',0.0636, 1.0, 0.0, 122.0/ + DATA subname(236), dif0(236), ar(236), meso(236), lebas(236) / 'XYMOPERA ',0.0636, 1.0, 0.0, 122.0/ + DATA subname(237), dif0(237), ar(237), meso(237), lebas(237) / 'ELHOLM ',0.0464,49000.0, 0.3, 237.0/ + DATA subname(238), dif0(238), ar(238), meso(238), lebas(238) / 'HOLM ',0.0534, 711.0, 0.3, 157.7/ + DATA subname(239), dif0(239), ar(239), meso(239), lebas(239) / 'METHYLHYDROPEROX',0.0551, 783.0, 0.3, 153.1/ + DATA subname(240), dif0(240), ar(240), meso(240), lebas(240) / 'ADIPIC_ACID ',0.0303, 218.0, 0.0, 508.0/ + DATA subname(241), dif0(241), ar(241), meso(241), lebas(241) / 'ADIPIC_ACID ',0.0365, 8450.0, 0.0, 353.0/ + DATA subname(242), dif0(242), ar(242), meso(242), lebas(242) / 'ADIPIC_ACID ',0.0465, 2550.0, 0.0, 216.0/ + DATA subname(243), dif0(243), ar(243), meso(243), lebas(243) / 'ADIPIC_ACID ',0.0557, 182.0, 0.0, 147.7/ + DATA subname(244), dif0(244), ar(244), meso(244), lebas(244) / 'ADIPIC_ACID ',0.0298,28400.0, 0.0, 524.0/ + DATA subname(245), dif0(245), ar(245), meso(245), lebas(245) / 'ADIPIC_ACID ',0.0405, 696.0, 0.0, 285.4/ + DATA subname(246), dif0(246), ar(246), meso(246), lebas(246) / 'ADIPIC_ACID ',0.0485, 1440.0, 0.0, 197.0/ + DATA subname(247), dif0(247), ar(247), meso(247), lebas(247) / 'ADIPIC_ACID ',0.0588,2060000., 0.0, 130.0/ + DATA subname(248), dif0(248), ar(248), meso(248), lebas(248) / 'ADIPIC_ACID ',0.0308, 36.8, 0.0, 491.0/ + DATA subname(249), dif0(249), ar(249), meso(249), lebas(249) / 'ADIPIC_ACID ',0.0433, 130.0, 0.0, 251.0/ + DATA subname(250), dif0(250), ar(250), meso(250), lebas(250) / 'ADIPIC_ACID ',0.0505, 5520.0, 0.0, 183.0/ + DATA subname(251), dif0(251), ar(251), meso(251), lebas(251) / 'ADIPIC_ACID ',0.0314, 6.8, 0.0, 474.0/ + DATA subname(252), dif0(252), ar(252), meso(252), lebas(252) / 'ADIPIC_ACID ',0.0394, 583.0, 0.0, 304.0/ + DATA subname(253), dif0(253), ar(253), meso(253), lebas(253) / 'ADIPIC_ACID ',0.0483, 2820.0, 0.0, 202.0/ + DATA subname(254), dif0(254), ar(254), meso(254), lebas(254) / 'ADIPIC_ACID ',0.0332, 1.1, 0.0, 425.0/ + DATA subname(255), dif0(255), ar(255), meso(255), lebas(255) / 'ADIPIC_ACID ',0.0464, 9.6, 0.0, 221.0/ + DATA subname(256), dif0(256), ar(256), meso(256), lebas(256) / 'ADIPIC_ACID ',0.0355, 1.0, 0.0, 375.0/ + DATA subname(257), dif0(257), ar(257), meso(257), lebas(257) / 'ADIPIC_ACID ',0.0489, 1.0, 0.0, 198.7/ + DATA subname(258), dif0(258), ar(258), meso(258), lebas(258) / 'IPNOPERA ',0.0652, 86.6, 0.3, 104.8/ ! VD_IPN + DATA subname(259), dif0(259), ar(259), meso(259), lebas(259) / 'IPCOPERA ',0.0687, 1.0, 0.3, 99.3/ ! VD_IPC CONTAINS C======================================================================= - Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) + Subroutine INIT_MET ( JDATE, JTIME ) C----------------------------------------------------------------------- C 30 Mar 01 J.Young: dyn alloc - Use HGRD_DEFN; replace INTERP3 with INTERPX; @@ -426,25 +545,19 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) C 31 Jan 05 J.Young: dyn alloc - establish both horizontal & vertical C domain specifications in one module C 16 Feb 11 S.Roselle: replaced I/O API include files with UTILIO_DEFN +C 25 Jul 19 D.Wong: used N_SOIL_TYPE defined in LSM_Mod to handle +C various number of soil type from different WRF version C----------------------------------------------------------------------- Use UTILIO_DEFN + Use LSM_Mod, only : N_SOIL_TYPE Implicit None Include SUBST_FILES_ID ! file name parameters - Include SUBST_CONST ! constants C Arguments: Integer, Intent( IN ) :: JDATE, JTIME ! internal simulation date&time - Logical, Intent( IN ) :: MOSAIC - Logical, Intent( IN ) :: ABFLUX - Logical, Intent( IN ) :: HGBIDI - -C File variables: - Real, Pointer :: MSFX2 ( :,: ) - Real, Pointer :: SOILCAT ( :,: ) - Real, Pointer :: X3M ( : ) C Local variables: Character( 16 ) :: PNAME = 'INIT_MET' @@ -453,15 +566,11 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) CHARACTER( 30 ) :: MSG1 = ' Error interpolating variable ' Character( 96 ) :: XMSG = ' ' -C for INTERPX - Integer STRTCOLGC2, ENDCOLGC2, STRTROWGC2, ENDROWGC2 Integer V Integer ALLOCSTAT C----------------------------------------------------------------------- - LOGDEV = INIT3() - If( MET_INITIALIZED )Return !> Allocate buffers @@ -484,7 +593,7 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) & Met_Data%PRSFC ( NCOLS,NROWS ), & Met_Data%Q2 ( NCOLS,NROWS ), & Met_Data%QSS_GRND ( NCOLS,NROWS ), - & Met_Data%RH ( NCOLS,NROWS ), + & Met_Data%RH2 ( NCOLS,NROWS ), & Met_Data%RA ( NCOLS,NROWS ), & Met_Data%RS ( NCOLS,NROWS ), & Met_Data%RC ( NCOLS,NROWS ), @@ -513,18 +622,21 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) & Met_Data%LPBL ( NCOLS,NROWS ), & Met_Data%CONVCT ( NCOLS,NROWS ), & Met_Data%PBL ( NCOLS,NROWS ), - & Met_Data%NACL_EMIS( NCOLS,NROWS ), - & Met_Data%UWINDA ( NCOLS,NROWS,NLAYS ), - & Met_Data%VWINDA ( NCOLS,NROWS,NLAYS ), +! & Met_Data%NACL_EMIS( NCOLS,NROWS ), + & Met_Data%COSZEN ( NCOLS,NROWS ), + & Met_Data%CFRAC ( NCOLS,NROWS ), + & Met_Data%UWINDA ( NCOLS,NROWS,NLAYS ), !(Wei Li) + & Met_Data%VWINDA ( NCOLS,NROWS,NLAYS ), !(Wei Li) & Met_Data%UWIND ( NCOLS+1,NROWS+1,NLAYS ), & Met_Data%VWIND ( NCOLS+1,NROWS+1,NLAYS ), & Met_Data%KZMIN ( NCOLS,NROWS,NLAYS ), + & Met_Data%PRESF ( NCOLS,NROWS,1:NLAYS+1 ), !(Wei Li) & Met_Data%PRES ( NCOLS,NROWS,NLAYS ), - & Met_Data%PRESF ( NCOLS,NROWS,1:NLAYS+1 ), & Met_Data%QV ( NCOLS,NROWS,NLAYS ), & Met_Data%QC ( NCOLS,NROWS,NLAYS ), & Met_Data%THETAV ( NCOLS,NROWS,NLAYS ), & Met_Data%TA ( NCOLS,NROWS,NLAYS ), + & Met_Data%RH ( NCOLS,NROWS,NLAYS ), & Met_Data%ZH ( NCOLS,NROWS,NLAYS ), & Met_Data%ZF ( NCOLS,NROWS,NLAYS ), & Met_Data%DZF ( NCOLS,NROWS,NLAYS ), @@ -549,103 +661,62 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) & Grid_Data%SZONE ( NCOLS,NROWS ), & Grid_Data%PURB ( NCOLS,NROWS ), & Grid_Data%SLTYP ( NCOLS,NROWS ), + & Grid_Data%WSAT ( NCOLS,NROWS ), + & Grid_Data%WWLT ( NCOLS,NROWS ), + & Grid_Data%WFC ( NCOLS,NROWS ), !We now use WFC whether BIDI is on or off + & Grid_Data%CLAY_PX ( NCOLS,NROWS ), + & Grid_Data%CSAND_PX ( NCOLS,NROWS ), + & Grid_Data%FMSAND_PX ( NCOLS,NROWS ), & Grid_Data%NAME ( n_lufrac ), & Grid_Data%LU_Type ( n_lufrac ), + & Grid_Data%LUFRAC ( NCOLS,NROWS,n_lufrac ), & STAT = ALLOCSTAT ) If ( ALLOCSTAT .Ne. 0 ) Then XMSG = 'Failure allocating grid vars' Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) End If - Grid_Data%NAME = name_lu - Grid_Data%LU_Type = cat_lu - - If ( ABFLUX .Or. HGBIDI .Or. MOSAIC ) Then - ALLOCATE( Met_Data%SOIM2 ( NCOLS,NROWS ), - & Met_Data%SOIT2 ( NCOLS,NROWS ), + Grid_Data%NAME = name_lu + Grid_Data%LU_Type = cat_lu + Grid_Data%WWLT = 0.0 + Grid_Data%WSAT = 0.0 + Grid_Data%WFC = 0.0 + Grid_Data%CLAY_PX = 0.0 + Grid_Data%CSAND_PX = 0.0 + Grid_Data%FMSAND_PX = 0.0 + + If ( BIOGEMIS_BEIS ) Then + ALLOCATE( Met_Data%SOIT2 ( NCOLS,NROWS ), & STAT = ALLOCSTAT ) If ( ALLOCSTAT .Ne. 0 ) Then - XMSG = 'Failure allocating mosaic met vars' + XMSG = 'Failure allocating layer 2 soil temperature' Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) End If + End If - ALLOCATE( Grid_Data%WSAT ( NCOLS,NROWS ), - & Grid_Data%WWLT ( NCOLS,NROWS ), - & Grid_Data%BSLP ( NCOLS,NROWS ), - & Grid_Data%WRES ( NCOLS,NROWS ), - & Grid_Data%WFC ( NCOLS,NROWS ), - & Grid_Data%LUFRAC ( NCOLS,NROWS,n_lufrac ), + If ( ABFLUX .or. BIOGEMIS_MEGAN ) Then + ALLOCATE( Met_Data%SOIM2 ( NCOLS,NROWS ), & STAT = ALLOCSTAT ) If ( ALLOCSTAT .Ne. 0 ) Then - XMSG = 'Failure allocating mosaic grid vars' + XMSG = 'Failure allocating layer 2 soil moisture' Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) End If - Grid_Data%WSAT = 0.0 - Grid_Data%WWLT = 0.0 - Grid_Data%WFC = 0.0 - Grid_Data%WRES = 0.0 - Grid_Data%BSLP = 0.0 + END IF + + If ( ABFLUX .or. HGBIDI ) Then - ALLOCATE( Mosaic_Data%USTAR ( NCOLS,NROWS,n_lufrac ), - & Mosaic_Data%LAI ( NCOLS,NROWS,n_lufrac ), - & Mosaic_Data%DELTA ( NCOLS,NROWS,n_lufrac ), - & Mosaic_Data%VEG ( NCOLS,NROWS,n_lufrac ), - & Mosaic_Data%Z0 ( NCOLS,NROWS,n_lufrac ), - & Mosaic_Data%RA ( NCOLS,NROWS,n_lufrac ), - & Mosaic_Data%RSTW ( NCOLS,NROWS,n_lufrac ), - & Mosaic_Data%RINC ( NCOLS,NROWS,n_lufrac ), - & Mosaic_Data%NAME ( n_lufrac ), - & Mosaic_Data%LU_Type ( n_lufrac ), - & STAT = ALLOCSTAT ) - If ( ALLOCSTAT .Ne. 0 ) Then - XMSG = 'Failure allocating mosaic vars' - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - Mosaic_Data%USTAR = 0.0 - Mosaic_Data%LAI = 0.0 - Mosaic_Data%DELTA = 0.0 - Mosaic_Data%VEG = 0.0 - Mosaic_Data%Z0 = 0.000001 - Mosaic_Data%RSTW = 0.0 - Mosaic_Data%RINC = 0.0 - Mosaic_Data%NAME = name_lu - Mosaic_Data%LU_Type = cat_lu - - ALLOCATE( ChemMos_Data%Rb ( NCOLS,NROWS,n_lufrac,ltotg ), - & ChemMos_Data%Rst ( NCOLS,NROWS,n_lufrac,ltotg ), - & ChemMos_Data%Rcut ( NCOLS,NROWS,n_lufrac,ltotg ), - & ChemMos_Data%Rgc ( NCOLS,NROWS,n_lufrac,ltotg ), - & ChemMos_Data%Rgb ( NCOLS,NROWS,n_lufrac,ltotg ), - & ChemMos_Data%Rwat ( NCOLS,NROWS,n_lufrac,ltotg ), - & ChemMos_Data%CZ0 ( NCOLS,NROWS,n_lufrac,ltotg ), - & ChemMos_Data%Cleaf ( NCOLS,NROWS,n_lufrac,ltotg ), - & ChemMos_Data%Cstom ( NCOLS,NROWS,n_lufrac,ltotg ), - & ChemMos_Data%Ccut ( NCOLS,NROWS,n_lufrac,ltotg ), - & ChemMos_Data%Csoil ( NCOLS,NROWS,n_lufrac,ltotg ), - & ChemMos_Data%NAME ( n_lufrac ), - & ChemMos_Data%LU_Type ( n_lufrac ), - & ChemMos_Data%Subname ( n_lufrac ), + ALLOCATE( Grid_Data%BSLP ( NCOLS,NROWS ), + & Grid_Data%WRES ( NCOLS,NROWS ), & STAT = ALLOCSTAT ) If ( ALLOCSTAT .Ne. 0 ) Then - XMSG = 'Failure allocating chemistry dependent mosaic vars' + XMSG = 'Failure allocating Soil grid vars' Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) End If - ChemMos_Data%Rb = resist_max - ChemMos_Data%Rst = resist_max - ChemMos_Data%Rcut = resist_max - ChemMos_Data%Rgc = resist_max - ChemMos_Data%Rgb = resist_max - ChemMos_Data%Rwat = resist_max - ChemMos_Data%CZ0 = 0.0 - ChemMos_Data%Cleaf = 0.0 - ChemMos_Data%Cstom = 0.0 - ChemMos_Data%Ccut = 0.0 - ChemMos_Data%Csoil = 0.0 - ChemMos_Data%NAME = name_lu - ChemMos_Data%LU_Type = cat_lu - ChemMos_Data%SubName = subname + + Grid_Data%WRES = 0.0 + Grid_Data%BSLP = 0.0 End If -!> ccccccccccccccccccccc canopy shade option!ccccccccccccccccccccc +!> ccccccccccccccccccccc canopy shade option!ccccccccccccccccccccc (Wei Li) CANOPY_SHADE = ENVYN( 'CTM_CANOPY_SHADE', & 'Flag for in-line canopy shading', & .FALSE., IOSX ) @@ -671,16 +742,16 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) End If End If -!> ccccccccccccccccccccc Fengsha option!ccccccccccccccccccccc +!> ccccccccccccccccccccc Fengsha option!ccccccccccccccccccccc (Wei Li) FENGSHA = ENVYN( CTM_WBDUST_FENGSHA, & 'Flag for in-line fengsha ', & .FALSE., IOSX ) - + IF ( FENGSHA ) THEN XMSG = 'Using the Fengsha Wind-Blown dust emission model...' CALL M3MSG2( XMSG ) END IF - + If ( FENGSHA ) Then ALLOCATE( Met_Data%CLAYF ( NCOLS,NROWS ), & Met_Data%SANDF ( NCOLS,NROWS ), @@ -693,49 +764,22 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) End If End If -!> ccccccccccccccccccccc enable backward compatiblity ccccccccccccccccccccc - - If ( .Not. desc3( met_cro_2d ) ) Then - xmsg = 'Could not get ' // MET_CRO_2D // ' file description' - Call m3exit( pname, JDATE, JTIME, xmsg, xstat2 ) - End If - - SPC = INDEX1( 'RA', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) rinv = .FALSE. ! Ra and Rst are in units s/m - - SPC = INDEX1( 'WR', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) ifwr = .True. ! canopy wetness is in METCRO2D - - SPC = INDEX1( 'Q2', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) ifq2 = .True. ! two meter mixing ratio in METCRO2D - SPC = INDEX1( 'TSEASFC', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) ifsst = .True. ! two meter SST in METCRO2D - - SPC = INDEX1( 'LH', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) iflh = .True. ! LH in METCRO2D +!> ccccccccccccccccccccc enable backward compatiblity ccccccccccccccccccccc - SPC = INDEX1( 'RCA', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) Then + IF (RCA_AVAIL) THEN vname_rc = 'RCA' Else vname_rc = 'RC' End If - SPC = INDEX1( 'RNA', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) Then + IF (RNA_AVAIL) THEN vname_rn = 'RNA' Else vname_rn = 'RN' End If - If ( .Not. desc3( met_dot_3d ) ) Then - xmsg = 'Could not get ' // MET_DOT_3D // ' file description' - Call m3exit( pname, JDATE, JTIME, xmsg, xstat2 ) - End If - - SPC = INDEX1( 'UWINDC', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) Then + If (UWINDC_AVAIL) Then vname_uc = 'UWINDC' CSTAGUV = .TRUE. Else @@ -743,189 +787,65 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) CSTAGUV = .FALSE. End If - SPC = INDEX1( 'VWINDC', NVARS3D, VNAME3D ) - If (SPC .Gt. 0) Then + If (VWINDC_AVAIL) Then vname_vc = 'VWINDC' Else vname_vc = 'VWIND' End If - If ( .Not. desc3( met_cro_3d ) ) Then - xmsg = 'Could not get ' // MET_CRO_3D // ' file description' - Call m3exit( pname, JDATE, JTIME, xmsg, xstat2 ) - End If - - V = INDEX1( 'PRES', NVARS3D, VNAME3D ) - If ( V .Ne. 0 ) Then - UNITSCK = UNITS3D( V ) - Else - XMSG = 'Could not get variable PRES from ' // MET_CRO_3D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - Select Case (UNITSCK) - Case ( 'PASCAL','pascal','Pascal','PA','pa','Pa' ) - CONVPA = 1.0 - P0 = 100000.0 - Case ( 'MILLIBAR','millibar','Millibar','MB','mb','Mb' ) - CONVPA = 1.0E-02 - P0 = 100000.0 * CONVPA - Case ( 'CENTIBAR','centibar','Centibar','CB','cb','Cb' ) - CONVPA = 1.0E-03 - P0 = 100000.0 * CONVPA - Case Default - XMSG = 'Units incorrect on ' // MET_CRO_3D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End Select - - MINKZ = .True. ! default - MINKZ = ENVYN( 'KZMIN', 'Kz min on flag', MINKZ, ALLOCSTAT ) - If ( ALLOCSTAT .Ne. 0 ) Write( LOGDEV,'(5X, A)' ) 'Kz min on flag' - Select Case( ALLOCSTAT ) - Case ( 1 ) - XMSG = 'Environment variable improperly formatted' - Call M3WARN( PNAME, JDATE, JTIME, XMSG ) - Case ( -1 ) - XMSG = 'Environment variable set, but empty ... Using default:' - Write( LOGDEV,'(5X, A)' ) XMSG - Case ( -2 ) - XMSG = 'Environment variable not set ... Using default:' - Write( LOGDEV,'(5X, A)' ) XMSG - End Select - If ( .Not. MINKZ ) Then XMSG = 'This run uses Kz0UT, *NOT* KZMIN in subroutine edyintb.' Write( LOGDEV,'(/5X, A, /)' ) XMSG End If -!> Open the met files - - Call SUBHFILE ( GRID_CRO_2D, GXOFF, GYOFF, - & STRTCOLGC2, ENDCOLGC2, STRTROWGC2, ENDROWGC2 ) - Call SUBHFILE ( MET_CRO_2D, GXOFF, GYOFF, - & STRTCOLMC2, ENDCOLMC2, STRTROWMC2, ENDROWMC2 ) - Call SUBHFILE ( MET_CRO_3D, GXOFF, GYOFF, - & STRTCOLMC3, ENDCOLMC3, STRTROWMC3, ENDROWMC3 ) - Call SUBHFILE ( MET_DOT_3D, GXOFF, GYOFF, - & STRTCOLMD3, ENDCOLMD3, STRTROWMD3, ENDROWMD3 ) - CALL SUBHFILE ( OCEAN_1, GXOFF, GYOFF, - & STRTCOL_O1, ENDCOL_O1, STRTROW_O1, ENDROW_O1 ) !> Get sigma coordinate variables - X3M => BUFF1D Do L = 1, NLAYS Grid_Data%DX3F( L ) = X3FACE_GD( L ) - X3FACE_GD( L-1 ) Grid_Data%RDX3F( L ) = 1.0 / Grid_Data%DX3F( L ) - X3M( L ) = 0.5 * ( X3FACE_GD( L ) + X3FACE_GD( L-1 ) ) + BUFF1D( L ) = 0.5 * ( X3FACE_GD( L ) + X3FACE_GD( L-1 ) ) End Do Do L = 1, NLAYS - 1 - Grid_Data%RDX3M( L ) = 1.0 / ( X3M( L+1 ) - X3M( L ) ) + Grid_Data%RDX3M( L ) = 1.0 / ( BUFF1D( L+1 ) - BUFF1D( L ) ) End Do Grid_Data%RDX3M( NLAYS ) = 0.0 -!> nullify pointer - Nullify( X3M ) - -!> reciprical of msfx2**2 -!> assign MSFX2 - MSFX2 => BUFF2D - VNAME = 'MSFX2' - If ( .Not. INTERPX( GRID_CRO_2D, VNAME, PNAME, - & STRTCOLGC2,ENDCOLGC2, STRTROWGC2,ENDROWGC2, 1,1, - & JDATE, JTIME, MSFX2 ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // GRID_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If +!> reciprocal of msfx2**2 Grid_Data%RMSFX4 = 1.0 / ( MSFX2**2 ) -!> nullify pointer - Nullify( MSFX2 ) - - VNAME = 'LON' - If ( .Not. INTERPX( GRID_CRO_2D, VNAME, PNAME, - & STRTCOLGC2,ENDCOLGC2, STRTROWGC2,ENDROWGC2, 1,1, - & JDATE, JTIME, Grid_Data%LON ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // GRID_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - VNAME = 'LAT' - If ( .Not. INTERPX( GRID_CRO_2D, VNAME, PNAME, - & STRTCOLGC2,ENDCOLGC2, STRTROWGC2,ENDROWGC2, 1,1, - & JDATE, JTIME, Grid_Data%LAT ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // GRID_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + Grid_Data%LON = LON - VNAME = 'LWMASK' - If ( .Not. INTERPX( GRID_CRO_2D, VNAME, PNAME, - & STRTCOLGC2,ENDCOLGC2, STRTROWGC2,ENDROWGC2, 1,1, - & JDATE, JTIME, Grid_Data%LWMASK ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // GRID_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + Grid_Data%LAT = LAT - VNAME = 'PURB' - If ( .Not. INTERPX( GRID_CRO_2D, VNAME, PNAME, - & STRTCOLGC2,ENDCOLGC2, STRTROWGC2,ENDROWGC2, 1,1, - & JDATE, JTIME, Grid_Data%PURB ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // GRID_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + Grid_Data%LWMASK = LWMASK - SOILCAT => BUFF2D - VNAME = 'SLTYP' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, SOILCAT ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + Grid_Data%PURB = PURB - Grid_Data%SLTYP = NINT( SOILCAT ) - Nullify( SOILCAT ) - - If ( ABFLUX .Or. MOSAIC ) Then - Do l = 1, n_lufrac - Write( vname,'( "LUFRAC_",I2.2 )' ) l - If ( .Not. INTERPX( GRID_CRO_2D, VNAME, PNAME, - & STRTCOLGC2,ENDCOLGC2, STRTROWGC2,ENDROWGC2, 1,1, - & JDATE, JTIME, Grid_Data%LUFRAC( :,:,l ) ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // GRID_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - End Do + Grid_Data%SLTYP = NINT( SOILCAT_A ) + Grid_Data%LUFRAC = LUFRAC - Forall( C = 1:MY_NCOLS, R = 1:MY_NROWS, Grid_Data%SLTYP(C,R) .Le. 11 ) - Grid_Data%WSAT( C,R ) = WSAT( Grid_Data%SLTYP( C,R ) ) + If ( (ABFLUX .or. HGBIDI .or. BIOGEMIS_MEGAN .or. BIOGEMIS_BEIS) .and. .not. PXSOIL_AVAIL) Then + Forall( C = 1:NCOLS, R = 1:NROWS, Grid_Data%SLTYP(C,R) .Le. N_SOIL_TYPE ) Grid_Data%WWLT( C,R ) = WWLT( Grid_Data%SLTYP( C,R ) ) + Grid_Data%WSAT( C,R ) = WSAT( Grid_Data%SLTYP( C,R ) ) + End Forall + End If + + If (.not. PXSOIL_AVAIL) Then + Forall( C = 1:NCOLS, R = 1:NROWS, Grid_Data%SLTYP(C,R) .Le. N_SOIL_TYPE ) Grid_Data%WFC ( C,R ) = WFC ( Grid_Data%SLTYP( C,R ) ) + End Forall + End If + + If ( ABFLUX .or. HGBIDI ) Then + Forall( C = 1:NCOLS, R = 1:NROWS, Grid_Data%SLTYP(C,R) .Le. N_SOIL_TYPE ) Grid_Data%WRES( C,R ) = WRES( Grid_Data%SLTYP( C,R ) ) Grid_Data%BSLP( C,R ) = BSLP( Grid_Data%SLTYP( C,R ) ) End Forall - End If - -!> Read fractional seawater and surf-zone coverage from the OCEAN file. -!> Store results in the OCEAN and SZONE arrays. - IF ( .NOT. OPEN3( OCEAN_1, FSREAD3, PNAME ) ) THEN - XMSG = 'Open failure for ' // OCEAN_1 - CALL M3WARN( PNAME, JDATE, JTIME, XMSG ) - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - END IF - - VNAME = 'OPEN' - If ( .Not. INTERPX( OCEAN_1, VNAME, PNAME, - & STRTCOL_O1,ENDCOL_O1, STRTROW_O1,ENDROW_O1, - & 1,1,JDATE, JTIME, Grid_Data%OCEAN ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // OCEAN_1 - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) End If - VNAME = 'SURF' - If ( .Not. INTERPX( OCEAN_1, VNAME, PNAME, - & STRTCOL_O1,ENDCOL_O1, STRTROW_O1,ENDROW_O1, - & 1,1,JDATE, JTIME, Grid_Data%SZONE ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // OCEAN_1 - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + Grid_Data%OCEAN = ocean + + Grid_Data%SZONE = szone MET_INITIALIZED = .true. @@ -933,7 +853,7 @@ Subroutine INIT_MET ( JDATE, JTIME, MOSAIC, ABFLUX, HGBIDI ) End Subroutine INIT_MET C======================================================================= - Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) + Subroutine GET_MET ( JDATE, JTIME, TSTEP ) C----------------------------------------------------------------------- C 30 Mar 01 J.Young: dyn alloc - Use HGRD_DEFN; replace INTERP3 with INTERPX; @@ -958,14 +878,10 @@ Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) Include SUBST_FILES_ID ! file name parameters Include SUBST_PE_COMM ! PE communication displacement and direction - Include SUBST_CONST ! constants C Arguments: Integer, Intent( IN ) :: JDATE, JTIME, TSTEP ! internal simulation date&time - Logical, Intent( IN ) :: MOSAIC - Logical, Intent( IN ) :: ABFLUX - Logical, Intent( IN ) :: HGBIDI C Parameters: Real, Parameter :: cond_min = 1.0 / resist_max ! minimum conductance [m/s] @@ -979,9 +895,6 @@ Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) Real FINT Real CPAIR, LV, QST Real TMPFX, TMPVTCON, TST, TSTV - Real, Pointer :: Es_Grnd ( :,: ) - Real, Pointer :: Es_Air ( :,: ) - Real, Pointer :: TV ( :,:,: ) Integer LP Integer C, R, L ! loop induction variables @@ -994,436 +907,148 @@ Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) C Interpolate file input variables and format for output C-------------------------------- MET_CRO_3D -------------------------------- - VNAME = 'ZH' - If ( .Not. INTERPX( MET_CRO_3D, VNAME, PNAME, - & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, - & JDATE, JTIME, Met_Data%ZH ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('ZH', jdate, jtime, Met_Data%ZH) - VNAME = 'PRES' - If ( .Not. INTERPX( MET_CRO_3D, VNAME, PNAME, - & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, - & JDATE, JTIME, Met_Data%PRES ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('PRES', jdate, jtime, Met_Data%PRES) - VNAME = 'PRESF' - If ( .Not. INTERPX( MET_CRO_3D, VNAME, PNAME, - & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS+1, - & JDATE, JTIME, Met_Data%PRESF ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('PRESF', jdate, jtime, Met_Data%PRESF) !(Wei Li) - VNAME = 'ZF' - If ( .Not. INTERPX( MET_CRO_3D, VNAME, PNAME, - & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, - & JDATE, JTIME, Met_Data%ZF ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - VNAME = 'DENS' - If ( .Not. INTERPX( MET_CRO_3D, VNAME, PNAME, - & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, - & JDATE, JTIME, Met_Data%DENS ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT 1 ) - End If + call interpolate_var ('UWINDA', jdate, jtime, Met_Data%UWINDA) !(Wei Li) + + call interpolate_var ('VWINDA', jdate, jtime, Met_Data%VWINDA) !(Wei Li) + + call interpolate_var ('ZF', jdate, jtime, Met_Data%ZF) + + call interpolate_var ('DENS', jdate, jtime, Met_Data%DENS) Met_Data%DENS1 = Met_Data%DENS( :,:,1 ) - VNAME = 'JACOBM' - If ( .Not. INTERPX( MET_CRO_3D, VNAME, PNAME, - & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, - & JDATE, JTIME, Met_Data%RJACM ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('JACOBM', jdate, jtime, Met_Data%RJACM) Met_Data%RJACM = 1.0 / Met_Data%RJACM - VNAME = 'JACOBF' - If ( .Not. INTERPX( MET_CRO_3D, VNAME, PNAME, - & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, - & JDATE, JTIME, Met_Data%RJACF ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('JACOBF', jdate, jtime, Met_Data%RJACF) Met_Data%RJACF = 1.0 / Met_Data%RJACF - VNAME = 'DENSA_J' - If ( .Not. INTERPX( MET_CRO_3D, VNAME, PNAME, - & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, - & JDATE, JTIME, Met_Data%RRHOJ ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('DENSA_J', jdate, jtime, Met_Data%RRHOJ) Met_Data%RRHOJ = 1.0 / Met_Data%RRHOJ - VNAME = 'TA' - IF ( .NOT. INTERPX( MET_CRO_3D, VNAME, PNAME, - & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, - & JDATE, JTIME, Met_Data%TA ) ) THEN - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D - CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - END IF - - VNAME = 'QV' - IF ( .NOT. INTERPX( MET_CRO_3D, VNAME, PNAME, - & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, - & JDATE, JTIME, Met_Data%QV ) ) THEN - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D - CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - END IF - - VNAME = 'QC' - IF ( .NOT. INTERPX( MET_CRO_3D, VNAME, PNAME, - & STRTCOLMC3,ENDCOLMC3, STRTROWMC3,ENDROWMC3, 1,NLAYS, - & JDATE, JTIME, Met_Data%QC ) ) THEN - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_3D - CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - END IF + call interpolate_var ('TA', jdate, jtime, Met_Data%TA) - VNAME = 'UWINDA' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,NLAYS, - & JDATE, JTIME, Met_Data%UWINDA ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('QV', jdate, jtime, Met_Data%QV) - VNAME = 'VWINDA' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,NLAYS, - & JDATE, JTIME, Met_Data%VWINDA ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('QC', jdate, jtime, Met_Data%QC) C-------------------------------- MET_CRO_2D -------------------------------- C Vegetation and surface vars - VNAME = 'LAI' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%LAI ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('LAI', jdate, jtime, Met_Data%LAI) - VNAME = 'VEG' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%VEG ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('VEG', jdate, jtime, Met_Data%VEG) - VNAME = 'ZRUF' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%Z0 ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('ZRUF', jdate, jtime, Met_Data%Z0) -C Canopy vars - If ( CANOPY_SHADE ) Then - VNAME = 'FCH' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%FCH ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) +C Canopy vars (Wei Li) + If ( CANOPY_SHADE ) Then + call interpolate_var ('FCH', jdate, jtime, Met_Data%FCH) + call interpolate_var ('FRT', jdate, jtime, Met_Data%FRT) + call interpolate_var ('CLU', jdate, jtime, Met_Data%CLU) + call interpolate_var ('POPU', jdate, jtime, Met_Data%POPU) + call interpolate_var ('LAIE', jdate, jtime, Met_Data%LAIE) + call interpolate_var ('C1R', jdate, jtime, Met_Data%C1R) + call interpolate_var ('C2R', jdate, jtime, Met_Data%C2R) + call interpolate_var ('C3R', jdate, jtime, Met_Data%C3R) + call interpolate_var ('C4R', jdate, jtime, Met_Data%C4R) End If - VNAME = 'FRT' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2,STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%FRT ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) +C FENGSHA vars (Wei Li) + If ( CANOPY_SHADE ) Then + call interpolate_var ('CLAYF', jdate, jtime, Met_Data%CLAYF) + call interpolate_var ('SANDF', jdate, jtime, Met_Data%SANDF) + call interpolate_var ('DRAG', jdate, jtime, Met_Data%DRAG) + call interpolate_var ('UTHR', jdate, jtime, Met_Data%UTHR) End If - VNAME = 'CLU' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2,STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%CLU ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - VNAME = 'POPU' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2,STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%POPU ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - VNAME = 'LAIE' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2,STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%LAIE ) ) Then - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - VNAME = 'C1R' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2,STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%C1R ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - VNAME = 'C2R' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2,STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%C2R ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - VNAME = 'C3R' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2,STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%C3R ) ) Then - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - VNAME = 'C4R' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2,STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%C4R ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - End If - -C FENGSHA vars - If ( FENGSHA ) Then - VNAME = 'CLAYF' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%CLAYF ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - VNAME = 'SANDF' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%SANDF ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - VNAME = 'DRAG' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%DRAG ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - VNAME = 'UTHR' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2,1,1, - & JDATE, JTIME, Met_Data%UTHR ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - End If C Soil vars - VNAME = 'SOIM1' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%SOIM1 ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - If ( ABFLUX .Or. HGBIDI .Or. MOSAIC ) Then - VNAME = 'SOIM2' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%SOIM2 ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('SOIM1', jdate, jtime, Met_Data%SOIM1) - VNAME = 'SOIT2' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%SOIT2 ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + If ( ABFLUX .or. BIOGEMIS_MEGAN) Then + call interpolate_var ('SOIM2', jdate, jtime, Met_Data%SOIM2) End If - VNAME = 'SOIT1' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%SOIT1 ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('SOIT1', jdate, jtime, Met_Data%SOIT1) - VNAME = 'SEAICE' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%SEAICE ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + If ( BIOGEMIS_BEIS ) Then + call interpolate_var ('SOIT2', jdate, jtime, Met_Data%SOIT2) End If + call interpolate_var ('SEAICE', jdate, jtime, Met_Data%SEAICE) + C met vars - VNAME = 'PRSFC' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%PRSFC ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('PRSFC', jdate, jtime, Met_Data%PRSFC) - VNAME = 'RGRND' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%RGRND ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('RGRND', jdate, jtime, Met_Data%RGRND) + + call interpolate_var ('SNOCOV', jdate, jtime, Met_Data%SNOCOV) - VNAME = 'SNOCOV' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%SNOCOV ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If Where( Met_Data%SNOCOV .Lt. 0.0 ) Met_Data%SNOCOV = 0.0 End Where - VNAME = 'TEMP2' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%TEMP2 ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('TEMP2', jdate, jtime, Met_Data%TEMP2) - VNAME = 'TEMPG' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%TEMPG ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('TEMPG', jdate, jtime, Met_Data%TEMPG) - VNAME = 'USTAR' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%USTAR ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('USTAR', jdate, jtime, Met_Data%USTAR) - VNAME = 'WSPD10' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%WSPD10 ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('WSPD10', jdate, jtime, Met_Data%WSPD10) - VNAME = 'HFX' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%HFX ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('HFX', jdate, jtime, Met_Data%HFX) - If ( iflh ) Then - VNAME = 'LH' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%LH ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + If ( LH_AVAIL ) Then + call interpolate_var ('LH', jdate, jtime, Met_Data%LH) Else ! for backward compatibility - VNAME = 'QFX' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%LH ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('QFX', jdate, jtime, Met_Data%LH) + End If + + call interpolate_var ('PBL', jdate, jtime, Met_Data%PBL) + + ! Update for WRFV4.1+ PX LSM runs that have soil texture in output for + ! CMAQ dust scheme. These are initialized to 0 if not present in MCIP. + ! DUST_EMIS.F will use table lookup values if 0 (old WRF or other LSMs). + If ( PXSOIL_AVAIL ) Then + call interpolate_var ('CLAY_PX', jdate, jtime, Grid_Data%CLAY_PX) + call interpolate_var ('CSAND_PX', jdate, jtime, Grid_Data%CSAND_PX) + call interpolate_var ('FMSAND_PX', jdate, jtime, Grid_Data%FMSAND_PX) + call interpolate_var ('WSAT_PX', jdate, jtime, Grid_Data%WSAT) + call interpolate_var ('WFC_PX', jdate, jtime, Grid_Data%WFC) + call interpolate_var ('WWLT_PX', jdate, jtime, Grid_Data%WWLT) End If - VNAME = 'PBL' - IF ( .NOT. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%PBL ) ) THEN - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - END IF C Met_cro_2D variables that have recently changed due to MCIP or WRF/CMAQ - If ( .Not. INTERPX( MET_CRO_2D, vname_rn, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%RN ) ) Then - XMSG = MSG1 // TRIM( vname_rn ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var (vname_rn, jdate, jtime, Met_Data%RN) - If ( .Not. INTERPX( MET_CRO_2D, vname_rc, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%RC ) ) Then - XMSG = MSG1 // TRIM( vname_rc ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - - If ( ifwr ) Then - VNAME = 'WR' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%WR ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var (vname_rc, jdate, jtime, Met_Data%RC) + + call interpolate_var ('CFRAC', jdate, jtime, Met_Data%CFRAC) + + If ( WR_AVAIL ) Then + call interpolate_var ('WR', jdate, jtime, Met_Data%WR) End If - If ( ifsst ) Then - VNAME = 'TSEASFC' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%TSEASFC ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + If ( TSEASFC_AVAIL ) Then + call interpolate_var ('TSEASFC', jdate, jtime, Met_Data%TSEASFC) Else Met_Data%TSEASFC = Met_Data%TEMPG End If - If ( rinv ) Then - VNAME = 'RADYNI' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%RA ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + If ( .not. RA_RS_AVAIL ) Then + call interpolate_var ('RADYNI', jdate, jtime, Met_Data%RA) Where( Met_Data%RA .Gt. cond_min ) Met_Data%RA = 1.0/Met_Data%RA @@ -1431,13 +1056,7 @@ Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) Met_Data%RA = resist_max End Where - VNAME = 'RSTOMI' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%RS ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('RSTOMI', jdate, jtime, Met_Data%RS) Where( Met_Data%RS .Gt. cond_min ) Met_Data%RS = 1.0 / Met_Data%RS @@ -1447,73 +1066,49 @@ Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) Else - VNAME = 'RA' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%RA ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('RA', jdate, jtime, Met_Data%RA) - VNAME = 'RS' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%RS ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + call interpolate_var ('RS', jdate, jtime, Met_Data%RS) End If - If ( ifq2 ) Then ! Q2 in METCRO2D - VNAME = 'Q2' - If ( .Not. INTERPX( MET_CRO_2D, VNAME, PNAME, - & STRTCOLMC2,ENDCOLMC2, STRTROWMC2,ENDROWMC2, 1,1, - & JDATE, JTIME, Met_Data%Q2 ) ) Then - XMSG = MSG1 // TRIM( VNAME ) // ' from ' // MET_CRO_2D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If + If ( Q2_AVAIL ) Then ! Q2 in METCRO2D + call interpolate_var ('Q2', jdate, jtime, Met_Data%Q2) Else Met_Data%Q2 = Met_Data%QV( :,:,1 ) End If - Es_Grnd => BUFF2D Where( Met_Data%TEMPG .Lt. stdtemp ) - Es_Grnd = vp0 *Exp( 22.514 - ( 6.15e3 / Met_Data%TEMPG ) ) + BUFF2D = vp0 *Exp( 22.514 - ( 6.15e3 / Met_Data%TEMPG ) ) Elsewhere - Es_Grnd = vp0 *Exp( svp2 * ( Met_Data%TEMPG -stdtemp ) / ( Met_Data%TEMPG -svp3 ) ) + BUFF2D = vp0 *Exp( svp2 * ( Met_Data%TEMPG -stdtemp ) / ( Met_Data%TEMPG -svp3 ) ) End Where - Met_Data%QSS_GRND = Es_Grnd * 0.622 / ( Met_Data%PRSFC - Es_Grnd ) - Nullify( Es_Grnd ) + Met_Data%QSS_GRND = BUFF2D * 0.622 / ( Met_Data%PRSFC - BUFF2D ) - Es_Air => BUFF2D Where( Met_Data%TEMP2 .Lt. stdtemp ) - Es_Air = vp0 *Exp( 22.514 - ( 6.15e3 / Met_Data%TEMP2 ) ) + BUFF2D = vp0 *Exp( 22.514 - ( 6.15e3 / Met_Data%TEMP2 ) ) Elsewhere - Es_Air = vp0 *Exp( svp2 * ( Met_Data%TEMP2 -stdtemp ) / ( Met_Data%TEMP2 -svp3 ) ) + BUFF2D = vp0 *Exp( svp2 * ( Met_Data%TEMP2 -stdtemp ) / ( Met_Data%TEMP2 -svp3 ) ) End Where - Met_Data%RH = Met_Data%Q2 / ( Es_Air * 0.622 / ( Met_Data%PRSFC - Es_Air ) ) * 100.0 - Where( Met_Data%RH .Gt. 100.0 ) - Met_Data%RH = 100.0 - Elsewhere( Met_Data%RH .lt. 0.0 ) - Met_Data%RH = 0.0 + + ! Calculate Relative Humidity at 2m + Met_Data%RH2 = Met_Data%Q2 / ( BUFF2D * 0.622 / ( Met_Data%PRSFC - BUFF2D ) ) * 100.0 + Where( Met_Data%RH2 .Gt. 100.0 ) + Met_Data%RH2 = 100.0 + Elsewhere( Met_Data%RH2 .lt. 0.0 ) + Met_Data%RH2 = 0.0 End Where - Nullify( Es_Air ) + + ! Calculate 3D Relative Humidity at Grid Scale + MET_DATA%RH = MET_DATA%QV * MET_DATA%PRES / ( MET_DATA%QV + 0.622015 ) / + & ( 610.94 * EXP( 17.625 * ( MET_DATA%TA - 273.15 ) / + & ( MET_DATA%TA - 273.15 + 243.04 ) ) ) + MET_DATA%RH = MIN( 0.9999, MAX( 0.001, MET_DATA%RH ) ) C-------------------------------- MET_DOT_3D -------------------------------- - If ( .Not. INTERPX( MET_DOT_3D, vname_uc, PNAME, - & STRTCOLMD3,ENDCOLMD3, STRTROWMD3,ENDROWMD3, 1,NLAYS, - & JDATE, JTIME, Met_Data%UWIND ) ) Then - XMSG = MSG1 // TRIM( vname_uc ) // ' from ' // MET_DOT_3D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT 1 ) - End If + call interpolate_var (vname_uc, jdate, jtime, Met_Data%UWIND) - If ( .Not. INTERPX( MET_DOT_3D, vname_vc, PNAME, - & STRTCOLMD3,ENDCOLMD3, STRTROWMD3,ENDROWMD3, 1,NLAYS, - & JDATE, JTIME, Met_Data%VWIND ) ) Then - XMSG = MSG1 // TRIM( vname_vc ) // ' from ' // MET_DOT_3D - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT 1 ) - End If + call interpolate_var (vname_vc, jdate, jtime, Met_Data%VWIND) C get ghost values for wind fields in case of free trop. CALL SUBST_COMM ( Met_Data%UWIND, DSPL_N0_E1_S0_W0, DRCN_E ) @@ -1535,14 +1130,12 @@ Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) Met_Data%KZMIN = KZ0UT END IF - TV => BUFF3D - TV = Met_Data%TA * ( 1.0 + 0.608 * Met_Data%QV ) - Met_Data%THETAV = TV * ( P0 / Met_Data%PRES ) ** 0.286 - Nullify( TV ) + BUFF3D = Met_Data%TA * ( 1.0 + 0.608 * Met_Data%QV ) + Met_Data%THETAV = BUFF3D * ( P0 / Met_Data%PRES ) ** 0.286 C------ Updating MOL, then WSTAR, MOLI, HOL - DO R = 1, MY_NROWS - DO C = 1, MY_NCOLS + DO R = 1, NROWS + DO C = 1, NCOLS ! CPAIR = 1004.67 * ( 1.0 + 0.84 * Met_Data%QV( C,R,1 ) ) ! J/(K KG) CPAIR = CPD * ( 1.0 + 0.84 * Met_Data%QV( C,R,1 ) ) ! J/(K KG) TMPFX = Met_Data%HFX( C,R ) / ( CPAIR * Met_Data%DENS( C,R,1 ) ) @@ -1576,8 +1169,8 @@ Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) C------ Met_Data%CONVCT = .FALSE. - DO R = 1, MY_NROWS - DO C = 1, MY_NCOLS + DO R = 1, NROWS + DO C = 1, NCOLS DO L = 1, NLAYS IF ( Met_Data%PBL( C,R ) .LT. Met_Data%ZF( C,R,L ) ) THEN LP = L; EXIT @@ -1603,6 +1196,9 @@ Subroutine GET_MET ( JDATE, JTIME, TSTEP, MOSAIC, ABFLUX, HGBIDI ) Met_Data%CONVCT = .True. End Where +! Calculate the cosine of the zenith angle + CALL CZANGLE(JDATE, JTIME, NCOLS, NROWS ) + Return End Subroutine GET_MET diff --git a/src/model/src/DUST_EMIS.F b/src/model/src/DUST_EMIS.F index a01d069..2ba5a5c 100644 --- a/src/model/src/DUST_EMIS.F +++ b/src/model/src/DUST_EMIS.F @@ -17,10 +17,6 @@ ! subject to their copyright restrictions. ! !------------------------------------------------------------------------! - -C RCS file, release, date & time of last delta, author, state, [and locker] -C $Header: /project/work/rep/arc/CCTM/src/emis/emis/DUST_EMIS.F,v 1.6 2011/10/21 16:10:45 yoj Exp $ - C::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: module dust_emis @@ -29,12 +25,6 @@ module dust_emis C * Extracts selected landuse categories from BELD01 and BELD03 and merges C * the selections into a dust-related landuse array (ULAND). -C Optionally, reads 3 gridded crop calendar file and calculates an -C erodible agriculture land fraction. (cropcal) - -C * Applies a predetermined removal fraction in and below canopy to -C * ULAND and determines a transport factor (TFB) for this regime. -C * = applies to tfbelow C Function: 3d point source emissions interface to the chemistry-transport model @@ -67,18 +57,23 @@ module dust_emis C Updated the dust diag output file accordingly. C 8 Jan 16 J.Young: Changes for computational efficiency C 2 Feb 16 J.Young: move dust aero speciation table to AERO_DATA +C 01 Feb 19 D.Wong: Implemented centralized I/O approach, removed all MY_N clauses +C 9 Jul 19 Gilliam: Removed a lot of old commented out legacy tables. +C Removed the direct read of FPAR MODIS file as this data comes +C directly from WRF LSM models that have access to MODIS veg data now. +C Number of soil types fixed to 16 to match WRF and tables updated. +C 3 Mar 22 Gilliam and Willison: Removed fugitive dust capture from canopies +C (tfa and tfb terms). Added soil texture information from PX when available. +C Removed deprecated option concerning erodable agland. Removed BELD as an option +C for input. C----------------------------------------------------------------------- use lus_defn use aero_data + use desid_vars implicit none -C windblown dust emissions rates - real, allocatable, save :: dustoutm( :,:,:,: ) ! mass emission rates [g/m**3/s] - real, allocatable, save :: dustoutn( :,:,: ) ! number emission rates [1/m**3/s] - real, allocatable, save :: dustouts( :,:,: ) ! surface-area emisrates [m2/m**3/s] - - public ndust_spc, dustoutm, dustoutn, dustouts, dust_spc, + public ndust_spc, dust_spc, & dust_emis_init, get_dust_emis private @@ -111,20 +106,17 @@ module dust_emis real, save :: factsrfj ! = pi * factm2j real, save :: factsrfk ! = pi * factm2k - real, save :: dustmode_dens( n_mode ) ! average modal density [kg/m**3] real :: sumsplit, sumfrac integer :: n, idx -C Number of soil types: For both WRF and MM5-PX met models, there are 16 types; -C the first 12 soil types are used and the rest lumped into Other. - integer, parameter :: nsltyp = 13 +C Number of soil types: For WRF there are 16 types; + integer, parameter :: nsltyp = 16 -C Variables for FENGSHA dust scheme +C Variables for FENGSHA dust scheme (Wei Li) real, save :: dust_alpha ! tuning parameter for FENGSHA dust emission flux C Variables for the windblown dust diagnostic file: - logical, save :: dustem_diag ! flag for dustemis diagnostic file - integer, parameter :: fndust_diag = 19 ! number of fixed diagnostic output vars + integer, parameter :: fndust_diag = 17 ! number of fixed diagnostic output vars integer, save :: ndust_diag ! number of diagnostic output vars real, allocatable, save :: diagv( : ) ! diagnostic output variables real, allocatable, save :: dustbf( :,:,: ) ! diagnostic accumulate buffer @@ -152,43 +144,34 @@ module dust_emis type( diag_type ), parameter :: fdiagnm( fndust_diag ) = (/ C var units desc C ---------------- -------- ------------------------------------------- - & diag_type( 'Cropland_Emis ', 'g/m**3/s', 'emissions for cropland landuse type '), - & diag_type( 'Desertland_Emis ', 'g/m**3/s', 'total emis for desert types and cropland '), - & diag_type( 'Cropland_Frac ', 'percent ', 'cropland erodible landuse fraction (%) '), - & diag_type( 'Desertland_Frac ', 'percent ', 'total desert fraction (%) '), - & diag_type( 'Cropland_Ustar ', 'm/s ', 'u* for cropland '), - & diag_type( 'Cropland_kvh ', '1/m ', 'cropland vert to horiz flux ratio '), - & diag_type( 'Cropland_Rough ', ' ', 'cropland surface roughness factor '), - & diag_type( 'Soil_Moist_Fac ', ' ', 'soil moisture factor for threshold u* '), - & diag_type( 'Soil_Erode_Pot ', ' ', 'soil -> dust erodiblity potential '), - & diag_type( 'Mx_Adsrb_H2O_Frc', ' ', 'max adsorbed water fraction '), - & diag_type( 'Vegetation_Frac ', ' ', 'vegetation land coverage '), - & diag_type( 'Urban_Cover ', 'percent ', 'urban land coverage '), - & diag_type( 'Forest_Cover ', 'percent ', 'forest land coverage '), - & diag_type( 'Trfac_Above_Can ', ' ', 'transport factor above canopy '), - & diag_type( 'Trfac_Inside_Can', ' ', 'transport factor in and below canopy '), - & diag_type( 'ANUMJ ', '#/s ', 'accumulation mode number '), - & diag_type( 'ANUMK ', '#/s ', 'coarse mode number '), - & diag_type( 'ASRFJ ', 'm**2/s ', 'accumulation mode surface area '), - & diag_type( 'ASRFK ', 'm**2/s ', 'coarse mode surface area ')/) + & diag_type( 'Cropland_Emis ', 'g m-3 s-1', 'emissions for cropland landuse type '), + & diag_type( 'Desertland_Emis ', 'g m-3 s-1', 'total emis for desert types and cropland '), + & diag_type( 'Cropland_Frac ', 'percent ', 'cropland erodible landuse fraction (%) '), + & diag_type( 'Desertland_Frac ', 'percent ', 'total desert fraction (%) '), + & diag_type( 'Cropland_Ustar ', 'm s-1 ', 'u* for cropland '), + & diag_type( 'Cropland_kvh ', 'm-1 ', 'cropland vert to horiz flux ratio '), + & diag_type( 'Cropland_Rough ', ' ', 'cropland surface roughness factor '), + & diag_type( 'Soil_Moist_Fac ', ' ', 'soil moisture factor for threshold u* '), + & diag_type( 'Soil_Erode_Pot ', '1 ', 'soil -> dust erodiblity potential '), + & diag_type( 'Mx_Adsrb_H2O_Frc', '1 ', 'max adsorbed water fraction '), + & diag_type( 'Vegetation_Frac ', '1 ', 'vegetation land coverage '), + & diag_type( 'Urban_Cover ', 'percent ', 'urban land coverage '), + & diag_type( 'Forest_Cover ', 'percent ', 'forest land coverage '), + & diag_type( 'ANUMJ ', 's-1', 'accumulation mode number '), + & diag_type( 'ANUMK ', 's-1', 'coarse mode number '), + & diag_type( 'ASRFJ ', 'm2 s-1 ', 'accumulation mode surface area '), + & diag_type( 'ASRFK ', 'm2 s-1 ', 'coarse mode surface area ')/) C Module shared variables: - real, allocatable, save :: agland( :,: ) ! agriculture land fraction real, allocatable, save :: wmax ( :,: ) ! max adsorb water percent real, allocatable, save :: kvh ( :,:,: ) ! ratio of vertical flux / horizontal (k factor) real, allocatable, save :: sd_ep ( :,: ) ! soil->dust erodiblity potential - real, allocatable, save :: tfb ( :,: ) ! transport fraction in and below canopy - real, allocatable, save :: fpar ( :,: ) ! modis fpar - - integer, save :: sdate, stime ! scenario start date & time real :: eropot( 3 ) = ! erodible potential of soil components & (/ 0.08, ! clay & 1.00, ! silt & 0.12 /) ! sand - integer, save :: logdev - CONTAINS C======================================================================= @@ -202,6 +185,8 @@ function dust_emis_init( jdate, jtime, tstep ) result( success ) use aero_data ! aerosol species definitions use asx_data_mod ! meteorology data use utilio_defn + use lus_data_module + use centralized_io_module C Arguments: integer, intent( in ) :: jdate ! current model date, coded YYYYDDD @@ -212,53 +197,68 @@ function dust_emis_init( jdate, jtime, tstep ) result( success ) C Includes: include SUBST_FILES_ID ! file name parameters -C External Functions: - integer, external :: setup_logdev - C Local variables: - character( 16 ) :: ctm_dustem_diag = 'CTM_DUSTEM_DIAG' ! env var for - ! diagnostic file - character( 16 ) :: ctm_erode_agland = 'CTM_ERODE_AGLAND' ! env var to - ! use erodible cropland character( 16 ) :: pname = 'DUST_EMIS_INIT' character( 16 ) :: vname character( 80 ) :: vardesc - character( 120 ) :: xmsg = ' ' - character( 16 ) :: modis_fpar_1 = 'MODIS_FPAR' - ! Fraction of Absorbed Photosynthetically Active Radiation + character( 250 ) :: xmsg = ' ' - logical :: erode_agland = .true. ! default integer status - integer c, r, i, j, k, l, n - integer idiag + integer c, r, i, j, k, l, n, im + integer idiag, idust, spc integer n_mass_emissions - integer gxoff, gyoff ! global origin offset from file - integer, save :: strtcol, endcol, strtrow, endrow - integer jdatemod + character( 16 ) :: sn type( diag_type ), allocatable :: diagnm_swap( : ) - interface - subroutine cropcal ( jdate, jtime, agland ) - integer, intent( in ) :: jdate, jtime - real, intent( out ) :: agland( :,: ) - end subroutine cropcal - subroutine tfbelow ( jdate, jtime, tfb ) - integer, intent( in ) :: jdate, jtime - real, intent( out ) :: tfb( :,: ) - end subroutine tfbelow - end interface C----------------------------------------------------------------------- - logdev = setup_logdev() success = .true. - - allocate ( dustoutm( ndust_spc,n_mode,ncols,nrows ), - & dustoutn( n_mode,ncols,nrows ), - & dustouts( n_mode,ncols,nrows ), stat = status ) + CALL LOG_MESSAGE( LOGDEV, 'Initialize Wind-Blown Dust Emissions' ) + +C...Populate Master Emissions Map Vector So That Diagnostics +C can be printed in EMIS_MAP + DESID_EMVAR( IDUSTSRM )%len = ndust_spc*2 + Allocate( DESID_EMVAR( IDUSTSRM )%arry( ndust_spc*2 ) ) + Allocate( DESID_EMVAR( IDUSTSRM )%units( ndust_spc*2 ) ) + Allocate( DESID_EMVAR( IDUSTSRM )%mw ( ndust_spc*2 ) ) + Allocate( DESID_EMVAR( IDUSTSRM )%used ( ndust_spc*2 ) ) + Allocate( DESID_EMVAR( IDUSTSRM )%conv ( ndust_spc*2 ) ) + Allocate( DESID_EMVAR( IDUSTSRM )%basis( ndust_spc*2 ) ) + Allocate( DESID_EMVAR( IDUSTSRM )%larea( ndust_spc*2 ) ) + Allocate( DESID_EMVAR( IDUSTSRM )%lareaadj( ndust_spc*2 ) ) + DESID_EMVAR( IDUSTSRM )%arry( : ) = 'NOT_AVAILABLE' + do i = 1,ndust_spc + IF ( dust_spc( i )%spcfac(1) .NE. 0.0 ) + & DESID_EMVAR( IDUSTSRM )%arry( i ) = + & 'PMFINE_' // dust_spc(i)%name + IF ( dust_spc( i )%spcfac(2) .NE. 0.0 ) + & DESID_EMVAR( IDUSTSRM )%arry( i+ndust_spc ) = + & 'PMCOARSE_' // dust_spc(i)%name + DESID_EMVAR( IDUSTSRM )%mw( i ) = dust_spc(i)%mw + DESID_EMVAR( IDUSTSRM )%mw( i+ndust_spc ) = dust_spc(i)%mw + end do + DESID_EMVAR( IDUSTSRM )%units( : ) = 'G/S' + DESID_EMVAR( IDUSTSRM )%used ( : ) = .FALSE. + DESID_EMVAR( IDUSTSRM )%conv ( : ) = 1.0 + DESID_EMVAR( IDUSTSRM )%basis( : ) = 'MASS' + DESID_EMVAR( IDUSTSRM )%larea( : ) = .FALSE. + DESID_EMVAR( IDUSTSRM )%lareaadj( : ) = .FALSE. + +C...Count the number of mass emissions species + n_mass_emissions = 0 + do i = 1, ndust_spc + do j = 1, 2 + if( dust_spc( i )%spcfac( j ) .gt. 0. ) + & n_mass_emissions = n_mass_emissions + 1 + end do + end do + allocate ( dustoutm( ndust_spc*2,ncols,nrows ), + & dustoutn( 2,ncols,nrows ), + & dustouts( 2,ncols,nrows ), stat = status ) if ( status .ne. 0 ) then xmsg = '*** Failure allocating DUSTOUTM, DUSTOUTN, or DUSTOUTS' call m3warn ( pname, jdate, jtime, xmsg ) @@ -273,77 +273,39 @@ end subroutine tfbelow success = .false.; return end if - if ( fengsha ) then + !add fengsha scheme (Wei Li) + if ( fengsha ) then C Disable diagnostic output if FENGSHA is used - dustem_diag = .false. + dustem_diag = .false. -C Allocate private arrays - allocate( tfb( ncols,nrows ), stat = status ) +C Allocate private arrays ! not used for now (Wei Li) + !allocate( tfb( ncols,nrows ), stat = status ) - if ( status .ne. 0 ) then - xmsg = '*** Failure allocating WMAX or TFB' - call m3warn( pname, jdate, jtime, xmsg ) - success = .false.; return - end if + if ( status .ne. 0 ) then + xmsg = '*** Failure allocating WMAX or TFB' + call m3warn( pname, jdate, jtime, xmsg ) + success = .false.; return + end if C Initialize land use/cover variables - if ( .not. lus_init( jdate, jtime ) ) then - xmsg = 'Failure initializing land use module' - call m3exit( pname, jdate, jtime, xmsg, xstat2 ) - end if + if ( .not. lus_init( jdate, jtime ) ) then + xmsg = 'Failure initializing land use module' + call m3exit( pname, jdate, jtime, xmsg, xstat2 ) + end if - else + else !else fengsha is off & default is on C Allocate private arrays - allocate( agland( ncols,nrows ), - & wmax ( ncols,nrows ), - & sd_ep ( ncols,nrows ), - & fpar ( ncols,nrows ), - & tfb ( ncols,nrows ), stat = status ) + allocate( wmax ( ncols,nrows ), + & sd_ep ( ncols,nrows ), stat = status) if ( status .ne. 0 ) then - xmsg = '*** Failure allocating AGLAND, WMAX, FPAR, SD_EP, or TFB' + xmsg = '*** Failure allocating WMAX, or SD_EP' call m3warn( pname, jdate, jtime, xmsg ) success = .false.; return end if - agland = 0.0 ! array assignment wmax = 0.0 ! array assignment sd_ep = 0.0 ! array assignment - fpar = 0.0 ! array assignment - -C Open MODIS file to get vegetation fraction - if ( .not. open3( modis_fpar_1, fsread3, pname ) ) then - xmsg = 'Could not open ' // modis_fpar_1 - call m3exit( pname, jdate, jtime, xmsg, xstat1 ) - end if - -C Get the file description - if ( .not. desc3( modis_fpar_1 ) ) then - xmsg = 'Could not get ' - & // trim( modis_fpar_1 ) - & // ' file description' - call m3exit( pname, jdate, jtime, xmsg, xstat1 ) - end if - -C To be able to use either climatological (2001-2010 averaged) or -C current fpar value. The year for the climatological fpar is 2005 in -C the input file. - if ( sdate3d .eq. 2005001 ) then ! climatological - jdatemod = 2005000 + mod( jdate,1000 ) - else ! current - jdatemod = jdate - end if - -C Get domain decomp info - call subhfile ( modis_fpar_1, gxoff, gyoff, - & strtcol, endcol, strtrow, endrow ) - -C Read in FPAR from MODIS file - xmsg = 'Could not read FPAR from ' // trim( modis_fpar_1 ) - if ( .not. xtract3( modis_fpar_1, 'MODIS_FPAR_T', 1,1, - & strtrow,endrow,strtcol,endcol, - & jdatemod, jtime, fpar( 1,1 ) ) ) - & call m3exit ( pname, jdate, jtime, xmsg, xstat1 ) C Initialize land use/cover variables if ( .not. lus_init( jdate, jtime ) ) then @@ -351,23 +313,6 @@ end subroutine tfbelow call m3exit( pname, jdate, jtime, xmsg, xstat2 ) end if -C Get env var for diagnostic output - dustem_diag = .false. ! default - vardesc = 'Flag for writing the windblown dust emission diagnostic file' - dustem_diag = envyn( ctm_dustem_diag, vardesc, dustem_diag, status ) - if ( status .ne. 0 ) write( logdev,'( 5x, a )' ) vardesc - if ( status .eq. 1 ) then - xmsg = 'Environment variable improperly formatted' - call m3warn( pname, jdate, jtime, xmsg ) - success = .false.; return - else if ( status .eq. -1 ) then - xmsg = 'Environment variable set, but empty ... Using default:' - write( logdev,'( 5x, a, i9 )' ) xmsg, jtime - else if ( status .eq. -2 ) then - xmsg = 'Environment variable not set ... Using default:' - write( logdev,'( 5x, a, i9 )' ) xmsg, jtime - end if - if ( dustem_diag ) then ! Open the emissions diagnostic file C Set up variable diagnostic names (from LUS_DEFN) @@ -387,15 +332,7 @@ end subroutine tfbelow vdiagnm_kvh = diag_type( ' ', ' ', ' ' ) ! array assignment vdiagnm_rough = diag_type( ' ', ' ', ' ' ) ! array assignment -C...Count the number of mass emissions species - n_mass_emissions = 0 - do i = 1, ndust_spc - do j = 1, n_mode - if( len_trim( dust_spc( i )%name( j ) ) .lt. 1 )cycle - n_mass_emissions = n_mass_emissions + 1 - end do - end do - +C...Set Up Diagnostic Species Variables ndust_diag = fndust_diag + 5 * n_dlcat + n_mass_emissions do i = 1, n_dlcat @@ -480,35 +417,30 @@ end subroutine tfbelow end do C...append diagnostic variables with mass emissions species - do j = 2, n_mode + do j = 1, 2 do i = 1, ndust_spc - n = len_trim( dust_spc( i )%name( j ) ) - if( n .lt. 1 )cycle ! assumes cmaq species names atleast one character long - n = 0 - do k = 1, idiag ! determine if dust emissions is already added to diagnostic output - if( dust_spc( i )%name( j ) .Eq. diagnm( k )%var )Then + if( dust_spc( i )%spcfac( j ) .eq. 0. ) cycle + n = 0 + do k = 1, idiag ! determine if dust emissions is already added to diagnostic output + if( trim( DESID_EMVAR( IDUSTSRM )%ARRY( (j-1)*ndust_spc+i )) + & .Eq. diagnm( k )%var ) Then n = k exit end if end do - if( n .gt. 0 )then ! skip already added - cycle - else - idiag = idiag + 1 - diagnm( idiag )%var = dust_spc( i )%name( j ) - end if + if( n .gt. 0 ) cycle ! skip already added + + idiag = idiag + 1 + diagnm( idiag )%var = DESID_EMVAR( IDUSTSRM )%ARRY( (j-1)*ndust_spc+i ) diagnm( idiag )%units = 'g/m**3/s' + Select Case( j ) ! assumes only two aerosol modes dust emissions -! Case( 1 ) -! diagnm( idiag )%desc = 'aitken mode' - Case( 2 ) - diagnm( idiag )%desc = 'accumulation mode' - Case( 3 ) - diagnm( idiag )%desc = 'coarse mode' -! Case Default -! diagnm( idiag )%des = 'Undefined mode ' - end Select - diagnm( idiag )%desc = Trim( diagnm( idiag )%desc ) + Case( 1 ) + diagnm( idiag )%desc = 'fine mode' + Case( 2 ) + diagnm( idiag )%desc = 'coarse mode' + end Select + diagnm( idiag )%desc = Trim( diagnm( idiag )%desc ) & // ' emissions for ' & // Trim( dust_spc( i )%description ) end do @@ -521,7 +453,7 @@ end subroutine tfbelow call m3warn( pname, jdate, jtime, xmsg ) success = .false.; return end if - diagnm_swap = diagnm + diagnm_swap = diagnm deallocate( diagnm ) @@ -535,47 +467,12 @@ end subroutine tfbelow diagnm( 1:ndust_diag ) = diagnm_swap( 1:ndust_diag ) deallocate( diagnm_swap ) - sdate = envint( 'CTM_STDATE', 'Scenario Start (YYYYJJJ)', 0, status ) - stime = envint( 'CTM_STTIME', 'Scenario Start (HHMMSS)', 0, status ) - if ( io_pe_inclusive ) - & call opdust_emis ( sdate, stime, tstep, ndust_diag, diagnm ) + & call opdust_emis ( stdate, sttime, tstep, ndust_diag, diagnm ) end if ! dustem_diag -C Get env var for erodible agriculture land fraction - erode_agland = .false. ! default - vardesc = 'Flag for calculating erodible agriculture land fraction' - erode_agland = envyn( ctm_erode_agland, vardesc, erode_agland, status ) - if ( status .ne. 0 ) write( logdev,'( 5x, a )' ) vardesc - if ( status .eq. 1 ) then - xmsg = 'Environment variable improperly formatted' - call m3warn( pname, jdate, jtime, xmsg ) - success = .false.; return - else if ( status .eq. -1 ) then - xmsg = 'Environment variable set, but empty ... Using default:' - write( logdev,'( 5x, a, i9 )' ) xmsg, jtime - else if ( status .eq. -2 ) then - xmsg = 'Environment variable not set ... Using default:' - write( logdev,'( 5x, a, i9 )' ) xmsg, jtime - end if - - if ( erode_agland ) then - call cropcal ( sdate, stime, agland ) - do r = 1, my_nrows - do c = 1, my_ncols - if ( agland( c,r ) .lt. 0.0 .or. agland( c,r ) .gt. 100.0 ) then - xmsg = '*** ERROR in AGLAND' - call m3exit( pname, jdate, jtime, xmsg, xstat1 ) - end if - end do - end do - end if - - end if ! dust scheme - -C Get transport factor within canopy and 4 land use type percents - call tfbelow ( jdate, jtime, tfb ) + end if ! end dust scheme (Wei Li) l2sgj = log( sigj ) * log( sigj ) l2sgk = log( sigk ) * log( sigk ) @@ -590,29 +487,12 @@ end subroutine tfbelow factsrfj = pi * factm2j factsrfk = pi * factm2k -C Calculate modal average dust particle densities (accum and coarse modes) [ kg/m**3 ] -C The following works because the dust_spc`s are a fixed split of the total emitted -C mass. - dustmode_dens( 1 ) = 0.0 - do n = 2, n_mode - sumsplit = 0.0; sumfrac = 0.0 - do i = 1, ndust_spc - idx = findAero( dust_spc( i )%name( n ), .true. ) - if( aerospc( idx )%tracer )cycle - if( dust_spc( i )%spcfac( n ) .lt. 1.0e-30 )cycle - sumsplit = sumsplit + dust_spc( i )%spcfac( n ) ! should = 1.0 - sumfrac = sumfrac + dust_spc( i )%spcfac( n ) / aerospc( idx )%density - end do - dustmode_dens( n ) = sumsplit / sumfrac - end do - #ifdef verbose_wbdust write( logdev,* ) ' ' write( logdev,* ) ' l2sgj,l2sgk: ', l2sgj, l2sgk write( logdev,* ) ' factnumj,factnumk: ', factnumj, factnumk write( logdev,* ) ' factm2j,factm2k: ', factm2j, factm2k write( logdev,* ) ' factsrfj,factsrfk: ', factsrfj, factsrfk - write( logdev,* ) ' modal avg dens(j/k): ', dustmode_dens( 2 ), dustmode_dens( 3 ) write( logdev,* ) ' ' #endif @@ -707,23 +587,29 @@ subroutine opdust_emis ( jdate, jtime, tstep, ndust_var, dust_var ) end subroutine opdust_emis C======================================================================= - subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt ) + subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt, + & l_desid_diag) use grid_conf ! horizontal & vertical domain specifications use asx_data_mod ! meteorology data use aero_data use utilio_defn + use lus_data_module + use centralized_io_module + use RUNTIME_VARS, only: WRF_V4P C 8/18/11 D.Wong: incorporated twoway model implementation and change C RC -> RCA and RN -> RNA and made it backward compatible C 8/12/15 D.Wong: added code to handle parallel I/O implementation C Arguments: - integer, intent( in ) :: jdate ! current model date, coded YYYYDDD - integer, intent( in ) :: jtime ! current model time, coded HHMMSS - integer, intent( in ) :: tstep( 3 ) ! output time step, sync step, 2way step + integer, intent( in ) :: jdate ! current model date, coded YYYYDDD + integer, intent( in ) :: jtime ! current model time, coded HHMMSS + integer, intent( in ) :: tstep( 3 ) ! output time step, sync step, 2way step real, intent( in ) :: rjacm( ncols,nrows ) ! reciprocal Jacobian [1/m] - real, intent( in ) :: cellhgt ! grid-cell height [sigma] + real, intent( in ) :: cellhgt ! grid-cell height [sigma] + logical, intent( in ) :: l_desid_diag ! flag determining whether or not DESID + ! is in diagnostic mode C Includes: include SUBST_FILES_ID ! file name parameters @@ -738,7 +624,6 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt ) ! 4 Clay real, parameter :: f6dpi = 6.0 / pi - real, parameter :: gpkg = 1.0e03 ! g/kg real, parameter :: mv = 0.16 real, parameter :: sigv = 1.45 @@ -751,13 +636,15 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt ) real, parameter :: sigb_mb = sigb * mb ! = 0.5 real, parameter :: betab_mb = betab * mb ! = 45.0 + !(Wei Li) character( 24 ) :: ctm_wbdust_fengsha_alpha = 'CTM_WBDUST_FENGSHA_ALPHA' ! env var to ! retrieve FENGSHA scaling factor + character( 16 ) :: pname = 'GET_DUST_EMIS' character( 16 ) :: vname character( 96 ) :: xmsg integer status - integer c, r, j, m, n, v + integer c, r, j, m, n, v, isd integer, save :: wstep = 0 ! local write counter integer :: mdate, mtime ! diagnostic file write date&time @@ -765,7 +652,6 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt ) ! automatic arrays real :: fmoit ( ncols,nrows ) ! factor of soil moisture on u*t real :: soimt ( ncols,nrows ) ! gravimetric soil moisture (Kg/Kg) - real :: tfa ( ncols,nrows ) ! transport fraction above canopy real :: wrbuf ( ncols,nrows ) ! diagnositc write buffer real :: vegfrac( ncols,nrows ) ! vegetation fraction real :: vegfree ! 1.0 - vegfrac for this col, row @@ -776,7 +662,7 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt ) real, allocatable, save :: elus ( :,:,: ) ! erodible landuse percent (0~100) real, allocatable, save :: fruf ( :,:,: ) ! surface roughness factor - real :: edust( n_mode ) ! mass emis rate [g/s] per mode (only accum & coarse) + real :: edust( 2 ) ! mass emis rate [g/s] per mode (only accum & coarse) real :: sumdfr ! sum var for desert fraction real :: rlay1hgt ! reciprocal of layer-1 height [1/m] real :: m3j ! 3rd moment accumulation (J) mode emis rates [m3/m3/s] @@ -791,30 +677,14 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt ) real :: lambdav ! vegetation roughness density - Shao et. al [Aus. J. Soil Res., 1996] real :: flxfac1, flxfac2 ! combined soli type mapping factors real :: hflux, vflux ! horizontal and vertical dust flux - real :: v2h ! vertical/horizontal dust flux ratio - real :: wm ! max adsorb water [%] + real :: v2h ! vertical/horizontal dust flux ratio !(Wei Li) + real :: wm ! max adsorb water [%] !(Wei Li) real :: jday integer :: emap( n_dlcat+1 ) C---Height for veg elements real :: hv( 4 ) -C---Vegetation fraction for 4 land types ! not used -C from Federal Geographic Data Committee [1997] -C Note: All other landuse types are mapped into these 4 types. -! real :: vegfra( 4 ) = -! & (/ 0.11, ! shrubland -! & 0.17, ! shrubgrass -! & 0.01, ! barrenland -! & 0.30 /) ! cropland - -C---Height for solid elements -! real :: hb( 4 ) = -! & (/ 0.01, ! shrubland -! & 0.02, ! shrubgrass -! & 0.005, ! barrenland -! & 0.02 /) ! cropland - C---Roughness density for solid elements C from Darmenova et al. [JGR,2009] and Xi and Sokolik [JGR,2015] real :: lambdab( 4 ) = @@ -830,48 +700,6 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt ) & 2.0e-06, ! barrenland & 3.0e-03 /) ! cropland -C Soil moisture limit: 13 types and 3 variables, which are: -C 1 - saturation moisture limit, (gravimetric units assumed, Kg/Kg) - !!!! This is probably volumetric-- NOAH -C 2 - fill capacity, and <- not used -C 3 - wilting point <- not used -C Modified values compatiable with both MM5 & NAM. -C Silt values are based on NAM documentation on soil types. -C Other includes all types higher than 12. The values of Other, serving as -C placeholders, are randomly chosen. Values of Other, however, have no effect -C on dust emissions as the threshold velocity of Other will be high. -C real :: soilml( nsltyp,3 ) = reshape ( -C & (/ 0.395, 0.135, 0.068, ! Sand -C & 0.410, 0.150, 0.075, ! Loamy Sand -C & 0.435, 0.195, 0.114, ! Sandy Loam -C & 0.485, 0.255, 0.179, ! Silt Loam -C & 0.476, 0.361, 0.084, ! Silt -C & 0.451, 0.240, 0.155, ! Loam -C & 0.420, 0.255, 0.175, ! Sandy Clay Loam -C & 0.477, 0.322, 0.218, ! Silty Clay Loam -C & 0.476, 0.325, 0.250, ! Clay Loam -C & 0.426, 0.310, 0.219, ! Sandy Clay -C & 0.482, 0.370, 0.283, ! Silty Clay -C & 0.482, 0.367, 0.286, ! Clay -C & 0.482, 0.367, 0.286 /), ! Other -C & (/ nsltyp,3 /), order = (/ 2,1 /) ) ! fill columns first - -C Since only soilml( nsltyp,1 ) is used, set the following: -! real :: soilml1( nsltyp ) = -! & (/ 0.395, ! Sand -! & 0.410, ! Loamy Sand -! & 0.435, ! Sandy Loam -! & 0.485, ! Silt Loam -! & 0.476, ! Silt -! & 0.451, ! Loam -! & 0.420, ! Sandy Clay Loam -! & 0.477, ! Silty Clay Loam -! & 0.476, ! Clay Loam -! & 0.426, ! Sandy Clay -! & 0.482, ! Silty Clay -! & 0.482, ! Clay -! & 0.482 /) ! Other - C converted to gravimetric [kg/kg] real :: soilml1( nsltyp ) = & (/ 0.242, ! Sand @@ -886,40 +714,10 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt ) & 0.284, ! Sandy Clay & 0.357, ! Silty Clay & 0.344, ! Clay - & 0.363 /) ! Other - -!! FROM NCAR LSM Group 17 Apr 2007 "volumetric" -!! ALSO in Spyrou, et al. [JGR,2010] -! real :: soilml1( nsltyp ) = -! & (/ 0.339, ! Sand -! & 0.421, ! Loamy Sand -! & 0.434, ! Sandy Loam -! & 0.476, ! Silt Loam -! & 0.476, ! Silt -! & 0.439, ! Loam -! & 0.404, ! Sandy Clay Loam -! & 0.464, ! Silty Clay Loam -! & 0.465, ! Clay Loam -! & 0.406, ! Sandy Clay -! & 0.468, ! Silty Clay -! & 0.468, ! Clay -! & 0.482 /) ! Other - -C convert to gravimetric [kg/kg] -! real :: soilml1( nsltyp ) = -! & (/ 0.208, ! Sand -! & 0.264, ! Loamy Sand -! & 0.286, ! Sandy Loam -! & 0.344, ! Silt Loam -! & 0.350, ! Silt -! & 0.299, ! Loam -! & 0.266, ! Sandy Clay Loam -! & 0.341, ! Silty Clay Loam -! & 0.324, ! Clay Loam -! & 0.271, ! Sandy Clay -! & 0.347, ! Silty Clay -! & 0.334, ! Clay -! & 0.363 /) ! Other + & 0.329, ! Organic Material + & 0.000, ! Water + & 0.170, ! BedRock + & 0.280 /) ! Other C---Soil texture: the amount of C 1: Coarse sand, 2: Fine-medium sand, 3: Silt, 4: Clay @@ -937,9 +735,13 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt ) & 0.00, 0.52, 0.06, 0.42, ! Sandy Clay & 0.00, 0.06, 0.47, 0.47, ! Silty Clay & 0.00, 0.22, 0.20, 0.58, ! Clay + & 0.00, 0.00, 0.00, 0.00, ! Organic Material + & 0.00, 0.00, 0.00, 0.00, ! Water + & 0.00, 0.00, 0.00, 0.00, ! BedRock & 0.00, 0.00, 0.00, 0.00 /), ! Other & (/ nsltyp,4 /), order = (/ 2,1 /) ) ! fill columns first + C---Mean mass median particle diameter (m) for each soil texture type C Chatenet et al. [Sedimentology,1996] and Menut et al. [JGR,2013] real :: dp( ndp ) = @@ -947,12 +749,10 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt ) & 210.0E-6, ! Fine-medium sand & 125.0E-6, ! Silt & 2.0E-6 /) ! Clay +C---Soil texture vars of the grid cell + real :: soiltxt_gcell( ndp ) + real :: clay, csand, fmsand, sandf, siltf - interface - subroutine tfabove ( tfa ) - real, intent( out ) :: tfa( :,: ) - end subroutine tfabove - end interface #ifdef verbose_wbdust integer dryhit @@ -963,38 +763,39 @@ end subroutine tfabove if ( firstime ) then firstime = .false. - if ( fengsha ) then + !call dust_alpha from env variable (Wei Li) + if ( fengsha ) then dust_alpha = 0.05 ! default dust_alpha = envreal( ctm_wbdust_fengsha_alpha, - & 'Emission global scaling factor for FENGSHA dust scheme', - & dust_alpha, status ) + & 'Emission global scaling factor for FENGSHA dust scheme', + & dust_alpha, status ) if ( status .ne. 0 ) then xmsg = '*** Failure retrieving FENGSHA scaling factor' call m3exit( pname, jdate, jtime, xmsg, xstat1 ) end if write(xmsg,'("Using FENGSHA alpha = ",g12.5)') dust_alpha - call m3msg2 ( xmsg ) - else + call m3msg2 ( xmsg ) !from AQM/src/io/ioapi/m3msg2.F90 + !if envreal is not found (from IOAPI app); try below from 'get_env_module' + !The ctm_wbdust_fengsha_alpha = 'CTM_WBDUST_FENGSHA_ALPHA' can be deleted + !call GET_ENV(dust_alpha, 'CTM_WBDUST_FENGSHA_ALPHA', dust_alpha, VARDEV) + else !else is default scheme allocate ( ustr( ncols,nrows,n_dlcat+1 ), - & qam( ncols,nrows,n_dlcat+1 ), - & fruf( ncols,nrows,n_dlcat+1 ), - & kvh( ncols,nrows,n_dlcat+1 ), - & elus( ncols,nrows,n_dlcat+1 ), stat = status ) + & qam( ncols,nrows,n_dlcat+1 ), + & fruf( ncols,nrows,n_dlcat+1 ), + & kvh( ncols,nrows,n_dlcat+1 ), + & elus( ncols,nrows,n_dlcat+1 ), stat = status ) if ( status .ne. 0 ) then xmsg = '*** Failure allocating USTR, QAM, FRUF, KVH, or ELUS' call m3exit( pname, jdate, jtime, xmsg, xstat1 ) end if - end if + end if !end fengsha end if -C---Calculate transport factor above the canopy - call tfabove ( tfa ) - C---Select dust scheme - if ( fengsha ) then + if ( fengsha ) then - do r = 1, my_nrows - do c = 1, my_ncols + do r = 1, nrows + do c = 1, ncols dust_em( c,r ) = 0.0 soimt( c,r ) = 0.0 @@ -1041,15 +842,15 @@ end subroutine tfabove vflux = v2h * hflux ! [g/m**2/s] rlay1hgt = rjacm ( c,r ) / cellhgt - - dust_em( c,r ) = dust_alpha * vflux * rlay1hgt * tfa(c,r) * tfb(c,r) + !tfb and tfa not used for now (Wei Li) + dust_em( c,r ) = dust_alpha * vflux * rlay1hgt !* tfa(c,r) * tfb(c,r) end if ! if rain & land & snow & drag end do ! c end do ! r - else ! default dust scheme + else ! default dust scheme C---Get Julian day number in year jday = float( mod( jdate,1000 ) ) @@ -1083,7 +884,7 @@ end subroutine tfabove #endif C Initialize windblown dust diagnostics output buffer - if ( dustem_diag .and. wstep .eq. 0 ) then + if ( dustem_diag .and. wstep .eq. 0 .and. .not. l_desid_diag ) then dustbf = 0.0 ! array assignment #ifdef verbose_wbdust sdiagv = 0.0 ! array assignment @@ -1095,11 +896,20 @@ end subroutine tfabove emap( m ) = dmap( m ) ! dmap maps to one of the 3 BELD3 desert types end do emap( n_dlcat+1 ) = 4 +C Check PX soil texture data flag and log a message if or if not used in WB dust + if(PXSOIL_AVAIL) then + CALL LOG_MESSAGE( LOGDEV, '================== Windblown Dust Message =====================' ) + CALL LOG_MESSAGE( LOGDEV, ' WRFV4.1+ inputs have extra PX LSM soil texture and props used.' ) + CALL LOG_MESSAGE( LOGDEV, ' Clay, coarse and fine-medium sand from PX LSM not lookup tables.' ) + else + CALL LOG_MESSAGE( LOGDEV, '================== Windblown Dust Message =====================' ) + CALL LOG_MESSAGE( LOGDEV, ' Clay, coarse and fine-medium sand from internal lookup table.' ) + end if C --------- ###### Start Main Loop ###### --------- - do r = 1, my_nrows - do c = 1, my_ncols + do r = 1, nrows + do c = 1, ncols dust_em( c,r ) = 0.0 soimt( c,r ) = 0.0 fmoit( c,r ) = 0.0 ! for diagnostic output visualization @@ -1114,8 +924,36 @@ end subroutine tfabove rlay1hgt = rjacm ( c,r ) / cellhgt -C---Vegetation fraction based on the MODIS FPAR - vegfrac( c,r ) = max( min( fpar( c,r ), 0.95 ), 0.005 ) + +C--- Set Clay, coarse and fine/medium sand fractions. +C--- If value from WRF is missing (-9999.) use old table values +C-- If value from WRF is from WRFV4.1 PX LSM csand_px, etc use those + j = Grid_Data%sltyp( c,r ) + + if (.not. WRF_V4P) then +C Adjust WRF soil definitions to match internal Menut et al. [JGR,2013] Table + if ( j .gt. 4 ) j = j + 1 + if ( j .gt. 13 ) j = 13 + end if + + if(PXSOIL_AVAIL) then + clay = Grid_Data%clay_px(c,r) + csand = Grid_Data%csand_px(c,r) + fmsand = Grid_Data%fmsand_px(c,r) + else + csand = soiltxt(j,1) + fmsand = soiltxt(j,2) + clay = soiltxt(j,4) + end if + + sandf = csand + fmsand + siltf = 1.0 - clay - sandf + + +C---Vegetation fraction based on the WRF/MCIP VEG variable. In WRF that would be VEGF_PX +C-- for the case of PX and VEGFRA in the case of other LSMs. In more recent WRFv4+ versions +C-- high resolution MODIS veg data is availiable and can be used in PX with pxlsm_modis_veg = 1 + vegfrac( c,r ) = max( min( Met_Data%veg(c,r), 0.95 ), 0.005) vegfree = 1.0 - vegfrac( c,r ) lambdav = -0.35 * log( vegfree ) ! Shao et al. [Aus. J. Soil Res.,1996] @@ -1132,23 +970,17 @@ end subroutine tfabove & ( Met_Data%snocov( c,r ) .lt. 0.001 ) ) then ! less than 0.1% snow coverage C---Dust possiblity 1,2,3 - j = Grid_Data%sltyp( c,r ) - -C kludge (fixed in wrf-px after 4 Mar 11) - if ( j .gt. 4 ) j = j + 1 ! PX combines "silt" with "silt loam" - if ( j .gt. 13 ) j = 13 ! = ? C Calculate maximum amount of the adsorbed water C w` = 0.0014(%clay)**2 + 0.17(%clay) - w` in % C Fecan et al. [1999,Annales Geophys.,17,144-157] - wmax( c,r ) = ( 14.0 * soiltxt( j,4 ) + 17.0 ) * soiltxt( j,4 ) ! [%] + wmax( c,r ) = ( 14.0 * clay + 17.0 ) * clay ! [%] ! write( logdev,'( 2x, a, i8.6, f12.5 )' ) 'max wmax:', jtime, maxval( wmax ) C Change soil moisture units from volumetric (m**3/m**3) to gravimetric (Kg/Kg) - soimt( c,r ) = Met_Data%soim1( c,r ) ! <- [m**3/m**3] - & * 1000.0 / ( 2650.0 * ( 0.511 + 0.126 - & * ( soiltxt( j,1 ) + soiltxt( j,2 ) ) ) ) + soimt( c,r ) = Met_Data%soim1( c,r ) + & * 1000.0 / ( 2650.0 * ( 0.511 + 0.126 * sandf ) ) if ( soimt( c,r ) .le. soilml1( j ) ) then C---Dust possiblity 4 @@ -1166,9 +998,8 @@ end subroutine tfabove end if C---Erodibility potential of soil component - sd_ep( c,r ) = soiltxt( j,4 ) * eropot( 1 ) - & + soiltxt( j,3 ) * eropot( 2 ) - & + ( soiltxt( j,1 ) + soiltxt( j,2 ) ) * eropot( 3 ) + sd_ep( c,r ) = clay * eropot( 1 ) + & + siltf * eropot( 2 ) + sandf * eropot( 3) C---Lu and Shao [JGR,1999] and Kang et al. [JGR,2011] C First, mapping soil types into 4 main soil types following Kang et al. [JGR,2011] @@ -1218,7 +1049,6 @@ end subroutine tfabove do m = 1, n_dlcat ! desert type landuse category elus( c,r,m ) = ladut( c,r,m ) * vegfree ! desert land [%] end do - elus( c,r,n_dlcat+1 ) = agland( c,r ) * vegfree ! crop land [%] C ------- Start Loop Over Erodible Landuse ---- @@ -1263,8 +1093,12 @@ end subroutine tfabove ! kvh( c,r,m ) = ( calpha * 9.81 * pfrac * 1000.0 / 2.0 / pp ) ! & * ( 0.24 + 2.09 * ustr( c,r,m ) * sqrt( 2650.0 / pp ) ) kvh( c,r,m ) = flxfac1 * ( 0.24 + flxfac2 * ustr( c,r,m ) ) + soiltxt_gcell(1) = csand + soiltxt_gcell(2) = fmsand + soiltxt_gcell(3) = siltf + soiltxt_gcell(4) = clay hflux = dust_hflux( ndp, dp, - & soiltxt( j,: ), + & soiltxt_gcell( : ), & fmoit( c,r ), & fruf( c,r,m ), & ustr( c,r,m ), @@ -1286,10 +1120,6 @@ end subroutine tfabove C ------- End Loop Over Erodible Landuse ---- -C Dust removal by surrounding vegetation <-??? -C Adjust dust emissions for transport factors - - dust_em( c,r ) = dust_em( c,r ) * tfa( c,r ) * tfb( c,r ) end if ! if soil moisture end if ! if rain & land & snow @@ -1304,46 +1134,52 @@ end subroutine tfabove & out of total cells:', & dryhit, (c-1)*(r-1) #endif + end if ! dust scheme (Wei Li) - end if ! dust scheme - - do r = 1, my_nrows - do c = 1, my_ncols + do r = 1, nrows + do c = 1, ncols C J/K mass emis rate [g/s] (edust( 1 ) not used) - edust( 2 ) = fracmj * dust_em( c,r ) - edust( 3 ) = fracmk * dust_em( c,r ) + edust( 1 ) = fracmj * dust_em( c,r ) + edust( 2 ) = fracmk * dust_em( c,r ) - do v = 1, ndust_spc - dustoutm( v,1,c,r ) = 0.0 - end do - - do n = 2, n_mode + do n = 1,2 do v = 1, ndust_spc - dustoutm( v,n,c,r ) = edust( n ) * dust_spc( v )%spcfac( n ) + dustoutm( (n-1)*ndust_spc+v,c,r ) = + & edust( n ) * dust_spc( v )%spcfac( n ) end do end do C J/K 3rd moment emis rate [m3/s] (needed for number and surface) - m3j = edust( 2 ) * f6dpi / ( gpkg * dustmode_dens( 2 ) ) - m3k = edust( 3 ) * f6dpi / ( gpkg * dustmode_dens( 3 ) ) + m3j = edust( 1 ) * f6dpi / ( gpkg * dust_dens( 1 ) ) + TINY(0.0) + m3k = edust( 2 ) * f6dpi / ( gpkg * dust_dens( 2 ) ) + TINY(0.0) C Mode-specific emission rates of particle number [1/s] - dustoutn( 1,c,r ) = 0.0 - dustoutn( 2,c,r ) = m3j * factnumj - dustoutn( 3,c,r ) = m3k * factnumk + dustoutn( 1,c,r ) = m3j * factnumj + dustoutn( 2,c,r ) = m3k * factnumk C Mode-specific dry surface area emission rates [m**2/s]. C 2nd moment multiplied by PI to obtain the surface area emissions rate. - dustouts( 1,c,r ) = 0.0 - dustouts( 2,c,r ) = m3j * factsrfj - dustouts( 3,c,r ) = m3k * factsrfk + dustouts( 1,c,r ) = m3j * factsrfj + dustouts( 2,c,r ) = m3k * factsrfk + +! Propagate Number and Surface Area Scaling Factors back to Emissions +! Module so that the dust emissions can be scaled appropriately + ISD = INDEX1( 'FINE', DESID_STREAM_AERO( IDUSTSRM )%LEN, + & DESID_STREAM_AERO( IDUSTSRM )%NAME ) + DESID_STREAM_AERO( IDUSTSRM )%FACNUM( ISD,2 ) = FACTNUMJ + DESID_STREAM_AERO( IDUSTSRM )%FACSRF( ISD,2 ) = FACTSRFJ + + ISD = INDEX1( 'COARSE', DESID_STREAM_AERO( IDUSTSRM )%LEN, + & DESID_STREAM_AERO( IDUSTSRM )%NAME ) + DESID_STREAM_AERO( IDUSTSRM )%FACNUM( ISD,3 ) = FACTNUMK + DESID_STREAM_AERO( IDUSTSRM )%FACSRF( ISD,3 ) = FACTSRFK #ifdef verbose_wbdust if ( m3j .ne. 0.0 ) dusthit = dusthit + 1 #endif - if ( dustem_diag ) then + if ( dustem_diag .and. .not. l_desid_diag ) then do m = 1, n_dlcat+1 diagv( m ) = qam( c,r,m ) ! g/m**3/s end do @@ -1379,37 +1215,34 @@ end subroutine tfabove diagv( n+4 ) = vegfrac( c,r ) ! 'Vegetation_Frac ' diagv( n+5 ) = uland( c,r,3 ) ! 'Urban_Cover ' diagv( n+6 ) = uland( c,r,4 ) ! 'Forest_Cover ' - diagv( n+7 ) = tfa ( c,r ) ! 'Trfac_Above_Can ' - diagv( n+8 ) = tfb ( c,r ) ! 'Trfac_Inside_Can' - n = n + 8 + n = n + 6 ! accum and coarse mode number density emissions - diagv( n+1 ) = dustoutn( 2,c,r ) - diagv( n+2 ) = dustoutn( 3,c,r ) + diagv( n+1 ) = dustoutn( 1,c,r ) + diagv( n+2 ) = dustoutn( 2,c,r ) ! accum and coarse mode surface area density emissions - diagv( n+3 ) = dustouts( 2,c,r ) - diagv( n+4 ) = dustouts( 3,c,r ) + diagv( n+3 ) = dustouts( 1,c,r ) + diagv( n+4 ) = dustouts( 2,c,r ) n = n + 4 m = 0 do v = 1, ndust_spc - if ( trim( dust_spc( v )%name( 2 ) ) .ne. ' ' ) then ! accum. mode mass emissions + if ( dust_spc( v )%spcfac( 1 ) .gt. 0. ) then ! accum. mode mass emissions m = m + 1 - diagv( m+n ) = dustoutm( v,2,c,r ) + diagv( m+n ) = dustoutm( v,c,r ) end if end do do v = 1, ndust_spc - if ( trim( dust_spc( v )%name( 3 ) ) .ne. ' ' ) then ! coarse mode mass emissions + if ( dust_spc( v )%spcfac( 2 ) .gt. 0. ) then ! coarse mode mass emissions m = m + 1 - diagv( m+n ) = dustoutm( v,3,c,r ) + diagv( m+n ) = dustoutm( v+ndust_spc,c,r ) end if end do n = n + m - C Multiply by sync step because when write to output we divide by the output step C to get a timestep average. do v = 1, ndust_diag @@ -1429,7 +1262,7 @@ end subroutine tfabove & dusthit, (c-1)*(r-1) #endif - if ( dustem_diag ) then + if ( dustem_diag .and. .not. l_desid_diag ) then C If last call this hour, write out the windblown dust emissions dignostics. C Then reset the emissions array and local write counter. @@ -1437,7 +1270,7 @@ end subroutine tfabove wstep = wstep + time2sec( tstep( 2 ) ) if ( wstep .ge. time2sec( tstep( 1 ) ) ) then - if ( .not. currstep( jdate, jtime, sdate, stime, tstep( 1 ), + if ( .not. currstep( jdate, jtime, stdate, sttime, tstep( 1 ), & mdate, mtime ) ) then xmsg = 'Cannot get step date and time' call m3exit( pname, jdate, jtime, xmsg, xstat3 ) @@ -1457,8 +1290,8 @@ end subroutine tfabove sdiagv = 0.0 ! array assignment #endif do v = 1, ndust_diag - do r = 1, my_nrows - do c = 1, my_ncols + do r = 1, nrows + do c = 1, ncols wrbuf( c,r ) = dustbf( v,c,r ) / float( wstep ) end do end do @@ -1491,7 +1324,7 @@ function dust_hflux( ndp, dp, soiltxt, fmoit, fruf, ustr, sd_ep, dens ) & result( hflux ) C usage: hflux = dust_flux( ndp, dp, -C soiltxt( j,: ), +C soiltxt2( : ), C fmoit( c,r ), C fruf( c,r,m ), C ustr( c,r,m ), @@ -1547,6 +1380,7 @@ function dust_hflux( ndp, dp, soiltxt, fmoit, fruf, ustr, sd_ep, dens ) end function dust_hflux + ! add a new function for fengsha (Wei Li) function dust_hflux_fengsha( ustar, fmoit, drag, uthr, ssm, dens ) & result( hflux ) @@ -1560,19 +1394,19 @@ function dust_hflux_fengsha( ustar, fmoit, drag, uthr, ssm, dens ) real u_sum real u_thresh real fac - + real, parameter :: amen = 1.0 ! Marticorena and Bergametti [JGR,1997] real, parameter :: cfac = 1000.0 * amen / grav fac = cfac * dens hflux = 0.0 - - rustar = ustar * drag + + rustar = ustar * drag u_thresh = uthr * fmoit u_sum = rustar * u_thresh hflux = max(0., rustar - u_thresh) * u_sum * u_sum * fac * ssm end function dust_hflux_fengsha - end module dust_emis + diff --git a/src/model/src/RUNTIME_VARS.F b/src/model/src/RUNTIME_VARS.F new file mode 100644 index 0000000..64e76e0 --- /dev/null +++ b/src/model/src/RUNTIME_VARS.F @@ -0,0 +1,1201 @@ + +!------------------------------------------------------------------------! +! The Community Multiscale Air Quality (CMAQ) system software is in ! +! continuous development by various groups and is based on information ! +! from these groups: Federal Government employees, contractors working ! +! within a United States Government contract, and non-Federal sources ! +! including research institutions. These groups give the Government ! +! permission to use, prepare derivative works of, and distribute copies ! +! of their work in the CMAQ system to the public and to permit others ! +! to do so. The United States Environmental Protection Agency ! +! therefore grants similar permission to use the CMAQ system software, ! +! but users are requested to provide copies of derivative works or ! +! products designed to operate in the CMAQ system to the United States ! +! Government without restrictions as to use by others. Software ! +! that is used with the CMAQ system but distributed under the GNU ! +! General Public License or the GNU Lesser General Public License is ! +! subject to their copyright restrictions. ! +!------------------------------------------------------------------------! + +!.................................................................... +! The RUNTIME_VARS module contains file unit identifiers for the log files, +! input files, and the values of all environment variables. +! +! It also contains routines for reading environment variables, and +! opening input files. +! +! History: +! 07/19/18, D. Wong: removed some of the ifdef clause for twoway model +! and added new logical environment variables +! ncd_64bit_offset and cell_num for MPAS coupling scheme +! 31 Jan 2019 (David Wong) +! -- removed all twoway related environment variables in this file +! 01 Feb 2019 (David Wong) +! -- implemented invocation of GET_ENV call directly, removed unnecessay +! interface block and unnecessary functions +! 02 May 2019 (David Wong) +! -- set BIOGEMIS_SEASON = .FALSE. as the default value +! 13 May 2019 (David Wong) +! -- setup environment variable ISAM_NEW_START +! 14 May 2019 (David Wong) +! -- updated environment variable ISAM_NEW_START with default value 'Y' +! 15 May 2019 (David Wong) +! -- included check for using marine gas emission or not +! 13 June 2019 (F. Sidi) +! -- Set the default for ERODE_AGLAND to FALSE. No longer supported feature +! in CMAQv5.3 +! 25 July 2019 (D. Wong) +! -- Included a logic to determine whether met data was created from +! WRF V4+ is used +! 01 Aug 2019 (D. Wong) +! -- Modified code to work with two-way model +! 07 Nov 2019 (D. Wong) +! -- Made RUNLEN environment variable avilable to two-way model as well +! 22 Nov 2019 (F. Sidi) +! -- Re-introduced master switch to overide emissions file date for +! representative day files +! 10 Feb 2020 (D. Wong) +! -- Added new environmental variable, MET_TSTEP, to enable +! running with temporally finer meteorology +! 10 Jun 2021 (G. Sarwar) +! -- Added 'CB6R5M' and deleted "CB6R3M" +! 4 Mar 2022 (G. Sarwar) +! -- Added 'CB6R5' +!.................................................................... + + MODULE RUNTIME_VARS + + use get_env_module + + IMPLICIT NONE + + SAVE + + PUBLIC + + INTEGER :: OUTDEV = 6 ! File Unit for Standard Output + INTEGER :: LOGDEV = -1 ! File Unit for Ascii Log File + INTEGER :: TOTPE = 1 ! Number of Total Processors + INTEGER :: NPROCS = 1 ! Number of Total Processors + INTEGER :: MYPE = -1 ! Processor Number + CHARACTER( 3 ) :: CMYPE = "" ! Processor Number + + !----------------------------------------------------------------------------------- + !>> Parameters for formatting output log files + !----------------------------------------------------------------------------------- + + INTEGER, PARAMETER :: CTM_DIAG_LVL = 0 + + INTEGER :: LOG_LINE_LENGTH = 80 ! Cut the log offs at this character if possible + INTEGER :: LOG_MAJOR_TAB = 5 ! Left tab for all text including headings + INTEGER :: LOG_MINOR_TAB = 2 ! Tab for indenting subsequent lines of text in + ! a paragraph for instance. + + CHARACTER( 10 ) :: WEEKDAY( 7 ) = (/'Monday ','Tuesday ','Wednesday', + & 'Thursday ','Friday ','Saturday ','Sunday ' /) + + +! this is for MPAS + LOGICAL :: ncd_64bit_offset = .FALSE. + INTEGER :: cell_num = 1 !(Wei Li; tested ) + !----------------------------------------------------------------------------------- + !>> Define Environment Variables for Controlling CMAQ Processes + !----------------------------------------------------------------------------------- + + ! Met model version + LOGICAL :: WRF_V4P = .FALSE. ! Indicator of whether WRF version is 4+ or not + + ! Convective scheme in met model + LOGICAL :: CONVECTIVE_SCHEME = .TRUE. + ! Flag for column model + LOGICAL :: COLUMN_MODEL = .FALSE. + + ! Grid and High-Level Model Parameters + LOGICAL :: NEW_START = .TRUE. ! Start New Simulation. Not a Restart + LOGICAL :: IGNORE_SOILINP = .FALSE. ! In case you don't have prev day + CHARACTER(300):: EXECUTION_ID = '' ! Execution ID + CHARACTER(16) :: GRID_NAME = '' ! grid name selected from GRIDDESC + CHARACTER(16) :: PROGNAME = 'DRIVER' ! Program name selected from GRIDDESC + INTEGER :: RUNLEN = 480000 ! Run Length + INTEGER :: STDATE = 1995192 ! Start Date + INTEGER :: STTIME = 000000 ! Start Time + INTEGER :: LOCAL_TSTEP = 010000 ! set to TSTEP( 1 ) in initscen.F + INTEGER :: MET_TSTEP ! set meterology input temporal frequency + INTEGER :: NPCOL = 1 ! no. of processors across grid columns + INTEGER :: NPROW = 1 ! no. of processors across grid rows + INTEGER :: MAXSYNC = 720 ! force max TSTEP(2) (sec) + INTEGER :: MINSYNC = 60 ! force min TSTEP(2) (sec) + + INTEGER, PARAMETER :: MAXLEN_CCTM_APPL = 200 ! Length of Logfile Names + CHARACTER( MAXLEN_CCTM_APPL ) :: APPL_NAME = 'APPL' ! Logfile Names + CHARACTER( MAXLEN_CCTM_APPL ) :: BLDFOLD = '' ! Build Directory + CHARACTER( MAXLEN_CCTM_APPL ) :: OUTDIR = '' ! Output Directory + + ! General; Multiprocess control, output and error checking + LOGICAL :: PRINT_PROC_TIME = .FALSE. ! Flag to print elapsed time for all + ! science submodules + LOGICAL :: FL_ERR_STOP=.TRUE. ! Flag to stop run if errors are found. + LOGICAL :: CKSUM = .TRUE. ! flag for cksum on, default = [T] + LOGICAL :: END_TIME = .FALSE. ! Override default beginning ACON timestamp + + INTEGER :: N_ACONC_VARS = 0 ! Number of species saved to avg conc file + INTEGER :: N_CONC_VARS = 0 ! Number of species saved to conc file + INTEGER :: ACONC_BLEV= 0 ! Beginning level saved to avg conc file + INTEGER :: ACONC_ELEV= 0 ! Ending level saved to avg conc file + INTEGER :: CONC_BLEV = 0 ! Beginning level saved to conc file + INTEGER :: CONC_ELEV = 0 ! Ending level saved to conc file + CHARACTER( 16 ) :: ACONC_FILE_SPCS( 900 ) = '' ! avg conc file species list + CHARACTER( 16 ) :: CONC_FILE_SPCS(900 ) = '' ! conc file species list + LOGICAL :: PWRTFLAG = .TRUE. ! Print confirmation of successful output + ! to logfile + LOGICAL :: LVEXT = .FALSE. ! Flag to perform vertical Extraction + CHARACTER( 1000 ) :: VEXT_COORD_PATH = "" ! File Path for Lon-Lat Text file specifying + ! locations for vertical extraction + + CHARACTER(256) :: GC_NAMELIST = '' ! Gas Species Namelist + CHARACTER(256) :: AE_NAMELIST = '' ! Aerosol Species Namelist + CHARACTER(256) :: NR_NAMELIST = '' ! Nonreactive Species Namelist + CHARACTER(256) :: TR_NAMELIST = '' ! Tracer Species Namelist + + ! Chemistry and Photolysis + LOGICAL :: PHOTDIAG = .FALSE. ! Flag for PHOTDIAG file + INTEGER :: NLAYS_DIAG = 0 ! Number of Diagnostic Layers to write out for photolysis + INTEGER :: NWAVE = 0 ! Number of Diagnostic Wavelengths + CHARACTER(16) :: WAVE_ENV(100) ! Targeted wavelengths for diagnostic output + LOGICAL :: CORE_SHELL= .FALSE. ! flag for using core-shell mixing model for aerosol optics + LOGICAL :: MIE_CALC = .FALSE. ! flag for using Mie Theory in aerosol optics calculation + REAL :: GEAR_ATOL = 1.0E-9 ! Absolute Tolerance for Gear Solver + REAL :: GEAR_RTOL = 1.0E-3 ! Relative Tolerance for Gear Solver + REAL :: GLBL_ATOL = 1.0E-7 ! Absolute Tolerance for Rosenbrock Solver + REAL :: GLBL_RTOL = 1.0E-3 ! Relative Tolerance for Rosenbrock Solver + + ! Aerosols + LOGICAL :: IC_AERO_M2WET=.FALSE.! flag for specifying wet aerosol size parameters + ! for initial conditions. FALSE = dry + LOGICAL :: BC_AERO_M2WET=.FALSE.! flag for specifying wet aerosol size parameters + ! for boundary conditions. FALSE = dry + LOGICAL :: IC_AERO_M2USE=.TRUE. ! flag for using the second moment from the input file + ! for initial conditions. TRUE = use input 2nd moment + LOGICAL :: BC_AERO_M2USE=.TRUE. ! flag for using the second moment from the input file + ! for boundary conditions.TRUE = use input 2nd moment + + ! Cloud Parameters + LOGICAL :: CLD_DIAG = .FALSE. ! flag to output cloud diagnostic files + + ! Air-Surface Exchange + LOGICAL :: ABFLUX = .FALSE. ! flag for ammonia bi-directional flux with in-lining depv + LOGICAL :: MOSAIC = .FALSE. ! flag for STAGE mosaic - output land use specific deposition and deposition velocity + LOGICAL :: SFC_HONO = .FALSE. ! flag for HONO interaction with surfaces + LOGICAL :: PX_LSM = .TRUE. ! flag for WRF PX land surface model + LOGICAL :: CLM_LSM = .FALSE. ! flag for WRF CLM land surface model + LOGICAL :: NOAH_LSM = .TRUE. ! flag for WRF NOAH land surface model + LOGICAL :: DEPV_DIAG = .FALSE. ! flag for grid cell deposition velocity diagnostic file + Logical :: HGBIDI = .FALSE. ! flag for Hg bidirectional exchange + Logical :: BIDI_FERT_NH3 = .TRUE. ! flag to remove fertilizer ammonia from Bidirectional emissions + Logical :: STAGE_E20 = .TRUE. ! flag for the Emerson et al. 2020 Aerosol deposition model PNAS https://www.pnas.org/cgi/doi/10.1073/pnas.2014761117 + Logical :: STAGE_P22 = .FALSE. ! flag for the Pleim et al. 2022 Aerosol deposition model + Logical :: STAGE_S22 = .FALSE. ! flag for the Shu et al. 2022 Aerosol deposition model + CHARACTER(16) :: DUST_LAND_SCHEME = "UNKNOWN" ! NLCD, USGS, etc + + + ! Transport Processes + LOGICAL :: VDIFFDIAG = .FALSE. ! flag for VDIFF diagnostic files + REAL :: SIGST = 0.7 ! sigma_sync_top value + REAL :: HDIV_LIM = 0.9 ! cutoff for max horizontal divergence step adj + REAL :: CFL = 0.75 ! maximum Courant-Friedrichs-Lewy number allowed + Logical :: MINKZ = .TRUE. ! flag for minimum Kz + LOGICAL :: W_VEL = .FALSE. ! flag for vertical velocity + LOGICAL :: GRAV_SETL = .TRUE. ! flag for aerosol gravitational setling + + + ! Emissions Processes + CHARACTER( MAXLEN_CCTM_APPL ) :: STAGECTRL = 'STAGECTRL_NML' ! STAGE Deposition Control Filename + CHARACTER( MAXLEN_CCTM_APPL ) :: MISC_CTRL = 'MISC_CTRL_NML' ! Emission Control Filename + CHARACTER( MAXLEN_CCTM_APPL ) :: DESID_CTRL = 'DESID_CTRL_NML' ! Emission Control Filename + CHARACTER( MAXLEN_CCTM_APPL ) :: DESID_CHEM_CTRL = 'DESID_CHEM_CTRL_NML' ! Emission Control Filename + INTEGER :: EMLAYS_MX = 0 ! Emission Layers + INTEGER :: N_FILE_GR = 0 ! Number of Gridded Emission Files + INTEGER :: N_FILE_TR = 0 ! NUmber of Tracer Emission Files + LOGICAL :: EMISCHK = .TRUE. ! flag for checking that surrogate emissions + ! are present on emission files + LOGICAL :: BIOGEMIS_BEIS = .FALSE. ! flag to in-line biogenic VOC emissions + LOGICAL :: BIOGEMIS_MEGAN= .FALSE. ! flag to in-line MEGAN biogenic emissions + LOGICAL :: USE_MEGAN_LAI = .FALSE. ! flag to use MEGAN LAI values + LOGICAL :: MGN_ONLN_DEP = .FALSE. ! flag to use ONLINE N deposition in BDSNP + LOGICAL :: BDSNP_MEGAN = .FALSE. ! flag to use BDSNP for soil NO + CHARACTER(16) :: SPPRO = 'DEFAULT' ! requested speciation profile name + LOGICAL :: BEMIS_DIAG = .TRUE. ! true: write diagnostic emiss file + LOGICAL :: MGEMDIAG = .FALSE. ! flag for MGEM diagnostic file + LOGICAL :: OCEAN_CHEM = .TRUE. ! Flag for ocean halogen chemistry and sea spray aerosol emissions + LOGICAL :: WB_DUST = .FALSE. ! flag for On-Line Dust Emission Calculation + LOGICAL :: DUSTEM_DIAG = .FALSE. ! flag for dustemis diagnostic file + LOGICAL :: SSEMDIAG = .FALSE. ! flag for SSEMIS diagnostic file + LOGICAL :: LTNG_NO = .FALSE. ! flag for online calculation of NO from lightning + INTEGER :: LT_ASM_DT = 0 ! Lightning Input Time Interval + LOGICAL :: NLDNSTRIKE = .FALSE. ! flag to use NLDN STRIKE directly + LOGICAL :: LTNGDIAG = .FALSE. ! flag to turn on lightning NO diagnostics + REAL :: MOLSNCG = 350.0 ! Lightning NO Production Rate + REAL :: MOLSNIC = 350.0 ! Lightning NO Production Rate + CHARACTER(250) :: LTNG_FNAME = 'InLine' ! Lightning NO Input Name + + INTEGER :: NPTGRPS = 0 ! no. pt src input file groups + LOGICAL :: PT3DDIAG = .FALSE. ! Write point source 3d emis diagnostic file + LOGICAL :: PT3DFRAC = .FALSE. ! Write layer fractions diagnostic file, if true + INTEGER :: PT_NSTEPS = 1 + INTEGER :: PT_DATE = 1995192 ! Julian start date (YYYYDDD) + INTEGER :: PT_TIME = 0 ! start time (HHMMSS) + INTEGER :: IPVERT = 0 ! Numerical flag for plume vertical spread method + INTEGER :: REP_LAYR = -1 ! Minimum layer for reporting srcs w/ high plumes + LOGICAL :: EMIS_SYM_DATE = .FALSE. ! Overrider CMAQ not to check + ! if the dates on the emissions file match that of + ! the interal model (representative day case) + CHARACTER( 16 ), SAVE, ALLOCATABLE :: PLAY_BASE( : ) ! Use for Plume Rise Calculation + + LOGICAL :: USE_MARINE_GAS_EMISSION = .FALSE. + + ! Process Analysis + LOGICAL :: PROCAN = .FALSE. ! flag for process analysis + INTEGER :: PA_BEGCOL = 0 ! Starting PA output + INTEGER :: PA_ENDCOL = 0 ! ending column for PA output + INTEGER :: PA_BEGROW = 0 ! Starting row for PA output + INTEGER :: PA_ENDROW = 0 ! ending row for PA output + INTEGER :: PA_BEGLEV = 0 ! Starting layer for PA output + INTEGER :: PA_ENDLEV = 0 ! ending layer for PA output + + ! Sulfur tracking + LOGICAL :: STM = .FALSE. ! flag for sulfur tracking option + LOGICAL :: ADJ_STMSPC = .TRUE. ! flag for normalizing sulfur tracking species + + ! ISAM + CHARACTER(1) :: ISAM_NEW_START = 'Y' ! Start New Simulation. Not a Restart for ISAM + INTEGER :: ISAM_BLEV = 0 ! Beginning level saved to conc file + INTEGER :: ISAM_ELEV = 0 ! Ending level saved to conc file + INTEGER :: SA_NLAYS = 0 ! Number of layers saved to conc file + INTEGER :: AISAM_BLEV = 0 ! Beginning level saved to sa_aconc file + INTEGER :: AISAM_ELEV = 0 ! Ending level saved to sa_aconc file + INTEGER :: AVGSA_LAYS = 0 ! Number of layers saved to conc file + INTEGER :: ISAM_CHEM_BIAS = 5 ! which chemistry are biased in apportioning reaction yields + ! to source reactant + ! 1 for none so divided equally between sources' reactant + ! 2 for all products apportioned to sources with NO, NO2, NO3, HONO, ANO3 + ! -equally if reactants are neither or both + ! 3 for all products apportioned to sources with Case 2 plus select OVOC species + ! and radicals + ! -equally if reactants are neither or both + ! 4 for all products apportioned to sources with select OVOC species + ! and radicals + ! -equally if reactants are neither or both + ! 5 to switch between Cases 2 and 3 based on whether + ! production H2O2 over production HNO3 less than VOC_NOX_TRANS + + REAL :: VOC_NOX_TRANS = 0.35 ! H2O2 to HNO3 marking transition from NOx to VOC limiting O3 production + INTEGER :: ISAM_NOX_CASE = 2 ! option of ISAM_CHEM_BIAS representing NOx limiting O3 production + INTEGER :: ISAM_VOC_CASE = 4 ! option of ISAM_CHEM_BIAS representing VOC limiting O3 production + + CONTAINS + +!......................................................................... + SUBROUTINE INIT_ENV_VARS( JDATE, JTIME ) + +! Defines and retrieves values for all environment variable input to +! CMAQ. +!......................................................................... + + USE RXNS_DATA, ONLY : MECHNAME + USE M3UTILIO + + IMPLICIT NONE + + INCLUDE SUBST_FILES_ID ! file name parameters + +#ifdef parallel + include 'mpif.h' +#endif + + INTEGER, INTENT( In ) :: JDATE + INTEGER, INTENT( In ) :: JTIME + CHARACTER( 16 ) :: V_LIST2( 20 ) + CHARACTER( 240 ) :: XMSG = '' + INTEGER :: NV + + + INTEGER :: STATUS ! ENV... status + CHARACTER( 400 ) :: STRTEMP + CHARACTER( 80 ) :: PBASE + INTEGER, PARAMETER :: EXIT_STATUS = 1 + INTEGER :: ERROR + INTEGER :: VARDEV = -1 + + LOGICAL :: FOUND + LOGICAL :: EFLAG = .FALSE. + INTEGER :: LOC, STR_LEN + CHARACTER(10) :: WRF_VERSION + + CHARACTER( 16 ) :: PNAME = 'RUNTIME_VARS' + + !------------------------------------------------------------------------------------------------------- + !>> Grid and High-Level Model Parameters + !------------------------------------------------------------------------------------------------------- +#ifdef parallel + CALL MPI_COMM_RANK ( MPI_COMM_WORLD, MYPE, ERROR ) + CALL MPI_COMM_SIZE ( MPI_COMM_WORLD, TOTPE, ERROR ) +#else + MYPE = 0 + TOTPE = 0 +#endif + + IF ( MYPE .EQ. 0 ) VARDEV = OUTDEV + + ! Get Simulation Scenario Name to Label Log Files, etc + CALL GET_ENV( APPL_NAME, 'CTM_APPL', APPL_NAME, VARDEV ) + + ! Start I/O-API and set up log file(s) + CALL SETUP_LOGDEV() + IF ( MYPE .EQ. 0 ) THEN + CALL LOG_HEADING( OUTDEV, "Environment Variable Report" ) + CALL LOG_SUBHEADING( OUTDEV, "Grid and High-Level Model Parameters" ) + WRITE( OUTDEV, '(6x,A)' ),'--Env Variable-- | --Value--' + WRITE( OUTDEV, '(6x,A)' ), REPEAT( '-',80 ) + END IF + + ! Get Logfile Directory + CALL GET_ENV ( BLDFOLD, 'BLD', BLDFOLD, VARDEV ) + + ! Get Logfile Directory + CALL GET_ENV ( OUTDIR, 'OUTDIR', OUTDIR, VARDEV ) + + ! Determine if this run is a new start or a restart + CALL GET_ENV ( NEW_START, 'NEW_START', NEW_START, VARDEV ) + + ! Determine if prev day soilinp is available for MEGAN + CALL GET_ENV ( IGNORE_SOILINP, 'IGNORE_SOILINP', IGNORE_SOILINP, VARDEV ) + + ! Get Execution ID + CALL GET_ENV ( STRTEMP, 'EXECUTION_ID', EXECUTION_ID, VARDEV ) + EXECUTION_ID = STRTEMP(1:300) + + ! Get Grid Name + CALL GET_ENV ( STRTEMP, 'GRID_NAME', GRID_NAME, VARDEV ) + GRID_NAME = STRTEMP(1:16) + + ! Output Time Step + CALL GET_ENV ( LOCAL_TSTEP, 'CTM_TSTEP', LOCAL_TSTEP, VARDEV ) + + ! Run Duration + CALL GET_ENV ( RUNLEN, 'CTM_RUNLEN', RUNLEN, VARDEV ) + +#ifndef twoway + ! Main Program Name + CALL GET_ENV ( STRTEMP, 'CTM_PROGNAME', PROGNAME, VARDEV ) + PROGNAME = STRTEMP( 1:16 ) + + ! Starting Date + CALL GET_ENV ( STDATE, 'CTM_STDATE', STDATE, VARDEV ) + + ! Starting Time + CALL GET_ENV ( STTIME, 'CTM_STTIME', STTIME, VARDEV ) + + ! Retrieve the domain decomposition processor array + IF ( NPROCS .GT. 1 ) THEN + CALL GET_ENV ( 'NPCOL_NPROW', NV, V_LIST2, VARDEV ) + IF ( NV .NE. 2 ) THEN + XMSG = 'Environment variable problem for NPCOL_NPROW' + & // ' using default 1X1' + CALL M3WARN ( 'INIT_ENV_VARS', 0, 0, XMSG ) + NV = 2 + V_LIST2( 1 ) = '1' + V_LIST2( 2 ) = '1' + END IF + READ( V_LIST2( 1 ), '( I4 )' ) NPCOL + READ( V_LIST2( 2 ), '( I4 )' ) NPROW + END IF + +#endif + + ! MAXSYNC + CALL GET_ENV ( MAXSYNC, 'CTM_MAXSYNC', MAXSYNC, VARDEV ) + + ! MINSYNC + CALL GET_ENV ( MINSYNC, 'CTM_MINSYNC', MINSYNC, VARDEV ) + + + !------------------------------------------------------------------------------------------------------- + !>> General; Multiprocess control, output and error checking + !------------------------------------------------------------------------------------------------------- + + IF ( MYPE .EQ. 0 ) THEN + CALL LOG_SUBHEADING( OUTDEV, "Multiprocess control, output and error checking" ) + WRITE( OUTDEV, '(6x,A)' ),'--Env Variable-- | --Value--' + WRITE( OUTDEV, '(6x,A)' ), REPEAT( '-',80 ) + END IF + + ! PRINT_PROC_TIME + CALL GET_ENV ( PRINT_PROC_TIME, 'PRINT_PROC_TIME', PRINT_PROC_TIME, VARDEV ) + + ! FL_ERR_STOP + CALL GET_ENV ( FL_ERR_STOP, 'FL_ERR_STOP', FL_ERR_STOP, VARDEV ) + + ! CKSUM + CALL GET_ENV ( CKSUM, 'CTM_CKSUM', CKSUM, VARDEV ) + + ! Override default beginning time timestamp for ACONC? + CALL GET_ENV ( END_TIME, 'AVG_FILE_ENDTIME', END_TIME, VARDEV ) + + ! ACONC File Species List + CALL GET_ENV ( 'AVG_CONC_SPCS', N_ACONC_VARS, ACONC_FILE_SPCS, VARDEV ) + + ! CONC File Species List + CALL GET_ENV ( 'CONC_SPCS', N_CONC_VARS, CONC_FILE_SPCS, VARDEV ) + + ! ACONC Layer Specification + CALL GET_ENV ( 'ACONC_BLEV_ELEV', NV, V_LIST2, VARDEV ) + IF ( NV .LE. 0 ) THEN ! assume 1:NLAYS + ACONC_BLEV = 1 + ACONC_ELEV = -1 + ELSE IF ( NV .EQ. 1 ) THEN ! Assume 1:CONC_BLEV_ELEV + ACONC_BLEV = 1 + READ( V_LIST2( 2 ), '( I4 )' ) ACONC_ELEV + ELSE IF ( NV .EQ. 2 ) THEN ! Correct Input + READ( V_LIST2( 1 ), '( I4 )' ) ACONC_BLEV + READ( V_LIST2( 2 ), '( I4 )' ) ACONC_ELEV + ELSE + XMSG = 'Environment variable error for ACONC_BLEV_ELEV' + CALL M3EXIT( 'INIT_ENV_VARS', JDATE, JTIME, XMSG, EXIT_STATUS ) + END IF + + ! CONC File Vertical Layer Range and Speciation + CALL GET_ENV ( 'CONC_BLEV_ELEV', NV, V_LIST2, VARDEV ) + IF ( NV .LE. 0 ) THEN ! assume 1:NLAYS + CONC_BLEV = 1 + CONC_ELEV = -1 + ELSE IF ( NV .EQ. 1 ) THEN ! Assume 1:CONC_BLEV_ELEV + CONC_BLEV = 1 + READ( V_LIST2( 2 ), '( I4 )' ) CONC_ELEV + ELSE IF ( NV .EQ. 2 ) THEN ! Correct Input + READ( V_LIST2( 1 ), '( I4 )' ) CONC_BLEV + READ( V_LIST2( 2 ), '( I4 )' ) CONC_ELEV + ELSE + XMSG = 'Environment variable error for CONC_BLEV_ELEV' + CALL M3EXIT( 'INIT_ENV_VARS', JDATE, JTIME, XMSG, EXIT_STATUS ) + END IF + + ! PWRTFLAG + CALL GET_ENV ( PWRTFLAG, 'IOAPI_LOG_WRITE', PWRTFLAG, VARDEV ) + + ! Get Flag for Vertical Extraction + CALL GET_ENV ( LVEXT, 'VERTEXT', LVEXT, VARDEV ) +#ifdef parallel + ! Get Filepath for File Specifying Lon-Lat Coordinates for + ! Vertical Extraction + CALL GET_ENV ( VEXT_COORD_PATH, 'VERTEXT_COORD_PATH', VEXT_COORD_PATH, VARDEV ) +#else + IF( LVEXT ) THEN + LVEXT = .FALSE. + WRITE( OUTDEV,'(A)')'Option to extract a Vertical Column of Ouptut Data set to YES' + WRITE( OUTDEV,'(A)')'However, the serial version cannot execute the option' + WRITE( LOGDEV,'(A)')'Option to extract a Vertical Column of Ouptut Data set to YES' + WRITE( LOGDEV,'(A)')'However, the serial version cannot execute the option' + END IF +#endif + + ! Get Filename for Gas Species Namelist + CALL GET_ENV ( GC_NAMELIST, 'gc_matrix_nml', GC_NAMELIST, VARDEV ) + + ! Get Filename for Aerosol Species Namelist + CALL GET_ENV ( AE_NAMELIST, 'ae_matrix_nml', AE_NAMELIST, VARDEV ) + + ! Get Filename for Nonreactive Species Namelist + CALL GET_ENV ( NR_NAMELIST, 'nr_matrix_nml', NR_NAMELIST, VARDEV ) + + ! Get Filename for Tracer Species Namelist + CALL GET_ENV ( TR_NAMELIST, 'tr_matrix_nml', TR_NAMELIST, VARDEV ) + +#ifdef isam + !------------------------------------------------------------------------------------------------------- + !>> ISAM + !------------------------------------------------------------------------------------------------------- + IF ( MYPE .EQ. 0 ) THEN + CALL LOG_SUBHEADING( OUTDEV, "ISAM setting and output options" ) + WRITE( OUTDEV, '(6x,A)' ),'--Env Variable-- | --Value--' + WRITE( OUTDEV, '(6x,A)' ), REPEAT( '-',80 ) + END IF + + + ! Determine if this ISAM run is a new start or a restart + CALL GET_ENV ( ISAM_NEW_START, 'ISAM_NEW_START', ISAM_NEW_START, VARDEV ) + + ! SA_ACONC Layer Specification + CALL GET_ENV ( 'AISAM_BLEV_ELEV', NV, V_LIST2, VARDEV ) + IF ( NV .LE. 0 ) THEN ! assume 1:NLAYS + AISAM_BLEV = 1 + AISAM_ELEV = -1 + ELSE IF ( NV .EQ. 1 ) THEN ! Assume 1:AISAM_BLEV_ELEV + AISAM_BLEV = 1 + READ( V_LIST2( 2 ), '( I4 )' ) AISAM_ELEV + ELSE IF ( NV .EQ. 2 ) THEN ! Correct Input + READ( V_LIST2( 1 ), '( I4 )' ) AISAM_BLEV + READ( V_LIST2( 2 ), '( I4 )' ) AISAM_ELEV + ELSE + XMSG = 'Environment variable error for AISAM_BLEV_ELEV' + CALL M3EXIT( 'INIT_ENV_VARS', JDATE, JTIME, XMSG, EXIT_STATUS ) + END IF + + ! SA_CONC File Vertical Layer Range and Speciation + CALL GET_ENV ( 'ISAM_BLEV_ELEV', NV, V_LIST2, VARDEV ) + IF ( NV .LE. 0 ) THEN ! assume 1:NLAYS + ISAM_BLEV = 1 + ISAM_ELEV = -1 + ELSE IF ( NV .EQ. 1 ) THEN ! Assume 1:ISAM_BLEV_ELEV + ISAM_BLEV = 1 + READ( V_LIST2( 2 ), '( I4 )' ) ISAM_ELEV + ELSE IF ( NV .EQ. 2 ) THEN ! Correct Input + READ( V_LIST2( 1 ), '( I4 )' ) ISAM_BLEV + READ( V_LIST2( 2 ), '( I4 )' ) ISAM_ELEV + ELSE + XMSG = 'Environment variable error for ISAM_BLEV_ELEV' + CALL M3EXIT( 'INIT_ENV_VARS', JDATE, JTIME, XMSG, EXIT_STATUS ) + END IF + + ! Get species bias case + CALL GET_ENV ( ISAM_CHEM_BIAS, 'ISAM_O3_WEIGHTS', ISAM_CHEM_BIAS, VARDEV ) + IF ( ISAM_CHEM_BIAS .LT. 1 .OR. ISAM_CHEM_BIAS .GT. 5 ) THEN + XMSG = 'ISAM_O3_WEIGHTS must equal 1 thru 5' + WRITE( OUTDEV, '(A)' )TRIM( XMSG ) + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + IF ( ISAM_CHEM_BIAS .EQ. 5 ) THEN + EFLAG = .FALSE. + ! VOC_NOX_TRANS value, ratio of H2O2 over HNO3 production rates or concentration + CALL GET_ENV ( VOC_NOX_TRANS, 'VOC_NOX_TRANS', VOC_NOX_TRANS, VARDEV ) + CALL GET_ENV ( ISAM_NOX_CASE, 'ISAM_NOX_CASE', ISAM_NOX_CASE, VARDEV ) + CALL GET_ENV ( ISAM_VOC_CASE, 'ISAM_VOC_CASE', ISAM_VOC_CASE, VARDEV ) + IF ( ISAM_NOX_CASE .LT. 1 .OR. ISAM_NOX_CASE .GT. 4 ) THEN + XMSG = 'ISAM_NOX_CASE must equal 1 thru 4' + WRITE( OUTDEV, '(A)' )TRIM( XMSG ) + EFLAG = .TRUE. + END IF + IF ( ISAM_VOC_CASE .LT. 1 .OR. ISAM_VOC_CASE .GT. 4 ) THEN + XMSG = 'ISAM_VOC_CASE must equal 1 thru 4' + WRITE( OUTDEV, '(A)' )TRIM( XMSG ) + EFLAG = .TRUE. + END IF + IF ( ISAM_VOC_CASE .EQ. ISAM_NOX_CASE ) THEN + XMSG = 'ISAM_VOC_CASE must NOT equal ISAM_NOX_CASE' + WRITE( OUTDEV, '(A)' )TRIM( XMSG ) + XMSG = 'Set ISAM_O3_WEIGHTS to their value.' + WRITE( OUTDEV, '(A)' )TRIM( XMSG ) + EFLAG = .TRUE. + END IF + IF ( EFLAG ) CALL M3EXIT ( PNAME, 0, 0, 'Found errors in ISAM options', XSTAT1 ) + END IF +#endif + + !------------------------------------------------------------------------------------------------------- + !>> Chemistry and Photolysis + !------------------------------------------------------------------------------------------------------- + + IF ( MYPE .EQ. 0 ) THEN + CALL LOG_SUBHEADING( OUTDEV, "Chemistry and Photolysis" ) + WRITE( OUTDEV, '(6x,A)' ),'--Env Variable-- | --Value--' + WRITE( OUTDEV, '(6x,A)' ), REPEAT( '-',80 ) + END IF + + ! Get photolysis rate diagnostic file flag + CALL GET_ENV ( PHOTDIAG, 'CTM_PHOTDIAG', PHOTDIAG, VARDEV ) + + IF( PHOTDIAG ) THEN + ! Get desired number of layers for PHOTDIAG2 and PHOTDIAG3 files + CALL GET_ENV ( NLAYS_DIAG, 'NLAYS_PHOTDIAG', NLAYS_DIAG, VARDEV ) + + ! Get Desired Wavelengths for Diagnostic Output + CALL GET_ENV( 'NWAVE_PHOTDIAG', NWAVE, WAVE_ENV, VARDEV ) + END IF + + ! Get flag to use core-shell mixing model for aerosol optical properties + CALL GET_ENV ( CORE_SHELL, 'CORE_SHELL_OPTICS', CORE_SHELL, VARDEV ) + + ! Get flag to use fast optics for volume mixing model for aerosol optical properties + CALL GET_ENV ( MIE_CALC, 'OPTICS_MIE_CALC', MIE_CALC, VARDEV ) + + !Absolute Tolerance for SMVGEAR + CALL GET_ENV ( GEAR_ATOL, 'GEAR_ATOL', GEAR_ATOL, VARDEV ) + + !Relative Tolerance for SMVGEAR + CALL GET_ENV ( GEAR_RTOL, 'GEAR_RTOL', GEAR_RTOL, VARDEV ) + + ! Tolerances for Rosenbrock Solver + CALL GET_ENV ( GLBL_RTOL, 'RB_RTOL', GLBL_RTOL, VARDEV ) + + ! Absolute Tolerance for RB Solver + CALL GET_ENV ( GLBL_ATOL, 'RB_ATOL', GLBL_ATOL, VARDEV ) + + !------------------------------------------------------------------------------------------------------- + !>> Aerosols + !------------------------------------------------------------------------------------------------------- + + IF ( MYPE .EQ. 0 ) THEN + CALL LOG_SUBHEADING( OUTDEV, "Aerosols" ) + WRITE( OUTDEV, '(6x,A)' ),'--Env Variable-- | --Value--' + WRITE( OUTDEV, '(6x,A)' ), REPEAT( '-',80 ) + END IF + + ! Get flag for interpreting initial condition aerosol size distributions as dry + CALL GET_ENV ( IC_AERO_M2WET, 'IC_AERO_M2WET', IC_AERO_M2WET, VARDEV ) + + ! Get flag for interpreting initial condition aerosol size distributions as dry + CALL GET_ENV ( BC_AERO_M2WET, 'BC_AERO_M2WET', BC_AERO_M2WET, VARDEV ) + + ! Get flag for using initial condition aerosol second moment + CALL GET_ENV ( IC_AERO_M2USE, 'IC_AERO_M2USE', IC_AERO_M2USE, VARDEV ) + + ! Get flag for using initial condition aerosol second moment + CALL GET_ENV ( BC_AERO_M2USE, 'BC_AERO_M2USE', BC_AERO_M2USE, VARDEV ) + + !------------------------------------------------------------------------------------------------------- + !>> sulfur tracking option + !------------------------------------------------------------------------------------------------------- + + ! Flag for sulfur tracking option + CALL GET_ENV ( STM, 'STM_SO4TRACK', STM, VARDEV ) + + IF ( STM ) THEN + ! Get sulfur tracking normalization flag + CALL GET_ENV ( ADJ_STMSPC, 'STM_ADJSO4', ADJ_STMSPC, VARDEV ) + END IF + + !------------------------------------------------------------------------------------------------------- + !>> Cloud Parameters + !------------------------------------------------------------------------------------------------------- + + IF ( MYPE .EQ. 0 ) THEN + CALL LOG_SUBHEADING( OUTDEV, "Cloud Processes" ) + WRITE( OUTDEV, '(6x,A)' ),'--Env Variable-- | --Value--' + WRITE( OUTDEV, '(6x,A)' ), REPEAT( '-',80 ) + END IF + + ! FLag for outputting cloud diagnostics + CALL GET_ENV ( CLD_DIAG, 'CLD_DIAG', CLD_DIAG, VARDEV ) + + !------------------------------------------------------------------------------------------------------- + !>> Air-Surface Exchange Parameters + !------------------------------------------------------------------------------------------------------- + + IF ( MYPE .EQ. 0 ) THEN + CALL LOG_SUBHEADING( OUTDEV, "Air-Surface Exchange Processes" ) + WRITE( OUTDEV, '(6x,A)' ),'--Env Variable-- | --Value--' + WRITE( OUTDEV, '(6x,A)' ), REPEAT( '-',80 ) + END IF + + ! Check if using PX version of MCIP + CALL GET_ENV ( PX_LSM, 'PX_VERSION', PX_LSM, VARDEV ) + + ! Flag for Ammonia bi-directional flux with in-line deposition + ! velocities calculation + CALL GET_ENV ( ABFLUX, 'CTM_ABFLUX', ABFLUX, VARDEV ) + + ! Flag for Mosaic method to get land-use specific deposition velocities + CALL GET_ENV ( MOSAIC, 'CTM_MOSAIC', MOSAIC, VARDEV ) + + ! Flag for HONO interaction with leaf and building surfaces + CALL GET_ENV ( SFC_HONO, 'CTM_SFC_HONO', SFC_HONO, VARDEV ) + + ! Flag CLM LSM + CALL GET_ENV ( CLM_LSM, 'CLM_VERSION', CLM_LSM, VARDEV ) + + ! Flag for NOAH LSM + CALL GET_ENV ( NOAH_LSM, 'NOAH_VERSION', NOAH_LSM, VARDEV ) + + ! CTM_DEPV_FILE + CALL GET_ENV ( DEPV_DIAG, 'CTM_DEPV_FILE', DEPV_DIAG, VARDEV ) + + ! CTM_HGBIDI + CALL GET_ENV ( HGBIDI, 'CTM_HGBIDI', HGBIDI, VARDEV ) + + ! CTM_IGNORE_FERT_NH3 + CALL GET_ENV ( BIDI_FERT_NH3, 'CTM_BIDI_FERT_NH3', BIDI_FERT_NH3, VARDEV ) + + ! Flag for using BELD Land Use for WindBlown Dust + CALL GET_ENV ( STRTEMP, 'CTM_WBDUST_BELD', DUST_LAND_SCHEME, VARDEV ) + DUST_LAND_SCHEME = STRTEMP( 1:16) + + ! Get Name of STAGE Control File + CALL GET_ENV ( STAGECTRL, 'STAGECTRL_NML', STAGECTRL, VARDEV ) + + ! Flag for Surface Tiled Aerosol and Gaseous Exchange (STAGE) model Pleim et al. 2022 Aerosol Deposition Option + CALL GET_ENV ( STAGE_P22, 'CTM_STAGE_P22', STAGE_P22, VARDEV ) + + ! Flag for Surface Tiled Aerosol and Gaseous Exchange (STAGE) model Emerson et al. 2020 Aerosol Deposition Option + CALL GET_ENV ( STAGE_E20, 'CTM_STAGE_E20', STAGE_E20, VARDEV ) + + ! Flag for Surface Tiled Aerosol and Gaseous Exchange (STAGE) model Shu et al. 2022 (CMAQ v5.3) Aerosol Deposition Option + CALL GET_ENV ( STAGE_S22, 'CTM_STAGE_S22', STAGE_S22, VARDEV ) + + !------------------------------------------------------------------------------------------------------- + !>> Transport Processes + !------------------------------------------------------------------------------------------------------- + + IF ( MYPE .EQ. 0 ) THEN + CALL LOG_SUBHEADING( OUTDEV, "Transport Processes" ) + WRITE( OUTDEV, '(6x,A)' ),'--Env Variable-- | --Value--' + WRITE( OUTDEV, '(6x,A)' ), REPEAT( '-',80 ) + END IF + + ! CTM_VDIFF_DIAG_FILE + CALL GET_ENV ( VDIFFDIAG, 'CTM_VDIFF_DIAG_FILE', VDIFFDIAG, VARDEV ) + + ! Get Minimum Layer for Advection Time Step Adjustment + CALL GET_ENV ( SIGST, 'SIGMA_SYNC_TOP', SIGST, VARDEV ) + + ! Get Maximum Horizontal Div Limit for Advection Adjustment + CALL GET_ENV ( HDIV_LIM, 'ADV_HDIV_LIM', HDIV_LIM, VARDEV ) + + ! CFL Criteria + CALL GET_ENV ( CFL, 'CTM_ADV_CFL', CFL, VARDEV ) + + ! CTM_KZMIN + CALL GET_ENV ( MINKZ, 'KZMIN', MINKZ, VARDEV ) + + ! CTM_WVEL + CALL GET_ENV ( W_VEL, 'CTM_WVEL', W_VEL, VARDEV ) + + ! CTM_GRAV_SETL + CALL GET_ENV ( GRAV_SETL, 'CTM_GRAV_SETL', GRAV_SETL, VARDEV ) + + !------------------------------------------------------------------------------------------------------- + !>> Emission Environment Variables + !------------------------------------------------------------------------------------------------------- + + IF ( MYPE .EQ. 0 ) THEN + CALL LOG_SUBHEADING( OUTDEV, "Emissions Parameters" ) + WRITE( OUTDEV, '(6x,A)' ),'--Env Variable-- | --Value--' + WRITE( OUTDEV, '(6x,A)' ), REPEAT( '-',80 ) + END IF + + ! Number of Layers for Emissions + CALL GET_ENV ( EMLAYS_MX, 'CTM_EMLAYS', EMLAYS_MX, VARDEV ) + + ! Get Name of Emission Control File + CALL GET_ENV ( MISC_CTRL, 'MISC_CTRL_NML', MISC_CTRL, VARDEV ) + CALL GET_ENV ( DESID_CTRL, 'DESID_CTRL_NML', DESID_CTRL, VARDEV ) + CALL GET_ENV ( DESID_CHEM_CTRL,'DESID_CHEM_CTRL_NML', DESID_CHEM_CTRL, VARDEV ) + + ! Get number of different Gridded File Emissions Streams + CALL GET_ENV ( N_FILE_GR, 'N_EMIS_GR', N_FILE_GR, VARDEV ) + + ! Get number of different Gridded File Emissions Streams + CALL GET_ENV ( N_FILE_TR, 'N_EMIS_TR', N_FILE_TR, VARDEV ) + + ! Flag for checking emissions surrogates against species actually + ! present on emissions files + CALL GET_ENV ( EMISCHK, 'CTM_EMISCHK', EMISCHK, VARDEV ) + + ! CTM_BIOGEMIS_BE + CALL GET_ENV ( BIOGEMIS_BEIS, 'CTM_BIOGEMIS_BE', BIOGEMIS_BEIS, VARDEV ) + + ! CTM_BIOGEMIS_MG + CALL GET_ENV(BIOGEMIS_MEGAN, 'CTM_BIOGEMIS_MG', BIOGEMIS_MEGAN,VARDEV ) + CALL GET_ENV(USE_MEGAN_LAI, 'USE_MEGAN_LAI',USE_MEGAN_LAI,VARDEV ) + CALL GET_ENV(MGN_ONLN_DEP, 'MGN_ONLN_DEP',MGN_ONLN_DEP,VARDEV ) + CALL GET_ENV(BDSNP_MEGAN, 'BDSNP_MEGAN',BDSNP_MEGAN,VARDEV ) + + ! Get the speciation profile to use + CALL GET_ENV ( SPPRO, 'BIOG_SPRO', SPPRO, VARDEV ) + + ! Biogenic Emission Diag File + CALL GET_ENV ( BEMIS_DIAG, 'B3GTS_DIAG', BEMIS_DIAG, VARDEV ) + + ! Get marine gas emission diagnostic output file flag. + CALL GET_ENV ( MGEMDIAG, 'CTM_MGEMDIAG', MGEMDIAG, VARDEV ) + + ! Flag for ocean halogen chemistry and sea spray aerosol emissions + CALL GET_ENV ( OCEAN_CHEM, 'CTM_OCEAN_CHEM', OCEAN_CHEM, VARDEV ) + + ! Flag for Online Calculation of Windblown dust emissions + CALL GET_ENV ( WB_DUST, 'CTM_WB_DUST', WB_DUST, VARDEV ) + + ! Get env var for diagnostic output + CALL GET_ENV ( DUSTEM_DIAG, 'CTM_DUSTEM_DIAG', DUSTEM_DIAG, VARDEV ) + + ! Get sea spray emission diagnostic output file flag. + CALL GET_ENV ( SSEMDIAG, 'CTM_SSEMDIAG', SSEMDIAG, VARDEV ) + + ! Set LTNG_NO to Y or T to turn on lightning NO production + CALL GET_ENV ( LTNG_NO, 'CTM_LTNG_NO', LTNG_NO, VARDEV ) + + ! Get Lightning Input Time Interval + CALL GET_ENV ( LT_ASM_DT, 'LTNG_ASSIM_DT', LT_ASM_DT, VARDEV ) + + ! Get Lightning NO File Name + CALL GET_ENV ( LTNG_FNAME, 'LTNGNO', LTNG_FNAME, VARDEV ) + + ! Flag for using NLDN data for Lightning Strikes + CALL GET_ENV ( NLDNSTRIKE, 'USE_NLDN', NLDNSTRIKE, VARDEV ) + + ! Flag for Outputing Lightning Diagnostic File + CALL GET_ENV ( LTNGDIAG, 'LTNGDIAG', LTNGDIAG, VARDEV ) + + ! Get Lightning NO Production Rate + CALL GET_ENV ( MOLSNCG, 'MOLSNCG', 350.0, VARDEV ) + + ! Get Lightning NO Production Rate + CALL GET_ENV ( MOLSNIC, 'MOLSNIC', 350.0, VARDEV ) + + ! get number of different file groups (sectors) + CALL GET_ENV ( NPTGRPS, 'N_EMIS_PT', NPTGRPS, VARDEV ) + + ! PT3DDIAG +! CALL GET_ENV ( PT3DDIAG, 'PT3DDIAG', PT3DDIAG, VARDEV ) + + ! PT3DFRAC +! CALL GET_ENV ( PT3DFRAC, 'PT3DFRAC', PT3DFRAC, VARDEV ) + + ! Point Source Time Steps +! CALL GET_ENV ( PT_NSTEPS, 'LAYP_NSTEPS', PT_NSTEPS, VARDEV ) + + ! Point Source Date +! CALL GET_ENV ( PT_DATE, 'LAYP_STDATE', PT_DATE, VARDEV ) + + ! Point Source Time +! CALL GET_ENV ( PT_TIME, 'LAYP_STTIME', PT_TIME, VARDEV ) + + ! IPVERT + CALL GET_ENV ( IPVERT, 'IPVERT', IPVERT, VARDEV ) + + ! REP_LAYR +! CALL GET_ENV ( REP_LAYR, 'REP_LAYER_MIN', REP_LAYR, VARDEV ) + +! ALLOCATE( PLAY_BASE( NPTGRPS ) ) +! PLAY_BASE( : ) = '' +! DO NV = 1,NPTGRPS +! WRITE( PBASE,'( "PLAY_BASE", "_", I2.2 )' ) NV +! CALL GET_ENV ( STRTEMP, PBASE, PLAY_BASE( NV ), VARDEV ) +! PLAY_BASE( NV ) = STRTEMP +! END DO + + ! Determine user-defined default for emissions date override for representative days + CALL GET_ENV ( EMIS_SYM_DATE, 'EMIS_SYM_DATE', EMIS_SYM_DATE, VARDEV ) + + !------------------------------------------------------------------------------------------------------- + !>> Process Analysis + !------------------------------------------------------------------------------------------------------- + + IF ( MYPE .EQ. 0 ) THEN + CALL LOG_SUBHEADING( OUTDEV, "Process Analysis Parameters" ) + WRITE( OUTDEV, '(6x,A)' ),'--Env Variable-- | --Value--' + WRITE( OUTDEV, '(6x,A)' ), REPEAT( '-',80 ) + END IF + + ! Flag for Using Process Analysis + CALL GET_ENV ( PROCAN, 'CTM_PROCAN', PROCAN, VARDEV ) + + ! Get the Beginning and Ending Columns for Process Analysis + CALL GET_ENV ( 'PA_BCOL_ECOL', NV, V_LIST2, VARDEV ) + IF ( NV .LE. 0 ) THEN + PA_BEGCOL = 1; PA_ENDCOL = 0 + ELSE IF ( NV .EQ. 2 ) THEN + READ( V_LIST2( 1 ), '( I4 )' ) PA_BEGCOL + READ( V_LIST2( 2 ), '( I4 )' ) PA_ENDCOL + ELSE + XMSG = 'Environment variable error for PA_BCOL_ECOL' + CALL M3EXIT( 'INIT_ENV_VARS', JDATE, JTIME, XMSG, EXIT_STATUS ) + END IF + + ! Get the Beginning and Ending Rows for Process Analysis + CALL GET_ENV ( 'PA_BROW_EROW', NV, V_LIST2, VARDEV ) + IF ( NV .LE. 0 ) THEN + PA_BEGROW = 1; PA_ENDROW = 0 + ELSE IF ( NV .EQ. 2 ) THEN + READ( V_LIST2( 1 ), '( I4 )' ) PA_BEGROW + READ( V_LIST2( 2 ), '( I4 )' ) PA_ENDROW + ELSE + XMSG = 'Environment variable error for PA_BROW_EROW' + CALL M3EXIT( 'INIT_ENV_VARS', JDATE, JTIME, XMSG, EXIT_STATUS ) + END IF + + ! Get the Beginning and Ending Layers for Process Analysis + CALL GET_ENV ( 'PA_BLEV_ELEV', NV, V_LIST2, VARDEV ) + IF ( NV .LE. 0 ) THEN + PA_BEGLEV = 1; PA_ENDLEV = 0 + ELSE IF ( NV .EQ. 2 ) THEN + READ( V_LIST2( 1 ), '( I4 )' ) PA_BEGLEV + READ( V_LIST2( 2 ), '( I4 )' ) PA_ENDLEV + ELSE + XMSG = 'Environment variable error for PA_BLEV_ELEV' + CALL M3EXIT( 'INIT_ENV_VARS', JDATE, JTIME, XMSG, EXIT_STATUS ) + END IF + + IF ( OCEAN_CHEM ) THEN + IF ( (INDEX( MECHNAME, 'CB6R5M_AE7_AQ') .GT. 0 ) .OR. + & (INDEX( MECHNAME, 'CB6R5_AE7_AQ' ) .GT. 0) ) then + USE_MARINE_GAS_EMISSION = .TRUE. + ENDIF + ENDIF + +! for MPAS +#ifdef mpas + call get_env (ncd_64bit_offset, 'ncd_64bit_offset', .false., vardev) + call get_env( cell_num, 'cell_num', 1, vardev) +#endif + +#ifdef twoway + WRF_V4P = .TRUE. +#else +! to obtain WRF version information + IF ( .NOT. OPEN3( MET_CRO_3D, FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open '// MET_CRO_3D // ' file' + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + IF ( .NOT. DESC3( MET_CRO_3D ) ) THEN + XMSG = 'Could not get ' // MET_CRO_3D //' file description' + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + ! Get environ. variable met_tstep to control meteorology frequency + CALL GET_ENV ( MET_TSTEP, 'MET_TSTEP', TSTEP3D, VARDEV) + + ! Ensure users cannot pick a met_tstep that is not smaller than the + ! file time step and something that is not a multiple of that tstep + + IF (MOD(TIME2SEC(MET_TSTEP), TIME2SEC(TSTEP3D)) .NE. 0) then + XMSG = 'MET_TSTEP environmental variable not equal to or a + & multiple greater than time step of met file ' // MET_CRO_3D + CALL M3EXIT(PNAME, 0, 0, XMSG, XSTAT1) + end if + + FOUND = .FALSE. + NV = 0 + Do WHILE ((.NOT. FOUND) .AND. (NV .LT. MXDESC3)) + NV = NV + 1 + LOC = INDEX (FDESC3D(NV), 'WRF ARW V') + IF (LOC > 0) THEN + FOUND = .TRUE. + STR_LEN = LEN_TRIM(FDESC3D(NV)) + READ (FDESC3D(NV)(LOC+9:STR_LEN), *) WRF_VERSION + IF (WRF_VERSION .GE. '4.1') THEN + WRF_V4P = .TRUE. + END IF + END IF + END DO + + XMSG = 'MET data determined based on WRF ARW version ' + IF( MYPE .EQ. 0 ) THEN + WRITE(OUTDEV,'(/,5X,2(A,1X),/)')TRIM( XMSG ), TRIM( FDESC3D(NV)(LOC+9:STR_LEN) ) + WRITE(LOGDEV,'(/,5X,2(A,1X),/)')TRIM( XMSG ), TRIM( FDESC3D(NV)(LOC+9:STR_LEN) ) + ELSE + WRITE(LOGDEV,'(/,5X,2(A,1X),/)')TRIM( XMSG ), TRIM( FDESC3D(NV)(LOC+9:STR_LEN) ) + END IF + + IF ( .NOT. CLOSE3( MET_CRO_3D ) ) THEN + XMSG = 'Could not close ' // MET_CRO_3D + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF +#endif + + END SUBROUTINE INIT_ENV_VARS + +!......................................................................... + SUBROUTINE LOG_HEADING( FUNIT, CHEAD_IN ) + +! Formats and writes a user-supplied heading to a specific log file. +! This approach is intended to standardize the log files that are +! created by CMAQ. The length of the input array is set at 80 because +! we would like to try limiting lines to 80 characters and a heading +! should probably just be one line. +!......................................................................... + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: FUNIT + CHARACTER( * ), INTENT( IN ) :: CHEAD_IN + CHARACTER( len=: ), ALLOCATABLE :: CHEAD + CHARACTER( 20 ) :: FMT + CHARACTER( 20 ) :: FMT2 + INTEGER :: LDASH + + ! Capitalize the heading + CHEAD = CHEAD_IN + CALL UPCASE( CHEAD ) + + ! Write the heading to the log file + WRITE( FUNIT, * ) + WRITE( FMT, '("(", I0, "x,A,A,A)")' ) LOG_MAJOR_TAB + WRITE( FMT2,'("(", I0, "x,A,)")' ) LOG_MAJOR_TAB + + LDASH = 2*8 + LEN_TRIM( CHEAD ) + WRITE( FUNIT, FMT2 ), REPEAT( '=', LDASH ) + WRITE( FUNIT, FMT ), + & '|>--- ',TRIM( CHEAD ),' ---<|' + WRITE( FUNIT, FMT2 ), REPEAT( '=', LDASH ) + + END SUBROUTINE LOG_HEADING + +!......................................................................... + SUBROUTINE LOG_SUBHEADING( FUNIT, CHEAD ) + +! Formats and writes a user-supplied sub-heading to a specific log file. +! This approach is intended to standardize the log files that are +! created by CMAQ. The length of the input array is set at 80 because +! we would like to try limiting lines to 80 characters and a sub-heading +! should probably just be one line. +!......................................................................... + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: FUNIT + CHARACTER( * ), INTENT( IN ) :: CHEAD + CHARACTER( 20 ) :: FMT + INTEGER :: LDASH + + ! Write the sub-heading to the log file + WRITE( FMT, '("(/,", I0, "x,A,A,A)")' ) LOG_MAJOR_TAB + WRITE( FUNIT, FMT ),'|> ',TRIM( CHEAD ),':' + LDASH = 2*3 - 1 + LEN_TRIM( CHEAD ) + + WRITE( FMT, '("(", I0, "x,A,A)")' ) LOG_MAJOR_TAB + WRITE( FUNIT, FMT ) '+',REPEAT( '=', LDASH ) + + END SUBROUTINE LOG_SUBHEADING + +!......................................................................... + SUBROUTINE LOG_MESSAGE( FUNIT, CMSG_IN ) + +! Formats and writes a user-supplied message to a specific log file. +! This approach is intended to standardize the log files that are +! created by CMAQ. +!......................................................................... + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: FUNIT + CHARACTER( * ), INTENT( IN ) :: CMSG_IN + CHARACTER( len=: ), ALLOCATABLE :: CMSG + CHARACTER( 20 ) :: FMT + + CHARACTER( LOG_LINE_LENGTH ) :: CTEMP + INTEGER :: MSG_SIZE + INTEGER :: NLINE1, NLINE2, NLINE, NTAB, LAST_SPACE + + CMSG = CMSG_IN + + ! Write the message to the log file, while trimming to 80 + ! characters (while accounting for tab-length) + NLINE1 = LOG_LINE_LENGTH - LOG_MAJOR_TAB + NLINE2 = LOG_LINE_LENGTH - LOG_MAJOR_TAB - LOG_MINOR_TAB + NLINE = NLINE1 + NTAB = LOG_MAJOR_TAB + + ! Determine Length of Total Message + MSG_SIZE = LEN_TRIM( CMSG ) + + DO WHILE ( MSG_SIZE .GT. LOG_LINE_LENGTH ) + ! Isolate One Line of Text + LAST_SPACE = INDEX( CMSG( 1:NLINE+1 ), " ", BACK=.TRUE. ) + + CTEMP = CMSG( 1:LAST_SPACE-1 ) + + WRITE( FMT, '("(", I0, "x,A)")' ) NTAB + WRITE( FUNIT, FMT ), CTEMP + + CMSG = CMSG( LAST_SPACE+1:LEN( CMSG ) ) + MSG_SIZE = LEN_TRIM( CMSG ) + + IF ( NTAB .EQ. LOG_MAJOR_TAB ) NTAB = NTAB + LOG_MINOR_TAB + IF ( NLINE.EQ. NLINE1 ) NLINE = NLINE2 + END DO + + ! Write Last Line + WRITE( FMT, '("(", I0, "x,A)")' ) NTAB + WRITE( FUNIT, FMT ), TRIM( CMSG ) + + + END SUBROUTINE LOG_MESSAGE + +!......................................................................... + SUBROUTINE TIMING_SPLIT( CPU_TIME_START, IMSG, CPROCIN ) + +! This subroutine provides a split for the MPI timing functions and +! then prints out a message for how much time has passed using a +! character string input for customizing that message. +!......................................................................... + + IMPLICIT NONE + +#ifdef parallel + INCLUDE 'mpif.h' +#endif + REAL( 8 ) :: CPU_TIME_START + REAL( 8 ) :: CPU_TIME_FINISH + INTEGER :: IMSG ! What kind of checkpoint this is + ! 1 = 'PROCESS' + ! 2 = 'MASTER TIME STEP' + ! 3 = 'OUTPUT' + CHARACTER( * ), INTENT(IN), OPTIONAL :: CPROCIN + CHARACTER( len=: ), ALLOCATABLE :: CPROC + CHARACTER( 250 ) :: XMSG + +#ifndef parallel + REAL :: REAL_TIME +#endif + + + IF ( PRESENT( CPROCIN ) ) THEN + CPROC = CPROCIN + ELSE + CPROC = ' ' + END IF + + ! Record Time at this Checkpoint +#ifdef parallel + CPU_TIME_FINISH = MPI_WTIME() +#else + CALL CPU_TIME( REAL_TIME ) + CPU_TIME_FINISH = REAL( REAL_TIME,8 ) +#endif + + + ! Assemble the statement requested by the calling program + SELECT CASE ( IMSG ) + CASE ( 1 ) + ! Write Out The Time to Complete Each Sub-Process + WRITE( XMSG, 1002 ),TRIM( CPROC ), CPU_TIME_FINISH-CPU_TIME_START +1002 FORMAT ( 2x, A15, ' completed... ', F12.4, ' seconds' ) + + CASE ( 2 ) + ! Write out the time to complete the entire master time step + WRITE( XMSG, '(7x,A16)' ),'Master Time Step' + CALL LOG_MESSAGE( LOGDEV, XMSG ) +#ifndef twoway + IF ( MYPE .EQ. 0 ) CALL LOG_MESSAGE( OUTDEV, XMSG ) +#endif + WRITE( XMSG, '(7x,A24,F12.4,A8)' ),'Processing completed... ', + & (CPU_TIME_FINISH-CPU_TIME_START),' seconds' + CALL LOG_MESSAGE( LOGDEV, XMSG ) + WRITE( LOGDEV, * ) + + CASE ( 3 ) + ! Write out the time to complete the output procedure + WRITE( XMSG, '(1x,A32,F10.4,A)' ), '=--> Data Output completed... ', + & (CPU_TIME_FINISH-CPU_TIME_START),' seconds' + CALL LOG_MESSAGE( LOGDEV, XMSG ) + WRITE( LOGDEV, * ) +#ifndef twoway + IF ( MYPE .EQ. 0 ) WRITE( OUTDEV, * ) +#endif + + END SELECT + + ! Write out the timing statement +#ifndef twoway + IF ( MYPE .EQ. 0 ) CALL LOG_MESSAGE( OUTDEV, XMSG ) +#endif +#ifdef parallel + CPU_TIME_START = MPI_WTIME() +#else + CALL CPU_TIME( REAL_TIME ) + CPU_TIME_START = REAL( REAL_TIME,8 ) +#endif + END SUBROUTINE TIMING_SPLIT + + END MODULE RUNTIME_VARS diff --git a/src/model/src/centralized_io_module.F b/src/model/src/centralized_io_module.F new file mode 100644 index 0000000..e2f0ebd --- /dev/null +++ b/src/model/src/centralized_io_module.F @@ -0,0 +1,6987 @@ +!------------------------------------------------------------------------! +! The Community Multiscale Air Quality (CMAQ) system software is in ! +! continuous development by various groups and is based on information ! +! from these groups: Federal Government employees, contractors working ! +! within a United States Government contract, and non-Federal sources ! +! including research institutions. These groups give the Government ! +! permission to use, prepare derivative works of, and distribute copies ! +! of their work in the CMAQ system to the public and to permit others ! +! to do so. The United States Environmental Protection Agency ! +! therefore grants similar permission to use the CMAQ system software, ! +! but users are requested to provide copies of derivative works or ! +! products designed to operate in the CMAQ system to the United States ! +! Government without restrictions as to use by others. Software ! +! that is used with the CMAQ system but distributed under the GNU ! +! General Public License or the GNU Lesser General Public License is ! +! subject to their copyright restrictions. ! +!------------------------------------------------------------------------! + +!------------------------------------------------------------------------! +! This module contains essential data structure and functions for +! centralized I/O implementation + +! Revision History: +! 02/01/19, D. Wong: initial implementation +! 02/11/19, D. Wong: Updated to accommodate STAGE option +! 03/06/19, D. Wong: fixed a bug to handle 3D emission data structure +! correctly and fixed a bug to deal with the case of +! ABFLUX turned off +! 04/01/19, D. Wong: -- enhanced robustness to handle time independent or +! dependent boundary condition file +! -- used two different CPP flags, m3dry_opt and stage_opt +! to distinguish these two deposition options +! -- reorganized the code to read in certain files when +! they are available as well as based on environmental +! variable setting +! 05/02/19, D. Wong: -- added a logic to call soilinp_setup when BIOGEMIS is true +! 05/03/19, D. Wong: -- reorganized the flow of reading in LUS data +! 05/06/19, D. Wong: -- added a new logic to read in INIT_MEDC_1 when it is not NEW_START +! 05/07/19, D. Wong: -- removed duplicated array allocation for NH4ps1 and NH4ps2 +! 05/13/19, D. Wong: -- expanded implementation to hanndle ISAM model +! 05/15/19, D. Wong: -- used USE_MARINE_GAS_EMISSION variable defined in RUNTIME_VAR.F +! to turn on a block of code related to marine gas emssion +! 06/18/19, D. Wong: -- modified cio implementation to handle: +! * emission file date is differ from simulation date +! * region files for scaling purposes +! 06/19/19, D. Wong: -- fixed a bug in the EMIS regions subroutine +! 07/08/19, F. Sidi: -- Renamed E2C_FERT -> E2C_CHEM & BELD4_LU -> E2C_LU +! 07/09/19, T. Spero: -- Changed file for fractional land use from +! GRIDCRO2D to LUFRAC_CRO. Allow backward +! compatibility. +! 07/17/19, R. Gilliam:- Removed the FPAR file call for windblow dust. MCIP VEG is used. +! 08/12/19, F. Sidi: -- Allowed lus_setup to use fractional land use from +! GRIDCRO2D or LUFRAC_CRO. Allows backward compatibility. +! 08/01/19, D. Wong:- Made modification so centralized I/O works with two-way model +! - used new variable type descriptor +! 09/10/19, D. Wong:- Extended to handle BC file with non 1-hr time step +! 09/19/19, D. Wong:- Used the start simulation time to pick up the very first emission +! data point rather than the start time in the emission file +! 09/20/19, D. Wong:- Extended the capability to handle 3D emission files with various +! number of layers less than of equal to the model number of layers +! 10/04/19, D. Wong:- fixed the time advancement, NEXTIME, for a multi-day run +! 11/22/19, F. Sidi:- Updated cio with new algorithm (developed by D. Wong) +! to enable running CMAQ with different files having +! different time steps, cleaned up code no longer needed +! & two-way model bugfixes +! 01/30/20, D. Wong:- fixed IC file interpolation time stamp issue by bypassing the +! check whether the new request falls within the circular buffer +! for IC variable which only has one time step of data. +! 02/10/20, F. Sidi:- Changed file_tstep from tstep3d to met_tstep an environment +! variable the flexlible allows users to toggle the temporal +! frequency of their input meterology. +! 03/05/20, D. Wong: Expanded CIO functionalities to MPAS as well +! 07/24/20, D. Wong: Fixed a bug, the code did not handle calling NEXTIME properly in +! an extreme case, i.e. simulation runs in a hourly basis, in the +! retrieve_boundary_data subroutine. +! 08/06/20, D. Wong:- fixed excessive reading of time independent boundary file data +! 02/23/21, D. Wong:- used KZMIN setting to determine reading in PURB or not +! 03/23/21. D. Wong:- modified code to accommodate a flexibility to allow each input +! can have different XORIG and YORIG settings than the simulation +! domain if it can be overlapped with the simulation domain +! perfectly w.r.t. domain resolution +! 11/17/21, G. Sarwar: Changed minimum values from 0.0 to 0.001 for ocean and szone +! to ensure values are nonnegative and greater than 0.001 +! 01/17/22, D. Wong: Added SAVE attribute to variable FIRSTIME +! 03/31/22, J. Willison: Removed wb_dust_setup and modified lus_setup to remove +! BELD as an option for desert land information. +! 04/12/22, G. Sarwar: Revised to include "DMS" into cb6r5_ae7_aq +!------------------------------------------------------------------------! + +!------------------------------------------------------------------------! +! Variable type notation: +! 'mc2' denote met cro 2d variable +! 'mc3' denote 3d variable +! 'md3' denote dot variable +! 'wb' denote wind blown dust +! 'ic' denote initial condition variable +! 'is' denote ISAM initial condition variable +! 'e2d' denote emission 2d variable +! 'e3d' denote emission 3d variable +! 'lnt' denote lightning variable +! 'mb' denote met 3D boundary variable +! 'bct' denote time dependent 3D boundary variable +! 'bc' denote time independent 3D boundary variable +!------------------------------------------------------------------------! + + MODULE CENTRALIZED_IO_MODULE + + use RUNTIME_VARS, only : LTNG_NO, STDATE, STTIME, ABFLUX, MOSAIC, + & NPTGRPS, USE_MARINE_GAS_EMISSION, logdev, + & CONVECTIVE_SCHEME, EMIS_SYM_DATE + use CENTRALIZED_IO_UTIL_MODULE + use get_env_module + USE UTILIO_DEFN +#ifdef mpas +! use coupler_module !(Wei Li) +! use mio_module !(Wei Li) +#endif + + implicit none + + integer, parameter :: max_nfiles = 500 + + character (20), parameter :: biogemis_fname = 'BEIS_NORM_EMIS' + +! to recognize the time step in each file could be different, in the new revised +! implementation will address that and here is the algorithm. When open a new file, +! n_opened_file will be incremented by one to keep track of how many have been +! opened. Each file has a unique f_name except met files which will be shared with +! one f_met since their tsteps should be the same. Then n_opened_file is assigned +! to an opened time dependent file (defined below) and time information will be +! stored accordingly. + + integer :: n_opened_file = 0 + integer :: f_met, f_ltng, f_bcon, f_icon, f_is_icon,f_mbiog + integer, allocatable :: f_emis(:), f_stk_emis(:) + + integer :: file_sdate(max_nfiles) = -1 + integer :: file_stime(max_nfiles) = -1 + integer :: file_tstep(max_nfiles) = -1 + real*8 :: file_xcell(max_nfiles) = 0.0d0 + real*8 :: file_ycell(max_nfiles) = 0.0d0 + logical :: file_sym_date(max_nfiles) + + CHARACTER( 40 ), parameter :: NLDN_STRIKES = 'NLDN_STRIKES' + CHARACTER( 40 ), parameter :: ICFILE = 'INIT_CONC_1' + CHARACTER( 40 ), parameter :: BCFILE = 'BNDY_CONC_1' + CHARACTER( 40 ), parameter :: ISAM_PREVDAY = 'ISAM_PREVDAY' + +! time independent data + real, allocatable :: MSFX2(:,:), ! from GRID_CRO_2D data + & LWMASK(:,:), ! from GRID_CRO_2D data + & HT(:,:), ! from GRID_CRO_2D data + & LAT(:,:), ! from GRID_CRO_2D data + & LON(:,:), ! from GRID_CRO_2D data + & PURB(:,:), ! from GRID_CRO_2D data + & LUFRAC(:,:,:), ! from LUFRAC_CRO data + & SOILCAT_A(:,:), ! from MET_CRO_2D + & MSFD2(:,:), ! from GRID_DOT_2D data + & X3HT0M(:,:), ! from GRID_CRO_3D data + & X3HT0F(:,:), ! from GRID_CRO_3D data + & ocean(:,:), ! from OCEAN data + & szone(:,:), ! from OCEAN data + & chlr(:,:), ! from OCEAN data + & dmsl(:,:), ! from OCEAN data + & OCEAN_MASK(:,:), ! from LTNG parameter data + & SLOPE(:,:), ! from LTNG parameter data + & INTERCEPT(:,:), ! from LTNG parameter data + & SLOPE_lg(:,:), ! from LTNG parameter data + & INTERCEPT_lg(:,:), ! from LTNG parameter data + & ICCG_SUM(:,:), ! from LTNG parameter data + & ICCG_WIN(:,:), ! from LTNG parameter data + & AVGEMIS(:,:,:,:), ! from BIOGEMIS data + & GROWAGNO(:,:), ! from BEIS_NORM_EMIS data + & NGROWAGNO(:,:), ! from BEIS_NORM_EMIS data + & NONAGNO(:,:), ! from BEIS_NORM_EMIS data + & RAINFALL(:,:,:), ! from SOILINP data + & HRNO_SW(:,:,:), ! from SOILINP data + & HRNO_T2M(:,:,:), ! from SOILINP data + & LDF(:,:,:), ! from MEGANMAP data + & LAI_M(:,:,:), ! from MEGANMAP data + & EFMAPS(:,:,:), ! from MEGANMAP data + & CTF(:,:,:), ! from MEGANMAP data + & BDSNP_NDEP(:,:,:), ! from MEGAN_BDSNP data + & BDSNP_FERT(:,:), ! from MEGAN_BDSNP data + & DRYPERIOD(:,:), ! from BDSNPINP data + & NDEPRES(:,:), ! from BDSNPINP data + & NDEPRATE(:,:), ! from BDSNPINP data + & PFACTOR(:,:), ! from BDSNPINP data + & SOILMPREV(:,:), ! from BDSNPINP data + & T24y(:,:), ! from MEGAN_SOILINP data + & SW24y(:,:), ! from MEGAN_SOILINP data + & lai_y(:,:) ! from MEGAN_SOILINP data + + + integer, allocatable :: PTYPE(:,:), ! from SOILINP data + & PULSEDATE(:,:), ! from SOILINP data + & PULSETIME(:,:), ! from SOILINP data + & BDSNP_LANDTYPE(:,:),! from MEGAN_BDSNP data + & BDSNP_ARID(:,:), ! from MEGAN_BDSNP data + & BDSNP_NONARID(:,:) ! from MEGAN_BDSNP data + + character( 16 ), allocatable :: DDTTM( : ) ! for SOILINP data, description date and time + +! time dependent data: +! gridded + integer :: n_grid_cro_data_vars + integer :: n_cio_grid_vars + real, allocatable :: cio_grid_data(:) + character (24), allocatable :: cio_grid_var_name(:,:) ! stores variable name, variable type and met variable + ! or not information for each variable + integer, allocatable :: cio_grid_data_inx (:,:,:), + & head_grid(:), tail_grid(:), ! head and tail of the gridded data circular buffer + & cio_grid_data_tstamp(:,:,:) + + character (16) :: cio_dust_land_scheme + character (20), allocatable :: cio_mpas_grid_data_tstamp(:,:) + +! boundary data + integer :: n_cio_bndy_vars, n_cio_bc_file_vars + real, allocatable :: cio_bndy_data(:) + character (16), allocatable :: cio_bndy_var_name(:,:), cio_bc_file_var_name(:) + integer, allocatable :: cio_bndy_data_inx (:,:,:), + & head_bndy(:), tail_bndy(:), ! head and tail of the boundary data circular buffer + & cio_bndy_data_tstamp(:,:,:) + +! emission data +! - gridded emission data + character (16), allocatable :: cio_emis_file_name(:), + & cio_emis_var_name(:,:) + integer, allocatable :: cio_emis_file_loc(:) + integer, allocatable :: cio_emis_nvars(:) + integer, allocatable :: cio_emis_file_layer(:) + integer, allocatable :: cio_emis_file_startcol(:) + integer, allocatable :: cio_emis_file_endcol(:) + integer, allocatable :: cio_emis_file_startrow(:) + integer, allocatable :: cio_emis_file_endrow(:) + integer :: cio_emis_nlays ! max value among cio_emis_file_layer + +! this is for MPAS only + integer, allocatable :: num_dist_layers(:,:) ! number of layers in MPAS grid has re-distributed emission data + real, allocatable :: dist_frac(:,:,:) ! calculated layer distribution fraction + real, allocatable :: emis_file_layer_frac(:,:) ! given layer faction information + integer :: mpas_tstep ! this is assigned in CMAQ_DRIVER + +! - stack emission data + real, allocatable :: cio_stack_data(:) + character (16), allocatable :: cio_stack_file_name(:), + & cio_stack_var_name(:,:), + & STKGNAME( : ), ! stack groups file name + & cio_mpas_stack_emis_timestamp(:) ! for MPAS only + + integer, allocatable :: n_cio_stack_emis_vars(:), + & cio_stack_file_loc(:), + & n_cio_stack_emis_lays(:), + & n_cio_stack_emis_pts(:), + & cio_stack_emis_data_inx (:,:,:,:), + & head_stack_emis(:,:), tail_stack_emis(:,:), ! head and tail of the stack emis data circular buffer + & cio_stack_emis_data_tstamp(:,:,:,:) + + integer :: modis_data_sdate ! modis dust data start date + + integer :: cio_model_sdate, + & cio_model_stime ! model start date and time + + logical, private :: cio_LTNG_NO + + real :: CONVPA ! Pressure conversion factor file units to Pa + Real :: P0 ! reference pressure (100000.0 Pa) for Potential Temperature, + ! note that in meteorology they do not use the SI 1 ATM. + +! availability of various variable + logical :: CFRAC_3D_AVAIL = .true., ! CFRAC_3D is available or not + & PV_AVAIL = .false., ! Potential Vorticity is available or not + & TSEASFC_AVAIL = .false., ! SST is available or not + & WSPD10_AVAIL, ! WSPD10 is available or not + & UWINDC_AVAIL, ! UWINDC is available in DOT file or not + & VWINDC_AVAIL, ! VWINDC is available in DOT file or not + & QG_AVAIL = .true., ! flag for QG available in MET_CRO_3D + & QI_AVAIL, ! flag for QI available in MET_CRO_3D + & QS_AVAIL, ! flag for QS available in MET_CRO_3D + & QC_AVAIL = .true., ! flag for QC and it is always set to .true. + & JACOBF_AVAIL, ! flag for JACOBF available in MET_CRO_3D + & RNA_AVAIL = .false., ! flag for RNA available in MET_CRO_2D + & RCA_AVAIL = .false., ! flag for RCA available in MET_CRO_2D + & RA_RS_AVAIL = .true., ! flag for RA and RS available in MET_CRO_2D + & Q2_AVAIL = .true., ! flag for Q2, two meter mixing ratio available in MET_CRO_2D + & LH_AVAIL, ! flag for LH, two meter mixing ratio available in MET_CRO_2D + & HAS_SEAICE, ! flag for SEAICE in MET_CRO_2D + & WR_AVAIL = .true., ! flag for WR, canopy wetness available in MET_CRO_2D + & MEDC_AVAIL = .true., ! file INIT_MEDC_1 is available + & E2C_CHEM_AVAIL = .true., ! file E2C_CHEM is available + & GMN_AVAIL = .false., ! variable GMN available in E2C_CHEM or not + & LUCRO_AVAIL, ! file LUFRAC_CRO is available + & PXSOIL_AVAIL ! flag for WRFv4.1+ PX LSM soil extras in MET_CRO_2D + +! Met data is large enough to cover boundary and no MET_BDY_3D will be used + logical :: window + + logical :: east_pe, south_pe, west_pe, north_pe + + INTEGER :: TEMPG_LOC + INTEGER :: TSEASFC_LOC + + integer :: STRTCOLSTD, ENDCOLSTD, STRTROWSTD, ENDROWSTD, ! this is for standard domain useful for coupled model + & STRTCOLMC2, ENDCOLMC2, STRTROWMC2, ENDROWMC2, + & STRTCOLMC2x, ENDCOLMC2x, STRTROWMC2x, ENDROWMC2x, ! extension setup for READMC2 + & STRTCOLMC3, ENDCOLMC3, STRTROWMC3, ENDROWMC3, + & STRTCOLMD3, ENDCOLMD3, STRTROWMD3, ENDROWMD3, + & STRTCOLMD3x, ENDCOLMD3x, STRTROWMD3x, ENDROWMD3x, ! extension setup for READMD3 + & STRTCOLIC, ENDCOLIC, STRTROWIC, ENDROWIC, ! for ICFILE + & STRTCOLISIC, ENDCOLISIC, STRTROWISIC, ENDROWISIC, ! for ISAM ICFILE + & STRTCOLLNT, ENDCOLLNT, STRTROWLNT, ENDROWLNT ! for lightning strike file + + private :: gridded_files_setup, + & retrieve_lufrac_cro_data +#ifdef mpas +! & ,retrieve_ocean_data_mpas +#else + & ,boundary_files_setup, + & retrieve_grid_cro_2d_data, + & retrieve_grid_dot_2d_data, + & retrieve_ocean_data +#endif + + integer, private :: count = 0 + integer, private :: cio_logdev, + & size_s2d, ! standard 2d cro file size (in twoway model, size_s2d not equal to size_c2d + & size_s3d, ! standard 3d file size + & n_c2d, size_c2d, ! cro 2d file info: # of variables and a variable size + & size_c2dx, ! extended cro 2d variable size + & size_d2d, ! a 2d dot variable size + & size_d2dx, ! extended 2d dot variable spatial size + & n_c3d, size_c3d, ! cro 3d file info: # of variables and a variable size + & n_d3d, size_d3d, ! dot 3d file info: # of variables and a variable size + & size_d3dx, ! extended dot 3d variable size + & n_i3d, ! # of initial condition 3d variables + & n_is3d, ! # of initial condition 3d variables for ISAM + & n_e2d, ! # of 2d emission variables + & n_e3d, size_e3d, ! # of 3d emission variables and a variable size + & n_mb3d, ! # of 3d met boundary variables + & n_b3d, ! # of 3d boundary variables + & size_b3d, ! a 3d boundary variable size + & size_b2d, ! a 2d boundary variable size + & n_l2d, ! # of lightning strikes file variables + & size_lt ! lightning file variable size + + integer, private :: cro_ncols, cro_nrows, ! cro file nools and nrows + & w_cro_ncols, w_cro_nrows, ! window cro file nools and nrows + & x_cro_ncols, x_cro_nrows, ! extended cro file nools and nrows + & s_cro_ncols, s_cro_nrows, ! standard cro file nools and nrows (this is used to distinguish + ! met cro and regular cro file in twoway coupled model + & dot_ncols, dot_nrows, ! dot file nools and nrows + & x_dot_ncols, x_dot_nrows ! extended dot file nools and nrows + + integer, private :: cio_LTLYRS ! number of layers in lightning strike dataset + CHARACTER( 16 ) :: LT_NAME ! LNT name: old Cis NLDNstrk and new is LNT + + interface interpolate_var +!#ifdef mpas +! module procedure r_interpolate_var_1ds, +! & r_interpolate_var_2d, +! & i_interpolate_var_2d, +! & r_interpolate_var_3d +!#else + module procedure r_interpolate_var_1ds, ! Interpolation for Stack Group Real 1-D Data + & r_interpolate_var_2d, ! Interpolation for generic Real 2-D Data + & i_interpolate_var_2d, ! Interpolation for generic Integer 2-D Data + & r_interpolate_var_2db, ! Interpolation for Boundary Real 2-D Data + & r_interpolate_var_3d ! Interpolation for generic Real 3-D Data +!#endif + end interface + +! MPAS only routines: + +! stack_files_setup_mpas +! retrieve_stack_data_mpas +! retrieve_ocean_data_mpas + +! r_interpolate_var_1d ? +! r_interpolate_var_1ds +! r_interpolate_var_2d +! i_interpolate_var_2d +! r_interpolate_var_2dx ? +! r_interpolate_var_3d + +! Non MPAS routines: + +! boundary_files_setup +! stack_files_setup +! biogemis_setup +! beis_norm_emis_setup +! depv_data_setup +! medc_file_setup +! soilinp_setup +! retrieve_grid_cro_2d_data +! retrieve_grid_dot_2d_data +! retrieve_ocean_data +! retrieve_ltng_param_data +! retrieve_boundary_data +! retrieve_stack_data + +! r_interpolate_var_1ds +! r_interpolate_var_2d +! i_interpolate_var_2d +! r_interpolate_var_2db +! r_interpolate_var_3d + +! Common routines: + +! gridded_files_setup +! retrieve_time_dep_gridded_data +! retrieve_lufrac_cro_data +! lus_setup +! centralized_io_init +! INIT_EMIS_REGIONS +! DESID_READ_NAMELIST + + contains + +! ------------------------------------------------------------------------- + subroutine gridded_files_setup + + USE UTILIO_DEFN + use HGRD_DEFN, only : ncols, nrows, mype, colsx_pe, rowsx_pe + USE VGRD_DEFN, only : VGTYP_GD, nlays + USE RUNTIME_VARS, only : N_FILE_GR, BIOGEMIS_BEIS, + & STDATE, WB_DUST, ISAM_NEW_START, + & local_tstep, met_tstep, NLDNSTRIKE + use LSM_Mod, only : LAND_SCHEME + use cgrid_spcs, only : n_gc_spcd, n_ae_spc +!#ifdef mpas (Wei Li) +! use centralized_io_util_module, only : ext_layer_info, cal_distribution , +! & binary_search, quicksort, +! & mpas_date_time_to_julian +! use util_module, only : secsdiff, sec2time, index1 +!#endif + + INCLUDE SUBST_FILES_ID ! file name parameters + + Character( 40 ), parameter :: pname = 'gridded_files_setup' + + CHARACTER( 120 ) :: XMSG = ' ' + INTEGER :: GXOFF, GYOFF, stat, n, v, d_size, begin, end, adj, + & n_dust_vars, idx, t, ldate, ltime, + & nl, s, e, c, time, floc + character( 32 ) :: tname, fname + + character( 24 ), allocatable :: c2d_name(:, :), c3d_name(:, :), + & d3d_name(:,:), emis_name(:,:), + & i3d_name(:,:), is3d_name(:,:), + & l2d_name(:,:), medc_name(:,:) + logical :: done = .false. + logical :: found + + integer, allocatable :: bottom(:), top(:) + integer :: emis_file_dist_layer, tdate(2), ttime(2), diffsec + + logical :: layer_exist + +#ifdef mpas +! n_c2d = 0 +! n_c3d = 0 +! n_d3d = 0 +! size_d3dx = 1 +! +! if (binary_search( 'LH', vname_2d, n2d_data) .gt. 0) then +! lh_avail = .true. +! else +! lh_avail = .false. +! end if +! +! n_opened_file = n_opened_file + 1 +! f_met = n_opened_file +! file_tstep(f_met) = mpas_tstep +! +! wspd10_avail = .true. +#else +! met grid cro 2d file + IF ( .NOT. OPEN3( GRID_CRO_2D, FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open '// GRID_CRO_2D // ' file' + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + IF ( .NOT. DESC3( GRID_CRO_2D ) ) THEN + XMSG = 'Could not get ' // GRID_CRO_2D //' file description' + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + n_grid_cro_data_vars = nvars3d + + LAND_SCHEME = 'UNKNOWN' + + v = 0 + DO WHILE ((v .LT. NVARS3D) .and. (.not. done)) + v = v + 1 + IF ( VNAME3D( v ) .EQ. 'DLUSE' ) THEN + IF ( INDEX( VDESC3D( v ), 'USGS24' ) .NE. 0 ) THEN + LAND_SCHEME = 'USGS24' + cio_dust_land_scheme = 'USGS24' + ELSE IF ( INDEX( VDESC3D( v ), 'NLCD40' ) .NE. 0 ) THEN + LAND_SCHEME = 'NLCD40' + cio_dust_land_scheme = 'NLCD40' + ELSE IF ( INDEX( VDESC3D( v ), 'NLCD50' ) .NE. 0 ) THEN + LAND_SCHEME = 'NLCD50' + cio_dust_land_scheme = 'NLCD50' + ELSE IF ( INDEX( VDESC3D( v ), 'NLCD-MODIS' ) .NE. 0 ) THEN + LAND_SCHEME = 'NLCD50' + cio_dust_land_scheme = 'NLCD-MODIS' + ELSE IF ( INDEX( VDESC3D( v ), 'MODIS' ) .NE. 0 ) THEN + LAND_SCHEME = 'MODIS' + IF ( INDEX( VDESC3D( v ), 'MODIS NOAH' ) .ne. 0) THEN + cio_dust_land_scheme = 'MODIS_NOAH' + ELSE + cio_dust_land_scheme = 'MODIS' + END IF + END IF + done = .true. + END IF + END DO + + IF ( .NOT. OPEN3( GRID_DOT_2D, FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open '// GRID_DOT_2D // ' file' + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + +! lufrac cro file + IF ( .NOT. OPEN3( LUFRAC_CRO, FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open '// LUFRAC_CRO // ' file' + CALL M3WARN ( PNAME, 0, 0, XMSG ) + LUCRO_AVAIL = .FALSE. + XMSG = 'Solution: Reading Land Use Fractions from GRID_CRO_2D file' + WRITE(LOGDEV,'(5X,A)')TRIM( XMSG ) + ELSE + n_opened_file = n_opened_file + 1 + LUCRO_AVAIL = .TRUE. + IF ( .NOT. DESC3( LUFRAC_CRO ) ) THEN + XMSG = 'Could not get ' // LUFRAC_CRO //' file description' + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + END IF + +! met cro 2d file + IF ( .NOT. OPEN3( MET_CRO_2D, FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open '// MET_CRO_2D // ' file' + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + n_opened_file = n_opened_file + 1 + f_met = n_opened_file + IF ( .NOT. DESC3( MET_CRO_2D ) ) THEN + XMSG = 'Could not get ' // MET_CRO_2D //' file description' + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + file_sdate(f_met) = sdate3d + file_stime(f_met) = stime3d +#ifdef twoway + file_tstep(f_met) = tstep3d +#else + file_tstep(f_met) = met_tstep ! offline model controlled by runtime var MET_TSTEP +#endif + file_xcell(f_met) = xcell3d + file_ycell(f_met) = ycell3d + + IF (INDEX1( 'TSEASFC', NVARS3D, VNAME3D ) .gt. 0) then + TSEASFC_AVAIL = .true. + adj = 0 + else + TSEASFC_AVAIL = .false. + adj = 1 + end if + + HAS_SEAICE = (INDEX1( 'SEAICE', NVARS3D, VNAME3D ) .gt. 0) + +! include an additional variable TSEASFC when MET_CRO_2D does not have it and CMAQ code is looking for it + n_c2d = nvars3d + adj + allocate (c2d_name(n_c2d, 3), stat=stat) + if (stat .ne. 0) then + xmsg = 'Failure allocating c2d_name ' + call m3exit (pname, 0, 0, xmsg, xstat1 ) + end if + +! only met data has 'm' distinction and since twoway model does not provide +! boundary data, so this distinction only apply to non boundary met data + + c2d_name(1:nvars3d,1) = vname3d(1:nvars3d) + c2d_name(:,2) = 'mc2' ! denote 2d variable + c2d_name(:,3) = 'm' ! denote met variable + if (adj .eq. 1) then + c2d_name(n_c2d,1) = 'TSEASFC' + end if + + WSPD10_AVAIL = (INDEX1( 'WSPD10', NVARS3D, VNAME3D ) .gt. 0) + RNA_AVAIL = (INDEX1( 'RNA', NVARS3D, VNAME3D ) .gt. 0) + RCA_AVAIL = (INDEX1( 'RCA', NVARS3D, VNAME3D ) .gt. 0) + RA_RS_AVAIL = (INDEX1( 'RA', NVARS3D, VNAME3D ) .gt. 0) + WR_AVAIL = (INDEX1( 'WR', NVARS3D, VNAME3D ) .gt. 0) + Q2_AVAIL = (INDEX1( 'Q2', NVARS3D, VNAME3D ) .gt. 0) + LH_AVAIL = (INDEX1( 'LH', NVARS3D, VNAME3D ) .gt. 0) + PXSOIL_AVAIL = (INDEX1( 'CLAY_PX', NVARS3D, VNAME3D ) .gt. 0) + + CALL SUBHFILE ( MET_CRO_2D, GXOFF, GYOFF, + & STRTCOLMC2, ENDCOLMC2, STRTROWMC2, ENDROWMC2 ) + +#ifdef twoway + STRTCOLMC2x = STRTCOLMC2 + STRTROWMC2x = STRTROWMC2 + ENDCOLMC2x = ENDCOLMC2 + ENDROWMC2x = ENDROWMC2 +#else + STRTCOLMC2x = STRTCOLMC2 + STRTROWMC2x = STRTROWMC2 + if (north_pe .and. east_pe) then + ENDCOLMC2x = ENDCOLMC2 + ENDROWMC2x = ENDROWMC2 + else if (north_pe) then + ENDCOLMC2x = ENDCOLMC2 + 1 + ENDROWMC2x = ENDROWMC2 + else if (east_pe) then + ENDCOLMC2x = ENDCOLMC2 + ENDROWMC2x = ENDROWMC2 + 1 + else + ENDROWMC2x = ENDROWMC2 + 1 + ENDCOLMC2x = ENDCOLMC2 + 1 + end if +#endif + +! met cro 3d file + IF ( .NOT. OPEN3( MET_CRO_3D, FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open '// MET_CRO_3D // ' file' + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + IF ( .NOT. DESC3( MET_CRO_3D ) ) THEN + XMSG = 'Could not get ' // MET_CRO_3D //' file description' + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + n_c3d = nvars3d + allocate (c3d_name(n_c3d, 3), stat=stat) + if (stat .ne. 0) then + xmsg = 'Failure allocating c3d_name ' + call m3exit (pname, 0, 0, xmsg, xstat1 ) + end if + c3d_name(:,1) = vname3d(1:n_c3d) + c3d_name(:,2) = 'mc3' ! denote 3d variable + c3d_name(:,3) = 'm' ! denote met variable + + CFRAC_3D_AVAIL = (INDEX1( 'CFRAC_3D', NVARS3D, VNAME3D ) .gt. 0) + PV_AVAIL = (INDEX1( 'PV', NVARS3D, VNAME3D ) .gt. 0) + QI_AVAIL = (INDEX1( 'QI', NVARS3D, VNAME3D ) .gt. 0) + QS_AVAIL = (INDEX1( 'QS', NVARS3D, VNAME3D ) .gt. 0) + QG_AVAIL = (INDEX1( 'QG', NVARS3D, VNAME3D ) .gt. 0) + JACOBF_AVAIL = (INDEX1( 'JACOBF', NVARS3D, VNAME3D ) .gt. 0) + QC_AVAIL = .true. + + CALL SUBHFILE ( MET_CRO_3D, GXOFF, GYOFF, + & STRTCOLMC3, ENDCOLMC3, STRTROWMC3, ENDROWMC3 ) + + IF ( (ENDCOLMC3 - STRTCOLMC3 + 1) .NE. NCOLS .OR. + & (ENDROWMC3 - STRTROWMC3 + 1) .NE. NROWS ) THEN + WRITE( XMSG,'( A, 4I8 )' ) 'Local Columns or Rows incorrect', + & (ENDCOLMC3 - STRTCOLMC3 + 1), NCOLS, (ENDROWMC3 - STRTROWMC3 + 1), NROWS + CALL M3EXIT ( PNAME, cio_model_sdate, cio_model_stime, XMSG, XSTAT1 ) + END IF + +#ifdef twoway + window = .TRUE. + + STRTCOLMC3 = STRTCOLMC3 - 1 + ENDCOLMC3 = ENDCOLMC3 + 1 + STRTROWMC3 = STRTROWMC3 - 1 + ENDROWMC3 = ENDROWMC3 + 1 + w_cro_ncols = ENDCOLMC3 - STRTCOLMC3 + 1 + w_cro_nrows = ENDROWMC3 - STRTROWMC3 + 1 + +#else + IF ( GXOFF .NE. 0 .AND. GYOFF .NE. 0 ) THEN + window = .TRUE. ! windowing from file + STRTCOLMC3 = STRTCOLMC3 - 1 + ENDCOLMC3 = ENDCOLMC3 + 1 + STRTROWMC3 = STRTROWMC3 - 1 + ENDROWMC3 = ENDROWMC3 + 1 + w_cro_ncols = ENDCOLMC3 - STRTCOLMC3 + 1 + w_cro_nrows = ENDROWMC3 - STRTROWMC3 + 1 + ELSE + window = .FALSE. + w_cro_ncols = -1 + w_cro_nrows = -1 + if (.not. east_pe) then + ENDCOLMC3 = ENDCOLMC3 + 1 + end if + if (.not. north_pe) then + ENDROWMC3 = ENDROWMC3 + 1 + end if + END IF +#endif + + V = INDEX1( 'PRES', NVARS3D, VNAME3D ) + If ( V .eq. 0 ) Then + XMSG = 'Could not get variable PRES from ' // MET_CRO_3D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + End If + + Select Case (UNITS3D( V )) + Case ( 'PASCAL','pascal','Pascal','PA','pa','Pa' ) + CONVPA = 1.0 + P0 = 100000.0 + Case ( 'MILLIBAR','millibar','Millibar','MB','mb','Mb' ) + CONVPA = 1.0E-02 + P0 = 100000.0 * CONVPA + Case ( 'CENTIBAR','centibar','Centibar','CB','cb','Cb' ) + CONVPA = 1.0E-03 + P0 = 100000.0 * CONVPA + Case Default + XMSG = 'PRES units incorrect on ' // MET_CRO_3D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + End Select + +! met dot 3d file + IF ( .NOT. OPEN3( MET_DOT_3D, FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open '// MET_DOT_3D // ' file' + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + IF ( .NOT. DESC3( MET_DOT_3D ) ) THEN + XMSG = 'Could not get description of file '// MET_DOT_3D + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + n_d3d = nvars3d + allocate (d3d_name(n_d3d, 3), stat=stat) + if (stat .ne. 0) then + xmsg = 'Failure allocating d3d_name ' + call m3exit (pname, 0, 0, xmsg, xstat1 ) + end if + d3d_name(:,1) = vname3d(1:n_d3d) + d3d_name(:,2) = 'md3' ! denote dot variable + d3d_name(:,3) = 'm' ! denote met variable + + CALL SUBHFILE ( MET_DOT_3D, GXOFF, GYOFF, + & STRTCOLMD3, ENDCOLMD3, STRTROWMD3, ENDROWMD3 ) + +#ifdef twoway + STRTCOLMD3x = STRTCOLMD3 + STRTROWMD3x = STRTROWMD3 + ENDROWMD3x = ENDROWMD3 + ENDCOLMD3x = ENDCOLMD3 +#else + STRTCOLMD3x = STRTCOLMD3 + STRTROWMD3x = STRTROWMD3 + if (north_pe .and. east_pe) then + ENDCOLMD3x = ENDCOLMD3 + ENDROWMD3x = ENDROWMD3 + else if (north_pe) then + ENDCOLMD3x = ENDCOLMD3 + 1 + ENDROWMD3x = ENDROWMD3 + else if (east_pe) then + ENDCOLMD3x = ENDCOLMD3 + ENDROWMD3x = ENDROWMD3 + 1 + else + ENDROWMD3x = ENDROWMD3 + 1 + ENDCOLMD3x = ENDCOLMD3 + 1 + end if +#endif + + dot_ncols = ENDCOLMD3 - STRTCOLMD3 + 1 + dot_nrows = ENDROWMD3 - STRTROWMD3 + 1 + size_d3d = dot_ncols * dot_nrows * nlays + + x_dot_ncols = ENDCOLMD3x - STRTCOLMD3x + 1 + x_dot_nrows = ENDROWMD3x - STRTROWMD3x + 1 + size_d2dx = x_dot_ncols * x_dot_nrows + size_d3dx = size_d2dx * nlays + + UWINDC_AVAIL = (INDEX1( 'UWINDC', NVARS3D, VNAME3D ) .gt. 0) + VWINDC_AVAIL = (INDEX1( 'VWINDC', NVARS3D, VNAME3D ) .gt. 0) +#endif + +! emission file, could be one or multiple layer + + call desid_read_namelist() + call desid_init_regions() + + allocate (cio_emis_file_name(N_FILE_GR), + & cio_emis_file_loc(N_FILE_GR), + & cio_emis_nvars(N_FILE_GR), + & f_emis(N_FILE_GR), +#ifndef mpas +! & cio_emis_file_startcol(N_FILE_GR), +! & cio_emis_file_endcol(N_FILE_GR), +! & cio_emis_file_startrow(N_FILE_GR), +! & cio_emis_file_endrow(N_FILE_GR), +#endif + & stat=stat) + +#ifdef mpas +! allocate (num_dist_layers(ncols, n_file_gr), +! & dist_frac(nlays, ncols, n_file_gr), +! & bottom(nlays), +! & top(nlays), +! & emis_file_layer_frac(nlays, n_file_gr), +! & stat=stat) + +#endif + + n_e2d = 0 + n_e3d = 0 + do n = 1, N_FILE_GR + + n_opened_file = n_opened_file + 1 + f_emis(n) = n_opened_file + +! Check whether file is a representative day type + file_sym_date(f_emis(n)) = emis_sym_date ! Master switch to change default + write (fname, '(a15, i3.3)') "GR_EM_SYM_DATE_", n + call get_env(file_sym_date(f_emis(n)), fname, + & file_sym_date(f_emis(n)), logdev ) + + write (fname, '(a8, i3.3)') "GR_EMIS_", n + cio_emis_file_name(n) = fname + +#ifdef mpas +! floc = search_fname (cio_emis_file_name(n)) +! cio_emis_file_loc(n) = floc +! +! call mpas_date_time_to_julian (mio_file_data(floc)%timestamp(1), tdate(1), ttime(1)) +! call mpas_date_time_to_julian (mio_file_data(floc)%timestamp(2), tdate(2), ttime(2)) +! +! file_sdate(f_emis(n)) = tdate(1) +! file_stime(f_emis(n)) = ttime(1) +! +! diffsec = secsdiff (tdate(1), ttime(1), tdate(2), ttime(2)) +! +! file_tstep(f_emis(n)) = sec2time(diffsec) +! mio_file_data(floc)%tstep = file_tstep(f_emis(n)) +! +! layer_exist = .false. +! do v = 1, mio_file_data(floc)%n_global_atts +! if (mio_file_data(floc)%glo_att_name(v) .eq. 'layers') then +! layer_exist = .true. +! s = mio_file_data(floc)%glo_catt_range(2*v-1) +! e = mio_file_data(floc)%glo_catt_range(2*v) +! call ext_layer_info (mio_file_data(floc)%glo_att_cval(s:e), +! & emis_file_dist_layer, bottom, top, +! & emis_file_layer_frac(:,n)) +! end if +! end do +! +! if (layer_exist) then +! do c = 1, ncols +! call cal_distribution (bottom, top, g3ddata(c,1,:,zh_ind), +! & emis_file_layer_frac(:,n), +! & emis_file_dist_layer, +! & num_dist_layers(c,n), +! & dist_frac(:,c,n)) +! end do +! else +! num_dist_layers(:,n) = 1 +! dist_frac(:,:,n) = 1.0 +! end if +! +! cio_emis_nvars(n) = mio_file_data(floc)%nvars +! if (mio_file_data(floc)%nlays .eq. 1) then +! n_e2d = n_e2d + cio_emis_nvars(n) +! else +! n_e3d = n_e3d + cio_emis_nvars(n) +! end if +! +! call mpas_date_time_to_julian (mio_file_data(floc)%timestamp(1), file_sdate(f_emis(n)), time) +#else + IF ( .NOT. OPEN3( fname, FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open '// fname // ' file' + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + IF ( .NOT. DESC3( fname ) ) THEN + XMSG = 'Could not get description of file '// fname + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + call subhfile ( cio_emis_file_name(n), gxoff, gyoff, + & cio_emis_file_startcol(n), cio_emis_file_endcol(n), + & cio_emis_file_startrow(n), cio_emis_file_endrow(n) ) + + file_sdate(f_emis(n)) = sdate3d + file_stime(f_emis(n)) = stime3d + file_tstep(f_emis(n)) = tstep3d + file_xcell(f_emis(n)) = xcell3d + file_ycell(f_emis(n)) = ycell3d + + found = .false. + ldate = sdate3d + ltime = stime3d + if (ldate == stdate) then + found = .true. + else + t = 1 + do while ((t < mxrec3d) .and. (.not. found)) + call nextime (ldate, ltime, tstep3d) + if (ldate == stdate) then + found = .true. + end if + t = t + 1 + end do + end if + + cio_emis_nvars(n) = nvars3d + if (nlays3d .eq. 1) then + n_e2d = n_e2d + cio_emis_nvars(n) + else + n_e3d = n_e3d + cio_emis_nvars(n) + end if + +#endif + end do + +#ifdef mpas +! deallocate (bottom, top) +! +! n_dust_vars = 0 +#else + +! Wind blown dust data + n_dust_vars = 0 +#endif + + n_e2d = n_e2d + n_dust_vars + + allocate (emis_name(n_e2d+n_e3d, 3), stat=stat) + if (stat .ne. 0) then + xmsg = 'Failure allocating emis_name ' + call m3exit (pname, 0, 0, xmsg, xstat1 ) + end if + +#ifndef mpas +! setup initial condition file +! n_i3d = 0 +! IF ( .NOT. OPEN3( ICFILE, FSREAD3, PNAME ) ) THEN +! XMSG = 'Open failure for ' // ICFILE +! Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) +! END IF +! n_opened_file = n_opened_file + 1 +! f_icon = n_opened_file +! IF ( .NOT. DESC3( ICFILE ) ) THEN +! XMSG = 'Could not get description of file '// ICFILE +! CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) +! END IF +! call subhfile ( ICFILE, gxoff, gyoff, +! & STRTCOLIC, ENDCOLIC, STRTROWIC, ENDROWIC ) +! +!! remove duplicate name from MET_CRO_3D file +! adj = nvars3d +! do v = nvars3d, 1, -1 +! n = index1 (vname3d(v), n_c3d, c3d_name) +! if (n .gt. 0) then +! do idx = v+1, adj +! vname3d(idx-1) = vname3d(idx) +! end do +! adj = adj - 1 +! end if +! end do +! n_i3d = adj +! +! allocate (i3d_name(n_i3d, 3), stat=stat) +! if (stat .ne. 0) then +! xmsg = 'Failure allocating i3d_name ' +! call m3exit (pname, 0, 0, xmsg, xstat1 ) +! end if +! i3d_name(:,1) = vname3d(1:n_i3d) +! i3d_name(:,2) = 'ic' ! denote initial condition variable +! i3d_name(:,3) = ' ' ! denote non met variable +! +!! setup initial condition file for ISAM +! n_is3d = 0 +! +! if (ISAM_NEW_START == 'N') then +! IF ( .NOT. OPEN3( ISAM_PREVDAY, FSREAD3, PNAME ) ) THEN +! XMSG = 'Open failure for ' // ISAM_PREVDAY +! Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) +! END IF +! n_opened_file = n_opened_file + 1 +! f_is_icon = n_opened_file +! IF ( .NOT. DESC3( ISAM_PREVDAY ) ) THEN +! XMSG = 'Could not get description of file '// ISAM_PREVDAY +! CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) +! END IF +! call subhfile ( ISAM_PREVDAY, gxoff, gyoff, +! & STRTCOLISIC, ENDCOLISIC, STRTROWISIC, ENDROWISIC ) +! +! n_is3d = nvars3d +! allocate (is3d_name(n_is3d, 3), stat=stat) +! if (stat .ne. 0) then +! xmsg = 'Failure allocating i3d_name ' +! call m3exit (pname, 0, 0, xmsg, xstat1 ) +! end if +! is3d_name(:,1) = vname3d(1:n_is3d) +! is3d_name(:,2) = 'is' ! denote ISAM initial condition variable +! is3d_name(:,3) = ' ' ! denote non met variable +! +! file_sdate(f_is_icon) = sdate3d +! file_stime(f_is_icon) = stime3d +! file_tstep(f_is_icon) = tstep3d +! file_xcell(f_is_icon) = xcell3d +! file_ycell(f_is_icon) = ycell3d +! +! end if ! ISAM_NEW_START +#endif + +! setup gridded emission file + end = 0 + allocate (cio_emis_file_layer(N_FILE_GR), stat=stat) + do n = 1, N_FILE_GR + WRITE (fname, '(a8, i3.3)') "GR_EMIS_", n +#ifdef mpas +! floc = cio_emis_file_loc(n) +! nl = mio_file_data(floc)%nlays +#else + IF ( .NOT. DESC3( fname ) ) THEN + XMSG = 'Could not get description of file '// fname + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + nl = nlays3d +#endif + + begin = end + 1 + + write (tname, '(a1, i3.3)') '_', n +#ifdef mpas +! do v = 1, mio_file_data(floc)%nvars +! end = end + 1 +! emis_name(end,1) = trim(mio_file_data(floc)%var_name(v)) // tname +! end do + +#else + do v = 1, nvars3d + end = end + 1 + emis_name(end,1) = trim(vname3d(v)) // tname + end do +#endif + + if (nl .eq. 1) then + emis_name(begin:end, 2) = 'e2d' ! e denote emission 2d variable + else + emis_name(begin:end, 2) = 'e3d' ! E denote emission 3d variable + end if + emis_name(begin:end, 3) = ' ' ! denote non met variable + cio_emis_file_layer(n) = nl + end do + + cio_emis_nlays = maxval(cio_emis_file_layer) + ! If there are 3D (inline point or Lightning) sources, + ! revise the top to be the model top. + IF ( NPTGRPS .GT. 0 .OR. LTNG_NO ) cio_emis_nlays = NLAYS + + ! Make sure the top is not greater than the model top + cio_emis_nlays = MAX( MIN( cio_emis_nlays, NLAYS ), 1 ) + + WRITE( LOGDEV,1009 ) cio_emis_nlays, NLAYS + 1009 FORMAT( 5X, 'Number of Emissions Layers: ', I3 + & / 5X, 'out of total Number of Model Layers:', I3 ) + +! lightning file + n_l2d = 0 +#ifndef mpas +! if (NLDNSTRIKE) then +! IF ( .NOT. OPEN3( NLDN_STRIKES, FSREAD3, PNAME ) ) THEN +! XMSG = 'Open failure for ' // NLDN_STRIKES +! Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) +! END IF +! n_opened_file = n_opened_file + 1 +! f_ltng = n_opened_file +! IF ( .NOT. DESC3( NLDN_STRIKES ) ) THEN +! XMSG = 'Could not get description of file '// NLDN_STRIKES +! CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) +! END IF +! call subhfile ( NLDN_STRIKES, gxoff, gyoff, +! & STRTCOLLNT, ENDCOLLNT, STRTROWLNT, ENDROWLNT) +! +! file_sdate(f_ltng) = sdate3d +! file_stime(f_ltng) = stime3d +! file_tstep(f_ltng) = tstep3d +! file_xcell(f_ltng) = xcell3d +! file_ycell(f_ltng) = ycell3d +! +! n_l2d = nvars3d +! cio_LTLYRS = nlays3d +! allocate (l2d_name(n_l2d, 3), stat=stat) +! if (stat .ne. 0) then +! xmsg = 'Failure allocating l2d_name ' +! call m3exit (pname, 0, 0, xmsg, xstat1 ) +! end if +! l2d_name(:,1) = vname3d(1:n_l2d) +! l2d_name(:,2) = 'lnt' ! denote lightning variable +! l2d_name(:,3) = ' ' ! denote non met variable +! ! Check to see what the lightning variable name is called +! ! backwards (NLDNstrk) & forwards compatible (LNT) +! if ( index1('NLDNstrk', n_l2d ,l2d_name(:,1)) .gt. 0 ) then +! lt_name = 'NLDNstrk' +! else +! lt_name = 'LNT' +! end if +! +! end if +#endif + +! combining all files + n_cio_grid_vars = n_c2d + n_c3d + n_d3d + n_e2d + n_e3d + n_l2d + n_i3d + n_is3d + +#ifdef mpas +! cro_ncols = ncols +! cro_nrows = 1 +! size_c2dx = 1 + +!! for standard domain +! s_cro_ncols = ncols +! s_cro_nrows = 1 +#else + cro_ncols = ENDCOLMC2 - STRTCOLMC2 + 1 + cro_nrows = ENDROWMC2 - STRTROWMC2 + 1 + +! for standard domain + STRTCOLSTD = COLSX_PE( 1, MYPE+1 ) + ENDCOLSTD = COLSX_PE( 2, MYPE+1 ) + STRTROWSTD = ROWSX_PE( 1, MYPE+1 ) + ENDROWSTD = ROWSX_PE( 2, MYPE+1 ) + + s_cro_ncols = ENDCOLSTD - STRTCOLSTD + 1 + s_cro_nrows = ENDROWSTD - STRTROWSTD + 1 +#endif + size_c2d = cro_ncols * cro_nrows + + size_s2d = s_cro_ncols * s_cro_nrows + + if ((cro_ncols .ne. ncols) .or. (cro_nrows .ne. nrows)) then + call m3exit( 'Centralized I/O',0,0,' ==d== NO ncols nrows ',1 ) + end if + + x_cro_ncols = ENDCOLMC2x - STRTCOLMC2x + 1 + x_cro_nrows = ENDROWMC2x - STRTROWMC2x + 1 + size_c2dx = x_cro_ncols * x_cro_nrows + + size_d2d = dot_ncols * dot_nrows + + if (window) then + + size_c3d = w_cro_ncols * w_cro_nrows * nlays + else + size_c3d = size_c2dx * nlays + end if + + size_e3d = size_s2d * cio_emis_nlays + size_s3d = size_s2d * nlays + + size_lt = size_s2d * cio_LTLYRS + + allocate (cio_grid_var_name(n_cio_grid_vars, 3), + & cio_grid_data_inx(2, 0:2, n_cio_grid_vars), + & head_grid(n_cio_grid_vars), + & tail_grid(n_cio_grid_vars), + & cio_grid_data_tstamp(2, 0:2, n_cio_grid_vars), + & cio_grid_data( size_c2dx * 3 * n_c2d ! 2d met data + & + size_c2d * 3 * n_e2d ! 2d emis data + & + size_c3d * 3 * n_c3d ! 3D met data + & + size_e3d * 3 * n_e3d ! 3d emis data + & + size_s3d * 3 * n_i3d ! 3d initial condition data + & + size_s3d * 3 * n_is3d ! 3d ISAM initial condition data + & + size_d3dx * 3 * n_d3d ! 3d dot data + & + size_lt * 3 * n_l2d), ! lightning data + & stat = stat) + if (stat .ne. 0) then + xmsg = 'Failure allocating cio_grid_var_name and associated arrays ' + call m3exit (pname, 0, 0, xmsg, xstat1 ) + end if + cio_grid_data = 0.0 + +#ifdef mpas +! end = 0 +! allocate (cio_mpas_grid_data_tstamp(0:2, n_cio_grid_vars), +! & stat = stat) + +#else + begin = 1 + end = n_c2d + cio_grid_var_name(begin:end, :) = c2d_name + + begin = end + 1 + end = end + n_c3d + cio_grid_var_name(begin:end, :) = c3d_name + + begin = end + 1 + end = end + n_d3d + cio_grid_var_name(begin:end, :) = d3d_name +#endif + + begin = end + 1 + end = end + n_e2d + n_e3d + cio_grid_var_name(begin:end, :) = emis_name + +#ifndef mpas +! begin = end + 1 +! end = end + n_i3d +! cio_grid_var_name(begin:end, :) = i3d_name +! +! if (ISAM_NEW_START == 'N') then +! begin = end + 1 +! end = end + n_is3d +! cio_grid_var_name(begin:end, :) = is3d_name +! end if +! +! if (NLDNSTRIKE) then +! begin = end + 1 +! end = end + n_l2d +! cio_grid_var_name(begin:end, :) = l2d_name +! deallocate (l2d_name) +! end if +! +! deallocate (c2d_name, c3d_name, i3d_name) +! if (ISAM_NEW_START == 'N') then +! deallocate (is3d_name) +! end if +! if (.not. window) then +! deallocate (d3d_name) +! end if +#endif + deallocate (emis_name) + + call quicksort(cio_grid_var_name, 1, n_cio_grid_vars) + + begin = 1 + do v = 1, n_cio_grid_vars + +! locate certain species + if (cio_grid_var_name(v,1) .eq. 'TEMPG') then + tempg_loc = v + else if (cio_grid_var_name(v,1) .eq. 'TSEASFC') then + tseasfc_loc = v + end if + + if (cio_grid_var_name(v,2) .eq. 'mc2') then + d_size = size_c2dx + else if (cio_grid_var_name(v,2) .eq. 'e2d') then + d_size = size_s2d + else if (cio_grid_var_name(v,2) .eq. 'mc3') then + d_size = size_c3d + else if (cio_grid_var_name(v,2) .eq. 'e3d') then + d_size = size_e3d + else if ((cio_grid_var_name(v,2) .eq. 'ic') .or. + & (cio_grid_var_name(v,2) .eq. 'is')) then + d_size = size_s3d + else if (cio_grid_var_name(v,2) .eq. 'md3') then + d_size = size_d3dx + else if ((cio_grid_var_name(v,2) .eq. 'lnt') .or. + & (cio_grid_var_name(v,2) .eq. 'wb')) then + d_size = size_s2d + else + call m3exit( 'Centralized I/O',0,0,' ==d== UNKOWN',1 ) + end if + + do n = 0, 2 + cio_grid_data_inx(1, n, v) = begin + end = begin + d_size - 1 + cio_grid_data_inx(2, n, v) = end + begin = end + 1 + end do +! this is for checking purposes +! write (logdev, '(a12, i5, 1x, a16, 2a4, 10i10)') ' ==d== file ', v, +! & cio_grid_var_name(v,:), cio_grid_data_inx(:,:,v) + end do + + end subroutine gridded_files_setup + +! ------------------------------------------------------------------------- + subroutine retrieve_time_dep_gridded_data (jdate, jtime, vname) + + USE UTILIO_DEFN + USE HGRD_DEFN + USE VGRD_DEFN, ONLY : NLAYS + USE CGRID_SPCS + use get_env_module +#ifdef mpas !(Wei Li) +! use mio_module +! use util_module, only : nextime +! use mio_util_func_module, only : mpas_nextime +! use coupler_module, only : cell_area +! use centralized_io_util_module, only : julian_to_mpas_date_time, binary_search +#else + use centralized_io_util_module, only : binary_search +#endif + + INCLUDE SUBST_FILES_ID ! file name parameters + + integer, intent(in) :: jdate, jtime + character (*), intent(in), optional :: vname + + Character( 40 ), parameter :: pname = 'retrieve_time_dep_gridded_data' + + LOGICAL, SAVE :: firstime = .true. + INTEGER :: STAT, i, j, k, begin, end, buf_loc, iterations, iter, + & loc_jdate_met, loc_emis_jdate, + & loc_jtime_met, data_jdate, data_jtime, t_time, + & bs_tjdate, wb_tjdate, v, beg_v, end_v, fnum, str_len, + & bs_tjtime, wb_tjtime, wb_pre_begin, wb_pre_end, + & t_beg, t_end, floc + integer, allocatable :: tdata(:), loc_jdate(:), loc_jtime(:) + character (16) :: loc_vname + character (20) :: fname + logical :: advanced + character (20), allocatable, save :: mpas_loc_time_stamp(:) + + CHARACTER( 120 ) :: XMSG = ' ' + +#ifdef mpas +! real, save, allocatable :: mpas_tdata(:,:), temp_data_1d(:), temp_data_2d(:,:) +! character (20) :: loc_mpas_time_stamp ! this is for mpas only +! character (20), save :: mpas_time_stamp ! this is for mpas only +! integer, save :: pre_jdate, pre_jtime ! this is fore mpas only +! character( 40 ), save :: exception1, exception2 +#endif + + allocate (loc_jdate(n_opened_file), loc_jtime(n_opened_file), STAT=STAT) + + if (firstime) then + +#ifdef mpas +! allocate (mpas_loc_time_stamp(n_opened_file), STAT=STAT) +! +! do k = 1, N_FILE_GR +! write (fname, '(a8, i3.3)') "GR_EMIS_", k +! i = search_fname (fname) +! mpas_loc_time_stamp(f_emis(k)) = mio_file_data(i)%timestamp(1) +! end do +! +! pre_jdate = -1 +! pre_jtime = -1 +! +! call get_env (exception1, 'exception1', ' ') +! call get_env (exception2, 'exception2', ' ') + +#else + allocate (SOILCAT_A(ncols, nrows), STAT=STAT) + + IF ( STAT .NE. 0 ) THEN + XMSG = 'Failure allocating SLTYP array' + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT3 ) + END IF +#ifdef twoway + If ( .Not. INTERPX( MET_CRO_2D, 'SLTYP', PNAME, + & STRTCOLMC2, ENDCOLMC2,STRTROWMC2, ENDROWMC2, 1, 1, + & jdate, jtime, SOILCAT_A ) ) THEN + XMSG = ' Error interpolating variable SLTYP from ' // MET_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF +#else + If ( .Not. XTRACT3( MET_CRO_2D, 'SLTYP', + & 1, 1, STRTROWMC2, ENDROWMC2, STRTCOLMC2, ENDCOLMC2, + & jdate, jtime, SOILCAT_A ) ) THEN + XMSG = ' Error interpolating variable SLTYP from ' // MET_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF +#endif + +#endif + head_grid = -1 + tail_grid = -1 + + iterations = 2 + else + iterations = 1 + end if ! firstime + + if (present(vname)) then + beg_v = binary_search (vname, cio_grid_var_name(:,1), n_cio_grid_vars) + end_v = beg_v + else + beg_v = 1 + end_v = n_cio_grid_vars + end if + + loc_jdate = jdate + loc_jtime = jtime + + advanced = .false. + do iter = 1, iterations + do v = beg_v, end_v + buf_loc = mod((tail_grid(v) + iter), 2) + + begin = cio_grid_data_inx(1,buf_loc,v) + end = cio_grid_data_inx(2,buf_loc,v) + + if (cio_grid_var_name(v,2) == 'mc2') then + +#ifndef mpas +! data_jdate = loc_jdate(f_met) +! data_jtime = loc_jtime(f_met) +! +! if ((cio_grid_var_name(v,1) .ne. 'TSEASFC') .or. TSEASFC_AVAIL) then +#ifdef twoway + IF ( .NOT. INTERPX( MET_CRO_2D, cio_grid_var_name(v,1), PNAME, + & STRTCOLMC2x, ENDCOLMC2x, STRTROWMC2x, ENDROWMC2x, 1, 1, + & data_jdate, data_jtime, cio_grid_data(begin:end) ) ) THEN + XMSG = 'Could not extract ' // MET_CRO_2D // ' file' + CALL M3EXIT ( PNAME, data_jdate, data_jtime, XMSG, XSTAT1 ) + END IF +#else + IF ( .NOT. XTRACT3( MET_CRO_2D, cio_grid_var_name(v,1), + & 1, 1, STRTROWMC2x, ENDROWMC2x, STRTCOLMC2x, ENDCOLMC2x, + & data_jdate, data_jtime, cio_grid_data(begin:end) ) ) THEN + XMSG = 'Could not extract ' // MET_CRO_2D // ' file' + CALL M3EXIT ( PNAME, data_jdate, data_jtime, XMSG, XSTAT1 ) + END IF +#endif + END IF + +! deal with convective scheme + if ((cio_grid_var_name(v,1) .eq. 'RC') .or. + & (cio_grid_var_name(v,1) .eq. 'RCA')) then + if (maxval(cio_grid_data(begin:end)) .lt. 0.0) then + convective_scheme = .false. + cio_grid_data(begin:end) = 0.0 + XMSG = 'MCIP files indicate no convective parameterization was ' + & // 'used in the WRF simulation' + CALL M3WARN ( PNAME, JDATE, JTIME, XMSG ) + XMSG = 'Processing will continue without subgrid clouds' + CALL M3MESG ( XMSG ) + else + where (cio_grid_data(begin:end) .lt. 0.0) cio_grid_data(begin:end) = 0.0 + end if + end if + + else if (cio_grid_var_name(v,2) == 'mc3') then + + data_jdate = loc_jdate(f_met) + data_jtime = loc_jtime(f_met) +#ifdef twoway + IF ( .NOT. INTERPX( MET_CRO_3D, cio_grid_var_name(v,1), PNAME, + & STRTCOLMC3, ENDCOLMC3, STRTROWMC3, ENDROWMC3, 1, nlays, + & data_jdate, data_jtime, cio_grid_data(begin:end) ) ) THEN + XMSG = 'Could not extract ' // MET_CRO_3D // ' file' + CALL M3EXIT ( PNAME, data_jdate, data_jtime, XMSG, XSTAT1 ) + END IF +#else + IF ( .NOT. XTRACT3( MET_CRO_3D, cio_grid_var_name(v,1), + & 1, nlays, STRTROWMC3, ENDROWMC3, STRTCOLMC3, ENDCOLMC3, + & data_jdate, data_jtime, cio_grid_data(begin:end) ) ) THEN + XMSG = 'Could not extract ' // MET_CRO_3D // ' file' + CALL M3EXIT ( PNAME, data_jdate, data_jtime, XMSG, XSTAT1 ) + END IF +#endif + else if (cio_grid_var_name(v,2) == 'md3') then + + data_jdate = loc_jdate(f_met) + data_jtime = loc_jtime(f_met) +#ifdef twoway + IF ( .NOT. INTERPX( MET_DOT_3D, cio_grid_var_name(v,1), PNAME, + & STRTCOLMD3x, ENDCOLMD3x, STRTROWMD3x, ENDROWMD3x, 1, nlays, + & data_jdate, data_jtime, cio_grid_data(begin:end) ) ) THEN + XMSG = 'Could not extract ' // MET_DOT_3D // ' file' + CALL M3EXIT ( PNAME, data_jdate, data_jtime, XMSG, XSTAT1 ) + END IF +#else + IF ( .NOT. XTRACT3( MET_DOT_3D, cio_grid_var_name(v,1), + & 1, nlays, STRTROWMD3x, ENDROWMD3x, STRTCOLMD3x, ENDCOLMD3x, + & data_jdate, data_jtime, cio_grid_data(begin:end) ) ) THEN + XMSG = 'Could not extract ' // MET_DOT_3D // ' file' + CALL M3EXIT ( PNAME, data_jdate, data_jtime, XMSG, XSTAT1 ) + END IF +#endif +#endif + else if (cio_grid_var_name(v,2) == 'e2d') then + + str_len = len_trim(cio_grid_var_name(v,1)) + read (cio_grid_var_name(v,1)(str_len-2:str_len), *) fnum + loc_vname = cio_grid_var_name(v,1)(1:str_len-4) + +#ifdef mpas +! floc = cio_emis_file_loc(fnum) +! +! if (.not. allocated(mpas_tdata)) then +! allocate (mpas_tdata(ncols, nlays), +! & temp_data_1d(ncols), +! & stat=stat) +! end if +! +! loc_mpas_time_stamp = mpas_loc_time_stamp(f_emis(fnum)) +! +! call mio_fread (cio_emis_file_name(fnum), +! & loc_vname, +! & mpas_tdata, +! & loc_mpas_time_stamp) +! +!! de-normalized the data +! mpas_tdata = 0.0 +! if ((cio_emis_file_name(fnum) .eq. exception1) .or. +! & (cio_emis_file_name(fnum) .eq. exception2)) then +! do i = 1, ncols +! do k = 1, num_dist_layers(i,fnum) +! mpas_tdata(i,k) = temp_data_1d(i) * dist_frac(k,i,fnum) +! end do +! end do +! else +! do i = 1, ncols +! do k = 1, num_dist_layers(i,fnum) +! mpas_tdata(i,k) = temp_data_1d(i) * dist_frac(k,i,fnum) !* cell_area(i,1) +! end do +! end do +! end if +! +!! do i = 1, ncols +!! mpas_tdata(i,:) = mpas_tdata(i,:) * cell_area(i,1) +!! end do +! +! cio_grid_data(begin:end) = reshape(mpas_tdata, (/ end-begin+1 /)) + +#else + + ! Check if its a representative day on start-up (every other time it will + ! be managed by the emissions processing) + if (firstime) then + if (file_sym_date(f_emis(fnum))) loc_jdate(f_emis(fnum)) = file_sdate(f_emis(fnum)) + end if + data_jdate = loc_jdate(f_emis(fnum)) + data_jtime = loc_jtime(f_emis(fnum)) + + IF ( .NOT. XTRACT3( cio_emis_file_name(fnum), loc_vname, 1, 1, + & cio_emis_file_startrow(fnum), cio_emis_file_endrow(fnum), + & cio_emis_file_startcol(fnum), cio_emis_file_endcol(fnum), + & data_jdate, data_jtime, cio_grid_data(begin:end) ) ) THEN + XMSG = 'Could not extract ' // cio_emis_file_name(fnum) // ' file' + CALL M3EXIT ( PNAME, data_jdate, data_jtime, XMSG, XSTAT1 ) + END IF +#endif + + else if (cio_grid_var_name(v,2) == 'e3d') then + + str_len = len_trim(cio_grid_var_name(v,1)) + read (cio_grid_var_name(v,1)(str_len-2:str_len), *) fnum + loc_vname = cio_grid_var_name(v,1)(1:str_len-4) + +#ifdef mpas +! floc = cio_emis_file_loc(fnum) +! +! if (.not. allocated(mpas_tdata)) then +! allocate (mpas_tdata(ncols, nlays), +! & temp_data_1d(ncols), +! & stat=stat) +! end if +! +! file_tstep(f_emis(fnum)) = mio_file_data(floc)%tstep +! +! ! Check if its a representative day on start-up (every other +! ! time it will be managed by the emissions processing) +! if (firstime) then +! if (file_sym_date(f_emis(fnum))) loc_jdate(f_emis(fnum)) = file_sdate(f_emis(fnum)) +! end if +! data_jdate = loc_jdate(f_emis(fnum)) +! data_jtime = loc_jtime(f_emis(fnum)) +! +! call julian_to_mpas_date_time (data_jdate, data_jtime, loc_mpas_time_stamp) +! +! call mio_fread (cio_emis_file_name(fnum), +! & loc_vname, +! & temp_data_1d, +! & loc_mpas_time_stamp) +! +! cio_mpas_grid_data_tstamp(buf_loc, v) = loc_mpas_time_stamp +! +! call mpas_date_time_to_julian (loc_mpas_time_stamp, data_jdate, data_jtime) +! +!! de-normalized the data +! mpas_tdata = 0.0 +! do i = 1, ncols +! do k = 1, num_dist_layers(i,fnum) +! mpas_tdata(i,k) = temp_data_1d(i) * dist_frac(k,i,fnum) +! end do +! end do +! +! t_beg = begin +! t_end = begin + ncols - 1 +! do k = 1, nlays +! cio_grid_data(t_beg:t_end) = mpas_tdata(:,k) +! t_beg = t_end + 1 +! t_end = t_end + ncols +! end do + +#else + ! Check if its a representative day on start-up (every other time it will + ! be managed by the emissions processing) + if (firstime) then + if (file_sym_date(f_emis(fnum))) loc_jdate(f_emis(fnum)) = file_sdate(f_emis(fnum)) + end if + data_jdate = loc_jdate(f_emis(fnum)) + data_jtime = loc_jtime(f_emis(fnum)) + + IF ( .NOT. XTRACT3( cio_emis_file_name(fnum), loc_vname, + & 1, cio_emis_file_layer(fnum), + & cio_emis_file_startrow(fnum), cio_emis_file_endrow(fnum), + & cio_emis_file_startcol(fnum), cio_emis_file_endcol(fnum), + & data_jdate, data_jtime, cio_grid_data(begin:end) ) ) THEN + XMSG = 'Could not extract ' // cio_emis_file_name(fnum) // ' file' + CALL M3EXIT ( PNAME, data_jdate, data_jtime, XMSG, XSTAT1 ) + END IF + +#endif + + else if (cio_grid_var_name(v,2) == 'ic') then + +#ifndef mpas +! data_jdate = loc_jdate(f_icon) +! data_jtime = loc_jtime(f_icon) +! +! if (iter == 1) then +! +! IF ( .NOT. XTRACT3( ICFILE, cio_grid_var_name(v,1), +! & 1, nlays, STRTROWIC, ENDROWIC, STRTCOLIC, ENDCOLIC, +! & data_jdate, data_jtime, cio_grid_data(begin:end) ) ) THEN +! XMSG = 'Could not extract ' // ICFILE // ' file' +! CALL M3EXIT ( PNAME, data_jdate, data_jtime, XMSG, XSTAT1 ) +! END IF +! end if +#endif + + else if (cio_grid_var_name(v,2) == 'is') then + +#ifndef mpas +! data_jdate = loc_jdate(f_is_icon) +! data_jtime = loc_jtime(f_is_icon) +! +! if ((iter == 1) .and. (ISAM_NEW_START == 'N')) then +! +! IF ( .NOT. XTRACT3( ISAM_PREVDAY, cio_grid_var_name(v,1), +! & 1, nlays, STRTROWISIC, ENDROWISIC, STRTCOLISIC, ENDCOLISIC, +! & data_jdate, data_jtime, cio_grid_data(begin:end) ) ) THEN +! XMSG = 'Could not extract ' // ISAM_PREVDAY // ' file' +! CALL M3EXIT ( PNAME, data_jdate, data_jtime, XMSG, XSTAT1 ) +! END IF +! end if +#endif + + else if (cio_grid_var_name(v,2) == 'lnt') then + +#ifndef mpas +! data_jdate = loc_jdate(f_ltng) +! data_jtime = loc_jtime(f_ltng) +! +! IF ( .NOT. XTRACT3( NLDN_STRIKES, cio_grid_var_name(v,1), +! & 1, cio_LTLYRS, STRTROWLNT, ENDROWLNT, STRTCOLLNT, ENDCOLLNT, +! & data_jdate, data_jtime, cio_grid_data(begin:end) ) ) THEN +! XMSG = 'Could not extract ' // NLDN_STRIKES // ' file' +! CALL M3EXIT ( PNAME, data_jdate, data_jtime, XMSG, XSTAT1 ) +! END IF +#endif + end if + + cio_grid_data_tstamp(1, buf_loc, v) = data_jdate + cio_grid_data_tstamp(2, buf_loc, v) = data_jtime + + end do + +#ifndef mpas +!! assign TEMPG to TSEASFC when TSEASFC is not available in the input file +! if (.not. TSEASFC_AVAIL) then +! begin = cio_grid_data_inx(1,buf_loc,tempg_loc) +! end = cio_grid_data_inx(2,buf_loc,tempg_loc) +! i = cio_grid_data_inx(1,buf_loc,tseasfc_loc) +! j = cio_grid_data_inx(2,buf_loc,tseasfc_loc) +! cio_grid_data(i:j) = cio_grid_data(begin:end) +! end if +! +! CALL NEXTIME ( loc_jdate(f_met), loc_jtime(f_met), file_tstep(f_met) ) +! if (NLDNSTRIKE) then +! CALL NEXTIME ( loc_jdate(f_ltng), loc_jtime(f_ltng), file_tstep(f_ltng) ) +! end if +! CALL NEXTIME ( loc_jdate(f_bcon), loc_jtime(f_bcon), file_tstep(f_bcon) ) +#endif + + do i = 1, N_FILE_GR + CALL NEXTIME ( loc_jdate(f_emis(i)), loc_jtime(f_emis(i)), file_tstep(f_emis(i)) ) + end do + + end do ! end iter + + if (firstime) then + firstime = .false. + head_grid = 0 + tail_grid = 1 + else + do v = beg_v, end_v + head_grid(v) = mod(head_grid(v)+1, 2) + tail_grid(v) = mod(tail_grid(v)+1, 2) + end do + end if + +#ifdef mpas +! pre_jdate = jdate +! pre_jtime = jtime +#endif + deallocate (loc_jdate, loc_jtime) + + end subroutine retrieve_time_dep_gridded_data + +! ------------------------------------------------------------------------- + subroutine retrieve_lufrac_cro_data + + USE UTILIO_DEFN + USE HGRD_DEFN + USE LSM_Mod, ONLY: n_lufrac, init_lsm + + INCLUDE SUBST_FILES_ID ! file name parameters + + Character( 40 ), parameter :: pname = 'retrieve_lufrac_cro_data' + integer :: startcol, endcol, startrow, endrow, gxoff, gyoff + + CHARACTER( 120 ) :: XMSG = ' ' + INTEGER :: STAT, n, c + + CALL INIT_LSM( 0, 0 ) + + allocate (LUFRAC(ncols, nrows, n_lufrac), STAT=STAT) + IF ( STAT .NE. 0 ) THEN + XMSG = 'Failure allocating LUFRAC array' + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT3 ) + END IF + +#ifdef mpas +! do n = 1, n_lufrac +! do c = 1, ncols +! lufrac(c,1,n) = lufrac_data(n,c) +! end do +! end do +#else + CALL SUBHFILE ( LUFRAC_CRO, GXOFF, GYOFF, + & startcol, endcol, startrow, endrow ) + + IF ( .Not. XTRACT3( LUFRAC_CRO, 'LUFRAC', + & 1, n_lufrac, startrow, endrow, startcol, endcol, + & 0, 0, LUFRAC ) ) THEN + XMSG = 'Error interpolating variable LUFRAC from ' // LUFRAC_CRO + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF +#endif + + end subroutine retrieve_lufrac_cro_data + +#ifdef mpas +! ------------------------------------------------------------------------- +! subroutine stack_files_setup_mpas +! +!! USE UTILIO_DEFN +! use stk_prms +! use stack_group_data_module +! use get_env_module +! use hgrd_defn, only : ncols, mype +! use vgrd_defn, only : nlays +! !use coupler_module, only : pres_ind, g3ddata !(Wei Li) +! use centralized_io_util_module, only : quicksort +! !use util_module, only : index1 !(Wei Li) +! use RUNTIME_VARS, only : emis_sym_date +! +! !use mydata_module !(Wei Li) +! +! include SUBST_FILES_ID ! file name parameters +! +! character( 40 ), parameter :: pname = 'stack_files_setup_mpas' +! +! character( 120 ) :: xmsg = ' ' +! character( 500 ) :: map_fname, fname +! integer :: n, v, pt, max_nsrc_pts, max_nvars, begin, end, stat, delta, +! & num_mesh_points, my_num_mesh_points, t_nvars, floc +! integer, allocatable :: d_size(:), pt_size(:), +! & stk_gp_sdate(:), stk_gp_stime(:), +! & stk_gp_nlays(:), mpas_map(:), my_mpas_map_index(:), +! & tdata_1di(:) +! real, allocatable :: tdata_1dr(:) +! +! call get_env (map_fname, 'mpas_dmap_file', ' ') +! call get_env (num_mesh_points, 'num_mesh_points', 1) +! +! allocate (cio_stack_file_name(nptgrps), +! & cio_stack_file_loc(nptgrps), +! & n_cio_stack_emis_vars(nptgrps), +! & n_cio_stack_emis_lays(nptgrps), +! & n_cio_stack_emis_pts(nptgrps), +! & cio_mpas_stack_emis_timestamp(nptgrps), +! & stkgname(nptgrps), +! & d_size(nptgrps), +! & pt_size(nptgrps), +! & stk_gp_sdate(nptgrps), +! & stk_gp_stime(nptgrps), +! & stk_gp_nlays(nptgrps), +! & fire_on(nptgrps), +! & nsrc(nptgrps), +! & mpas_map(num_mesh_points), +! & my_mpas_map_index(num_mesh_points), ! my mesh point +! & my_nsrc_index(num_mesh_points, nptgrps), ! my source number +! & my_nsrc_mesh_index(num_mesh_points, nptgrps), ! my source w.r.t. to my mesh point +! & my_nsrc_pressure(nlays, num_mesh_points, nptgrps), ! my source pressure +! & stat=stat) +! if (stat .ne. 0) then +! xmsg = 'Failure allocating cio_stack_file_name and other arrays' +! call prog_interrupt (pname, 0, 0, xmsg, 1) +! end if +! +! my_data = .false. +! my_cell_num = -1 +! open (unit = 97, file = map_fname, status = 'old') +! my_num_mesh_points = 0 +! do n = 1, num_mesh_points +! read (97, *) mpas_map(n) +! if (mpas_map(n) == mype) then +! my_num_mesh_points = my_num_mesh_points + 1 +! my_mpas_map_index(my_num_mesh_points) = n +! if (n == 108535) then +! my_cell_num(1) = my_num_mesh_points +! my_data = .true. +! else if (n == 12287) then +! my_cell_num(2) = my_num_mesh_points +! my_data = .true. +! end if +! end if +! end do +! close (97) +! +! fire_on = .false. ! array assignment +!! go through all stack group one time to figure out max number of source points +! stkgname = ' ' ! array +! do n = 1, nptgrps +! write( stkgname( n ),'( "STK_GRPS_",I3.3 )' ) n +! end do +! +! if ( .not. stk_prms_init( stkgname ) ) then +! write (cio_logdev, *) 'Could not initialize stack parameters' +! stop +! end if +! +! do n = 1, nptgrps +! +! floc = search_fname(stkgname(n)) +! +!! stk_gp_sdate(n) = mio_file_data(floc)%var_name(ivar) +!! stk_gp_stime(n) = mio_file_data(floc)%var_name(ivar) +! stk_gp_nlays(n) = mio_file_data(floc)%dim_len(3) +! +! nsrc( n ) = mio_file_data(floc)%dim_len(5) +! +! do v = 1, mio_file_data(floc)%nvars +! if ( mio_file_data(floc)%var_name(v) .eq. 'ACRESBURNED' ) fire_on( n ) = .true. +! end do +! end do +! max_nsrc_pts = maxval(nsrc) +! +! allocate (stkid(max_nsrc_pts, nptgrps), +! & stat = stat) +! if (stat .ne. 0) then +! xmsg = 'Failure allocating other stack group variable arrays' +! call prog_interrupt (pname, cio_model_sdate, cio_model_stime, xmsg, 1) +! end if +! +!! read in stack group data +! +! do n = 1, nptgrps +! +! allocate (tdata_1di(nsrc(n)), stat = stat) +! +! call mio_fread (stkgname(n), 'ROW', tdata_1di) +! +! my_nsrc(n) = 0 +! do v = 1, nsrc(n) +! pt = index1 (tdata_1di(v), my_num_mesh_points, my_mpas_map_index) +! +! if (pt .gt. 0) then +! my_nsrc(n) = my_nsrc(n) + 1 +! my_nsrc_index(my_nsrc(n), n) = v +! my_nsrc_mesh_index(my_nsrc(n), n) = pt +! end if +! end do +! +! deallocate (tdata_1di) +! +! end do +! +! my_strt_src = 0 +! do n = 1, nptgrps +! +! if ( my_nsrc( n ) .gt. 0 ) then +! +! my_strt_src(n) = 1 +! my_end_src(n) = my_nsrc(n) +! +! stkdiam(n)%len = my_nsrc(n) +! stkht(n)%len = my_nsrc(n) +! stktk(n)%len = my_nsrc(n) +! stkvel(n)%len = my_nsrc(n) +! +! allocate (stkdiam(n)%arry(my_nsrc(n)), +! & stkht(n)%arry(my_nsrc(n)), +! & stktk(n)%arry(my_nsrc(n)), +! & stkvel(n)%arry(my_nsrc(n)), +! & tdata_1dr(nsrc(n)), +! & stat=stat ) +! +! if ( fire_on(n) ) then +! acres_burned(n)%len = my_nsrc(n) +! allocate (acres_burned(n)%arry(my_nsrc(n)), +! & stat=stat ) +! end if +! +! call mio_fread (stkgname(n), 'STKDM', tdata_1dr) +! +! do v = 1, my_nsrc(n) +! stkdiam( n )%arry(v) = tdata_1dr(my_nsrc_index(v, n)) +! my_nsrc_pressure(:,v,n) = g3ddata(my_nsrc_mesh_index(v, n),1,:,pres_ind) +! end do +! +! call mio_fread (stkgname(n), 'STKHT', tdata_1dr) +! +! do v = 1, my_nsrc(n) +! stkht( n )%arry(v) = tdata_1dr(my_nsrc_index(v, n)) +! end do +! +! call mio_fread (stkgname(n), 'STKTK', tdata_1dr) +! +! do v = 1, my_nsrc(n) +! stktk( n )%arry(v) = tdata_1dr(my_nsrc_index(v, n)) +! end do +! +! call mio_fread (stkgname(n), 'STKVE', tdata_1dr) +! +! do v = 1, my_nsrc(n) +! stkvel( n )%arry(v) = tdata_1dr(my_nsrc_index(v, n)) +! end do +! +! if ( fire_on( n ) ) then +! call mio_fread (stkgname(n), 'ACRESBURNED', tdata_1dr) +! +! do v = 1, my_nsrc(n) +! acres_burned( n )%arry(v) = tdata_1dr(my_nsrc_index(v, n)) +! end do +! +! end if +! +! deallocate (tdata_1dr) +! end if +! +! end do +! +!! process stack emission files +! max_nvars = 0 +! d_size = 0 +! do pt = 1, nptgrps +! +! write( cio_stack_file_name(pt), '( "STK_EMIS_",I3.3 )' ) pt +! +! floc = search_fname(cio_stack_file_name(pt)) +! cio_stack_file_loc(pt) = floc +! +! n_cio_stack_emis_vars(pt) = mio_file_data(floc)%nvars +! n_cio_stack_emis_lays(pt) = mio_file_data(floc)%nlays +! n_cio_stack_emis_pts(pt) = nsrc( pt ) +! +! cio_mpas_stack_emis_timestamp(pt) = mio_file_data(floc)%timestamp(1) +! +! if (max_nvars .lt. mio_file_data(floc)%nvars) then +! max_nvars = mio_file_data(floc)%nvars +! end if +! +! if (my_strt_src(pt) .gt. 0) then +! pt_size(pt) = (my_end_src(pt) - my_strt_src(pt) + 1) * n_cio_stack_emis_lays(pt) +! d_size(pt) = mio_file_data(floc)%nvars * pt_size(pt) * 3 +! else +! pt_size(pt) = 0 +! d_size(pt) = 0 +! end if +! +! end do +! +! allocate (cio_stack_var_name(max_nvars, nptgrps), +! & head_stack_emis(max_nvars, nptgrps), +! & tail_stack_emis(max_nvars, nptgrps), +! & cio_stack_emis_data_inx(2, 0:2, max_nvars, nptgrps), +! & cio_stack_emis_data_tstamp(2, 0:2, max_nvars, nptgrps), +! & cio_stack_data(sum(d_size)), +! & f_stk_emis(NPTGRPS), +! & stat = stat) +! if (stat .ne. 0) then +! xmsg = 'Failure allocating other stack arrays' +! call prog_interrupt (pname, 0, 0, xmsg, 1) +! end if +! +! begin = 1 +! cio_stack_emis_data_inx = -1 +! do pt = 1, nptgrps +! +! floc = cio_stack_file_loc(pt) +! +! n_opened_file = n_opened_file + 1 +! f_stk_emis(pt) = n_opened_file +! +!! Check whether file is a representative day type +! write (fname, '(a16, i3.3)') "STK_EM_SYM_DATE_", pt +! file_sym_date(f_stk_emis(pt)) = emis_sym_date ! Master switch to change default +! call get_env(file_sym_date(f_stk_emis(pt)), fname, +! & file_sym_date(f_stk_emis(pt)), logdev) +! +! file_sdate(f_stk_emis(pt)) = mio_file_data(floc)%tflag(1,1) +! file_stime(f_stk_emis(pt)) = mio_file_data(floc)%tflag(2,1) +! file_tstep(f_stk_emis(pt)) = mio_file_data(floc)%tstep +! +! t_nvars = mio_file_data(floc)%nvars +! +! cio_stack_var_name(1:t_nvars, pt) = mio_file_data(floc)%var_name(1:t_nvars) +! +! call quicksort(cio_stack_var_name(1:t_nvars,pt), 1, t_nvars) +! +! if (my_nsrc(pt) .gt. 0) then +! do v = 1, mio_file_data(floc)%nvars +! do n = 0, 2 +! cio_stack_emis_data_inx(1,n,v,pt) = begin +! end = begin + pt_size(pt) - 1 +! cio_stack_emis_data_inx(2,n,v,pt) = end +! begin = end + 1 +! end do +! end do +! end if +! end do +! +! deallocate (d_size) +! +! end subroutine stack_files_setup_mpas +! +!! ------------------------------------------------------------------------- +! subroutine retrieve_stack_data_mpas (jdate, jtime, fname, vname) +! +!! USE UTILIO_DEFN +! use stk_prms, only : my_strt_src, my_end_src, my_nsrc, my_nsrc_index +! use stack_group_data_module, only : nsrc +! use util_module, only : NEXTIME +! use centralized_io_util_module, only : julian_to_mpas_date_time, binary_search +! +! include SUBST_FILES_ID ! file name parameters +! +! integer, intent(in) :: jdate, jtime +! character (*), intent(in), optional :: fname, vname +! +! character( 40 ), parameter :: pname = 'retrieve_stack_data_mpas' +! +! logical, save :: firstime = .true. +! integer :: stat, i, j, begin, end, buf_loc, iterations, +! & iter, loc_jdate, loc_jtime, v, beg_v, end_v, +! & beg_gp, end_gp, gp, fnum +! real, allocatable :: tdata_1dr(:) +! character (20) :: mpas_time_stamp +! character (20), allocatable, save :: mpas_stack_loc_time_stamp(:) +! +! character( 120 ) :: xmsg = ' ' +! +! if (firstime) then +! +! allocate (mpas_stack_loc_time_stamp(nptgrps), stat=stat) +! +! do i = 1, nptgrps +! j = search_fname (cio_stack_file_name(i)) +! mpas_stack_loc_time_stamp(i) = mio_file_data(j)%timestamp(1) +! end do +! +! head_stack_emis = -1 +! tail_stack_emis = -1 +! +! iterations = 2 +! else +! iterations = 1 +! end if +! +! if (present(vname)) then +! beg_gp = binary_search (fname, cio_stack_file_name, nptgrps) +! end_gp = beg_gp +! beg_v = binary_search (vname, cio_stack_var_name(:,beg_gp), n_cio_stack_emis_vars(beg_gp)) +! end_v = beg_v +! else +! beg_gp = 1 +! end_gp = nptgrps +! end if +! +! do gp = beg_gp, end_gp +! +! allocate (tdata_1dr(nsrc(gp)), stat = stat) +! +! if (firstime) then +! loc_jdate = jdate +! if (file_sym_date(f_stk_emis(gp))) loc_jdate = file_sdate(f_stk_emis(gp)) ! Representative day check +! loc_jtime = jtime +! else +! loc_jdate = jdate +! loc_jtime = jtime +! end if +! +! if (.not. present(vname)) then +! beg_v = 1 +! end_v = n_cio_stack_emis_vars(gp) +! end if +! +!! cio_stack_emis_data_inx +! +! do iter = 1, iterations +! +! call julian_to_mpas_date_time (loc_jdate, loc_jtime, mpas_time_stamp) +! +! do v = beg_v, end_v +! buf_loc = mod((tail_stack_emis(v, gp) + iter), 2) +! +! cio_stack_emis_data_tstamp(1, buf_loc, v, gp) = loc_jdate +! cio_stack_emis_data_tstamp(2, buf_loc, v, gp) = loc_jtime +! +! begin = cio_stack_emis_data_inx(1, buf_loc, v, gp) +! end = cio_stack_emis_data_inx(2, buf_loc, v, gp) +! +! if ((begin .gt. 0) .and. (my_nsrc(gp) .gt. 0)) then +! +! call mio_fread (cio_stack_file_name(gp), +! & cio_stack_var_name(v, gp), +! & tdata_1dr, +! & mpas_time_stamp) +! +! do i = 1, my_nsrc(gp) +! cio_stack_data(begin+i-1) = tdata_1dr(my_nsrc_index(i, gp)) +! end do +! end if +! end do +! +! call nextime ( loc_jdate, loc_jtime, file_tstep(f_stk_emis(gp)) ) +! +! end do ! end iter +! +! deallocate (tdata_1dr) +! +! end do +! +! if (firstime) then +! firstime = .false. +! head_stack_emis = 0 +! tail_stack_emis = 1 +! else +! do gp = beg_gp, end_gp +! do v = beg_v, end_v +! head_stack_emis(v, gp) = mod(head_stack_emis(v, gp)+1, 2) +! tail_stack_emis(v, gp) = mod(tail_stack_emis(v, gp)+1, 2) +! end do +! end do +! end if +! +! end subroutine retrieve_stack_data_mpas +! +!! ------------------------------------------------------------------------- +! subroutine retrieve_ocean_data_mpas +! +! USE HGRD_DEFN +! USE mio_module, only : search_fname +! +! character (20) :: ocean_file = 'OCEAN_1' +! character (120) :: xmsg = ' ' +! character (1000) :: fname +! integer :: floc +! logical :: exist +! +! call get_env (fname, ocean_file, ' ') +! inquire (file=fname, exist=exist) +! +! if (exist) then +! floc = search_fname (ocean_file) +! end if +! +! if (ocean_chem) then +! +!! if OCEAN file does not exist, g2ddata with open_ind and surf_ind have +!! been setup in subroutne mpas_cmaq_coupler, mpas_atmchem_interface.F +! if (exist) then +! call mio_fread (ocean_file, +! & 'OPEN', +! & g2ddata(:, 1, open_ind), +! & mio_file_data(floc)%timestamp(1)) +! +! call mio_fread (ocean_file, +! & 'SURF', +! & g2ddata(:, 1, surf_ind), +! & mio_file_data(floc)%timestamp(1)) +! +! call mio_fread (ocean_file, +! & 'CHLO', +! & g2ddata(:, 1, chlo_ind), +! & mio_file_data(floc)%timestamp(1)) +! call mio_fread (ocean_file, +! & 'DMS', +! & g2ddata(:, 1, dms_ind), +! & mio_file_data(floc)%timestamp(1)) +! else +! XMSG = 'Ocean file doese not exist' +! call prog_interrupt ('reading ocean file', 0, 0, xmsg, 1) +! end if +! end if +! end if +! +! end subroutine retrieve_ocean_data_mpas +! +#else + +! ------------------------------------------------------------------------- + subroutine boundary_files_setup + + USE UTILIO_DEFN + use HGRD_DEFN, only : ncols, nrows + USE VGRD_DEFN, only : VGTYP_GD, nlays + use centralized_io_util_module, only : quicksort + + INCLUDE SUBST_FILES_ID ! file name parameters + + Character( 40 ), parameter :: pname = 'boundary_files_setup' + + CHARACTER( 120 ) :: XMSG = ' ' + INTEGER :: GXOFF, GYOFF, stat, n, v, d_size, begin, end + + character( 16 ), allocatable :: b3d_name(:,:) + character( 16 ) :: mb3d_name(2, 2) + +! MET_BDY_3D file, need to be opened when window is F + if (.not. window) then +#ifndef twoway + IF ( .NOT. OPEN3( MET_BDY_3D, FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open '// MET_BDY_3D // ' file' + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + IF ( .NOT. DESC3( MET_BDY_3D ) ) THEN + XMSG = 'Could not get file description from '// MET_BDY_3D + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF +#endif + n_mb3d = 2 + mb3d_name = 'mb' ! denote met 3D boundary variable + mb3d_name(1,1) = 'DENSA_J' + mb3d_name(2,1) = 'JACOBM' + else + n_mb3d = 0 + end if + +! BCON file + IF ( .NOT. OPEN3( BCFILE, FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open '// BCFILE // ' file' + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + n_opened_file = n_opened_file + 1 + f_bcon = n_opened_file + IF ( .NOT. DESC3( BCFILE ) ) THEN + XMSG = 'Could not get description of file '// BCFILE + CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + file_sdate(f_bcon) = sdate3d + file_stime(f_bcon) = stime3d + file_tstep(f_bcon) = tstep3d + file_xcell(f_bcon) = xcell3d + file_ycell(f_bcon) = ycell3d + + n_b3d = nvars3d + size_b2d = (ncols3d + nrows3d + 2 * nthik3d) * 2 * nthik3d + size_b3d = size_b2d * nlays + + allocate (b3d_name(n_b3d, 2), + & cio_bc_file_var_name(nvars3d), + & stat=stat) + if (stat .ne. 0) then + xmsg = 'Failure allocating mb3d_name ' + call m3exit (pname, 0, 0, xmsg, xstat1 ) + end if + + if (tstep3d == 0) then + b3d_name = 'bc' ! denote time independent 3D boundary variable + else + b3d_name = 'bct' ! denote time dependent 3D boundary variable + end if + + b3d_name(:,1) = vname3d(1:nvars3d) + cio_bc_file_var_name = vname3d(1:nvars3d) + n_cio_bc_file_vars = nvars3d + +! combining all files + n_cio_bndy_vars = n_mb3d + n_b3d + + allocate (cio_bndy_var_name(n_cio_bndy_vars, 2), + & cio_bndy_data_inx(2, 0:2, n_cio_bndy_vars), + & head_bndy(n_cio_bndy_vars), + & tail_bndy(n_cio_bndy_vars), + & cio_bndy_data_tstamp(2, 0:2, n_cio_bndy_vars), + & cio_bndy_data(size_b3d * 3 * (n_mb3d + n_b3d)), ! boundary data + & stat = stat) + if (stat .ne. 0) then + xmsg = 'Failure allocating cio_bndy_var_name and associated arrays ' + call m3exit (pname, 0, 0, xmsg, xstat1 ) + end if + + begin = 1 + end = n_b3d + cio_bndy_var_name(begin:end, :) = b3d_name + if (.not. window) then + begin = end + 1 + end = end + 2 + cio_bndy_var_name(begin:end, :) = mb3d_name + end if + + deallocate (b3d_name) + + call quicksort(cio_bndy_var_name, 1, n_cio_bndy_vars) + + begin = 1 + do v = 1, n_cio_bndy_vars + + do n = 0, 2 + cio_bndy_data_inx(1, n, v) = begin + end = begin + size_b3d - 1 + cio_bndy_data_inx(2, n, v) = end + begin = end + 1 + end do +! this is for checking purposes +! write (logdev, '(a13, i5, 1x, a16, a4, 10i10)') ' ==d== bfile ', v, +! & cio_bndy_var_name(v,:), cio_bndy_data_inx(:,:,v) + end do + + end subroutine boundary_files_setup + +! ------------------------------------------------------------------------- + subroutine stack_files_setup + + USE UTILIO_DEFN + USE STK_PRMS + USE stack_group_data_module + USE HGRD_DEFN, only : XORIG_GD, YORIG_GD, XCELL_GD, YCELL_GD + + INCLUDE SUBST_FILES_ID ! file name parameters + + Character( 40 ), parameter :: pname = 'stack_files_setup' + + Character( 32 ) :: fname + CHARACTER( 120 ) :: XMSG = ' ' + integer :: n, v, pt, max_nsrc_pts, max_nvars, begin, end, stat, delta + integer, allocatable :: d_size(:), pt_size(:), + & stk_gp_sdate(:), stk_gp_stime(:), + & stk_gp_nlays(:) + + integer :: ldate, ltime, t + logical :: found, done + + allocate (cio_stack_file_name(NPTGRPS), + & n_cio_stack_emis_vars(NPTGRPS), + & n_cio_stack_emis_lays(NPTGRPS), + & n_cio_stack_emis_pts(NPTGRPS), + & STKGNAME(NPTGRPS), + & d_size(NPTGRPS), + & pt_size(NPTGRPS), + & stk_gp_sdate(NPTGRPS), + & stk_gp_stime(NPTGRPS), + & stk_gp_nlays(NPTGRPS), + & FIRE_ON(NPTGRPS), + & NSRC(NPTGRPS), + & stat=stat) + if (stat .ne. 0) then + xmsg = 'Failure allocating cio_stack_file_name and other arrays' + call m3exit (pname, 0, 0, xmsg, xstat1 ) + end if + + FIRE_ON = .FALSE. ! array assignment +! go through all stack group one time to figure out max number of source points + STKGNAME = ' ' ! array + DO N = 1, NPTGRPS + WRITE( STKGNAME( N ),'( "STK_GRPS_",I3.3 )' ) N + END DO + + do N = 1, NPTGRPS + IF ( .NOT. OPEN3( STKGNAME( N ), FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open '// TRIM( STKGNAME( N ) ) // ' file' + call m3exit (pname, cio_model_sdate, cio_model_stime, xmsg, xstat1 ) + END IF + n_opened_file = n_opened_file + 1 + + IF ( .NOT. DESC3( STKGNAME( N ) ) ) THEN + XMSG = 'Could not get ' // TRIM( STKGNAME( N ) ) // ' file description' + call m3exit (pname, cio_model_sdate, cio_model_stime, xmsg, xstat1 ) + END IF + + stk_gp_sdate(n) = sdate3d + stk_gp_stime(n) = stime3d + stk_gp_nlays(n) = nlays3d + + NSRC( N ) = NROWS3D + + DO V = 1, NVARS3D + IF ( VNAME3D( V ) .EQ. 'ACRESBURNED' ) FIRE_ON( N ) = .TRUE. + END DO + end do + max_nsrc_pts = maxval(NSRC) + + allocate (xloca(max_nsrc_pts, NPTGRPS), + & yloca(max_nsrc_pts, NPTGRPS), + & stkid(max_nsrc_pts, NPTGRPS), + & f_stk_emis(NPTGRPS), + & stat = stat) + if (stat .ne. 0) then + xmsg = 'Failure allocating other stack group variable arrays' + call m3exit (pname, cio_model_sdate, cio_model_stime, xmsg, xstat1 ) + end if + +! read in stack group data + + do N = 1, NPTGRPS + IF ( .NOT. READ3( STKGNAME( N ), 'XLOCA', ALLAYS3, + & stk_gp_sdate(n), stk_gp_stime(n), XLOCA(:,N) ) ) THEN + XMSG = 'Could not read XLOCA from ' // TRIM( STKGNAME( N)) + call m3exit (pname, stk_gp_sdate(n), stk_gp_stime(n), xmsg, xstat1 ) + END IF + + IF ( .NOT. READ3( STKGNAME( N ), 'YLOCA', ALLAYS3, + & stk_gp_sdate(n), stk_gp_stime(n), YLOCA(:,N) ) ) THEN + XMSG = 'Could not read YLOCA from ' // TRIM( STKGNAME( N)) + call m3exit (pname, stk_gp_sdate(n), stk_gp_stime(n), xmsg, xstat1 ) + END IF + + IF ( .NOT. READ3( STKGNAME( N ), 'ISTACK', ALLAYS3, + & stk_gp_sdate(n), stk_gp_stime(n), STKID(:,N) ) ) THEN + XMSG = 'Could not read ISTACK from ' // TRIM( STKGNAME( N) ) + call m3exit (pname, stk_gp_sdate(n), stk_gp_stime(n), xmsg, xstat1 ) + END IF + end do + + IF ( .NOT. STK_PRMS_INIT( STKGNAME ) ) THEN + xmsg = 'Could not initialize stack parameters' + call m3exit( 'Stack Files Setup', 0, 0, xmsg, 2 ) + END IF + + do N = 1, NPTGRPS + + IF ( MY_NSRC( N ) .GT. 0 ) THEN + + IF ( .NOT. XTRACT3( STKGNAME( N ), 'STKDM', 1, stk_gp_nlays(n), + & MY_STRT_SRC( N ), MY_END_SRC( N ), + & 1, 1, stk_gp_sdate(n), stk_gp_stime(n), STKDIAM( N )%ARRY) ) THEN + XMSG = 'Could not read STKDM from ' // TRIM( STKGNAME( N ) ) + call m3exit (pname, stk_gp_sdate(n), stk_gp_stime(n), xmsg, xstat1 ) + END IF + + IF ( .NOT. XTRACT3( STKGNAME( N ), 'STKHT', 1, stk_gp_nlays(n), + & MY_STRT_SRC( N ), MY_END_SRC( N ), + & 1, 1, stk_gp_sdate(n), stk_gp_stime(n), STKHT( N )%ARRY) ) THEN + XMSG = 'Could not read STKHT from ' // TRIM( STKGNAME( N ) ) + call m3exit (pname, stk_gp_sdate(n), stk_gp_stime(n), xmsg, xstat1 ) + END IF + + IF ( .NOT. XTRACT3( STKGNAME( N ), 'STKTK', 1, stk_gp_nlays(n), + & MY_STRT_SRC( N ), MY_END_SRC( N ), + & 1, 1, stk_gp_sdate(n), stk_gp_stime(n), STKTK( N )%ARRY) ) THEN + XMSG = 'Could not read STKTK from ' // TRIM( STKGNAME( N ) ) + call m3exit (pname, stk_gp_sdate(n), stk_gp_stime(n), xmsg, xstat1 ) + END IF + + IF ( .NOT. XTRACT3( STKGNAME( N ), 'STKVE', 1, stk_gp_nlays(n), + & MY_STRT_SRC( N ), MY_END_SRC( N ), + & 1, 1, stk_gp_sdate(n), stk_gp_stime(n), STKVEL( N )%ARRY) ) THEN + XMSG = 'Could not read STKVE from ' // TRIM( STKGNAME( N ) ) + call m3exit (pname, stk_gp_sdate(n), stk_gp_stime(n), xmsg, xstat1 ) + END IF + + IF ( FIRE_ON( N ) ) THEN + IF ( .NOT. XTRACT3( STKGNAME( N ), 'ACRESBURNED', 1, stk_gp_nlays(n), + & MY_STRT_SRC( N ), MY_END_SRC( N ), + & 1, 1, stk_gp_sdate(n), stk_gp_stime(n), ACRES_BURNED( N )%ARRY) ) THEN + XMSG = 'Could not read ACRESBURNED from ' // TRIM( STKGNAME( N ) ) + call m3exit (pname, stk_gp_sdate(n), stk_gp_stime(n), xmsg, xstat1 ) + END IF + END IF + + END IF + + end do + +! process stack emission files + max_nvars = 0 + d_size = 0 + do pt = 1, NPTGRPS + WRITE( cio_stack_file_name(pt), '( "STK_EMIS_",I3.3 )' ) pt + + IF ( .NOT. OPEN3( cio_stack_file_name( pt ), FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open '// TRIM( cio_stack_file_name( pt ) ) // ' file' + CALL M3MESG( XMSG ) + END IF + n_opened_file = n_opened_file + 1 + f_stk_emis(pt) = n_opened_file + + IF ( .NOT. DESC3( cio_stack_file_name( pt ) ) ) THEN + XMSG = 'Could not get ' // TRIM( cio_stack_file_name( pt ) ) // ' file description' + CALL M3MESG( XMSG ) + END IF + + n_cio_stack_emis_vars(pt) = nvars3d + n_cio_stack_emis_lays(pt) = nlays3d + n_cio_stack_emis_pts(pt) = nrows3d + + file_sdate(f_stk_emis(pt)) = sdate3d + file_stime(f_stk_emis(pt)) = stime3d + file_tstep(f_stk_emis(pt)) = tstep3d + file_xcell(f_stk_emis(pt)) = xcell3d + file_ycell(f_stk_emis(pt)) = ycell3d + +! Check whether file is a representative day type + write (fname, '(a16, i3.3)') "STK_EM_SYM_DATE_", pt + file_sym_date(f_stk_emis(pt)) = emis_sym_date ! Master switch to change default + call get_env(file_sym_date(f_stk_emis(pt)), fname, + & file_sym_date(f_stk_emis(pt)), logdev) + + found = .false. + ldate = sdate3d + ltime = stime3d + if ((ldate == stdate) .and. (mxrec3d > 1)) then + found = .true. + else + t = 1 + do while ((t < mxrec3d) .and. (.not. found)) + call nextime (ldate, ltime, tstep3d) + if (ldate == stdate) then + found = .true. + end if + t = t + 1 + end do + end if + + if (max_nvars .lt. nvars3d) then + max_nvars = nvars3d + end if + if (MY_STRT_SRC(pt) .gt. 0) then + pt_size(pt) = (MY_END_SRC(pt) - MY_STRT_SRC(pt) + 1) * n_cio_stack_emis_lays(pt) + d_size(pt) = nvars3d * pt_size(pt) * 3 + else + pt_size(pt) = 0 + d_size(pt) = 0 + end if + + end do + + allocate (cio_stack_var_name(max_nvars, NPTGRPS), + & head_stack_emis(max_nvars, NPTGRPS), + & tail_stack_emis(max_nvars, NPTGRPS), + & cio_stack_emis_data_inx(2, 0:2, max_nvars, NPTGRPS), + & cio_stack_emis_data_tstamp(2, 0:2, max_nvars, NPTGRPS), + & cio_stack_data(sum(d_size)), + & stat = stat) + if (stat .ne. 0) then + xmsg = 'Failure allocating other stack arrays' + call m3exit (pname, 0, 0, xmsg, xstat1 ) + end if + + begin = 1 + cio_stack_emis_data_inx = -1 + do pt = 1, NPTGRPS + IF ( .NOT. DESC3( cio_stack_file_name( pt ) ) ) THEN + XMSG = 'Could not get ' // TRIM( cio_stack_file_name( pt ) ) // ' file description' + CALL M3MESG( XMSG ) + END IF + + cio_stack_var_name(1:nvars3d, pt) = vname3d(1:nvars3d) + call quicksort(cio_stack_var_name(:,pt), 1, nvars3d) + + if (MY_NSRC(pt) .gt. 0) then + do v = 1, nvars3d + do n = 0, 2 + cio_stack_emis_data_inx(1,n,v,pt) = begin + end = begin + pt_size(pt) - 1 + cio_stack_emis_data_inx(2,n,v,pt) = end + begin = end + 1 + end do + end do + end if + end do + + deallocate (d_size) + + end subroutine stack_files_setup + +! ------------------------------------------------------------------------- + subroutine biogemis_setup + + USE UTILIO_DEFN + use HGRD_DEFN, only : ncols, nrows + USE biog_emis_param_module + + INCLUDE SUBST_FILES_ID ! file name parameters + + Character( 40 ), parameter :: pname = 'biogemis_setup' + + CHARACTER( 120 ) :: XMSG = ' ' + CHARACTER( 256 ) :: MESG + CHARACTER( 16 ) :: VAR + INTEGER :: STAT, i, j, k + integer :: startcol, endcol, startrow, endrow, gxoff, gyoff + + ALLOCATE( AVGEMIS( NCOLS,NROWS,NSEF-1,NSEASONS ), + & STAT=STAT ) + + IF ( .NOT. OPEN3( biogemis_fname, FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open ' // trim(biogemis_fname) // ' file' + CALL M3MESG( XMSG ) + END IF + n_opened_file = n_opened_file + 1 + + IF ( .NOT. DESC3( biogemis_fname ) ) THEN + XMSG = 'Could not get ' // trim(biogemis_fname) // ' file description' + CALL M3MESG( XMSG ) + END IF + + call subhfile ( biogemis_fname, gxoff, gyoff, + & startcol, endcol, startrow, endrow ) + + +C Read the various categories of normalized emissions + DO I = 1, NSEASONS + + DO J = 1, NSEF-1 + VAR = 'AVG_' // TRIM( BIOTYPES( J ) ) // SEASON( I ) + + IF ( .NOT. XTRACT3( biogemis_fname, VAR, + & 1,1, startrow, endrow, startcol, endcol, + & 0, 0, AVGEMIS( :,:,J,I ) ) ) THEN + MESG = 'Could not read "' // TRIM( VAR ) // + & '" from file "' // TRIM( biogemis_fname ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + END DO + + END DO ! end loop over seasons + + end subroutine biogemis_setup + +! ------------------------------------------------------------------------- + subroutine beis_norm_emis_setup + + USE UTILIO_DEFN + use HGRD_DEFN, only : ncols, nrows + + Character( 40 ), parameter :: pname = 'beis_norm_emis_setup' + Character( 40 ), parameter :: fname = 'BEIS_NORM_EMIS' + + CHARACTER( 256 ) :: MESG + CHARACTER( 16 ) :: VAR + INTEGER :: STAT + integer :: startcol, endcol, startrow, endrow, gxoff, gyoff + + ALLOCATE( GROWAGNO( NCOLS,NROWS ), + & NGROWAGNO( NCOLS,NROWS ), + & NONAGNO( NCOLS,NROWS ), + & STAT=STAT ) + + IF ( .NOT. OPEN3( fname, FSREAD3, PNAME ) ) THEN + MESG = 'Could not open ' // trim(fname) // ' file ' + CALL M3MESG( MESG ) + END IF + n_opened_file = n_opened_file + 1 + + call subhfile ( fname, gxoff, gyoff, + & startcol, endcol, startrow, endrow ) + + VAR = 'AVG_NOAG_GROW' + IF ( .NOT. XTRACT3( fname, VAR, + & 1,1, startrow, endrow, startcol, endcol, + & 0, 0, GROWAGNO ) ) THEN + MESG = 'Could not read "' // TRIM( VAR ) // + & '" from file "' // TRIM( fname ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + + VAR = 'AVG_NOAG_NONGROWNB3' + IF ( .NOT. XTRACT3( fname, VAR, + & 1,1, startrow, endrow, startcol, endcol, + & 0, 0, NGROWAGNO ) ) THEN + MESG = 'Could not read "' // TRIM( VAR ) // + & '" from file "' // TRIM( fname ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + + VAR = 'AVG_NONONAG' + IF ( .NOT. XTRACT3( fname, VAR, + & 1,1, startrow, endrow, startcol, endcol, + & 0, 0, NONAGNO ) ) THEN + MESG = 'Could not read "' // TRIM( VAR ) // + & '" from file "' // TRIM( fname ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + + end subroutine beis_norm_emis_setup + +! ------------------------------------------------------------------------- + subroutine depv_data_setup + + USE UTILIO_DEFN + use HGRD_DEFN, only : ncols, nrows + use depv_data_module +! use util_module, only : index1 + + INCLUDE SUBST_FILES_ID ! file name parameters + + Character( 40 ), parameter :: pname = 'depv_data_setup' + + CHARACTER( 256 ) :: MESG + CHARACTER( 16 ) :: vname + INTEGER :: STAT, i, j, k, jdate_yest + integer :: startcol, endcol, startrow, endrow, gxoff, gyoff + + Allocate ( Beld_ag ( ncols, nrows, e2c_cats ), + & pHs1 ( ncols, nrows, e2c_cats ), ! for E2C_SOIL file + & pHs2 ( ncols, nrows, e2c_cats ), ! for E2C_SOIL file + & NH4ps1 ( ncols, nrows, e2c_cats ), ! for E2C_CHEM file + & NH4ps2 ( ncols, nrows, e2c_cats ), ! for E2C_CHEM file + & STAT=STAT ) + + IF ( .NOT. OPEN3( E2C_LU, FSREAD3, PNAME ) ) THEN + mesg = 'Could not open ' // trim(E2C_LU) // ' file' + CALL M3MESG( mesg ) + END IF + n_opened_file = n_opened_file + 1 + + call subhfile ( E2C_LU, gxoff, gyoff, + & startcol, endcol, startrow, endrow ) + + Do k = 1, e2c_cats + vname = BELD_Names(k) + IF ( .NOT. XTRACT3( E2C_LU, vname, + & 1, 1, startrow, endrow, startcol, endcol, + & 0, 0, Beld_ag( :,:,k ) ) ) Then + MESG = 'Could not read "' // TRIM( vname ) // + & '" from file "' // TRIM( E2C_LU ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + End Do + +! for E2C_SOIL file + If ( .Not. Open3( E2C_SOIL, fsread3, pname ) ) Then + mesg = 'Could not open '// E2C_SOIL // ' file' + Call M3exit ( pname, 0, 0, mesg, xstat1 ) + End If + n_opened_file = n_opened_file + 1 + + call subhfile ( E2C_SOIL, gxoff, gyoff, + & startcol, endcol, startrow, endrow ) + + vname = 'L1_PH' + If ( .Not. Xtract3 ( E2C_SOIL, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, 0, 0, pHs1 ) ) Then + MESG = 'Could not read "' // TRIM( vname ) // + & '" from file "' // TRIM( E2C_SOIL ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L2_PH' + If ( .Not. Xtract3 ( E2C_SOIL, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, 0, 0, pHs2 ) ) Then + MESG = 'Could not read "' // TRIM( vname ) // + & '" from file "' // TRIM( E2C_SOIL ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + +#ifdef m3dry_opt + Allocate ( por1 ( ncols, nrows, e2c_cats ), + & por2 ( ncols, nrows, e2c_cats ), + & wp1 ( ncols, nrows, e2c_cats ), + & wp2 ( ncols, nrows, e2c_cats ), + & cec1 ( ncols, nrows, e2c_cats ), + & cec2 ( ncols, nrows, e2c_cats ), + & STAT=STAT ) + + vname = 'L1_Porosity' + If ( .Not. Xtract3 ( E2C_SOIL, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, 0, 0, por1 ) ) Then + MESG = 'Could not read "' // TRIM( vname ) // + & '" from file "' // TRIM( E2C_SOIL ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L2_Porosity' + If ( .Not. Xtract3 ( E2C_SOIL, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, 0, 0, por2 ) ) Then + MESG = 'Could not read "' // TRIM( vname ) // + & '" from file "' // TRIM( E2C_SOIL ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L1_Wilt_P' + If ( .Not. Xtract3 ( E2C_SOIL, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, 0, 0, wp1 ) ) Then + MESG = 'Could not read "' // TRIM( vname ) // + & '" from file "' // TRIM( E2C_SOIL ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L2_Wilt_P' + If ( .Not. Xtract3 ( E2C_SOIL, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, 0, 0, wp2 ) ) Then + MESG = 'Could not read "' // TRIM( vname ) // + & '" from file "' // TRIM( E2C_SOIL ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L1_Cation' + If ( .Not. Xtract3 ( E2C_SOIL, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, 0, 0, cec1 ) ) Then + MESG = 'Could not read "' // TRIM( vname ) // + & '" from file "' // TRIM( E2C_SOIL ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L2_Cation' + If ( .Not. Xtract3 ( E2C_SOIL, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, 0, 0, cec2 ) ) Then + MESG = 'Could not read "' // TRIM( vname ) // + & '" from file "' // TRIM( E2C_SOIL ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If +#endif + +! for E2C_CHEM file + If ( .Not. Open3( E2C_CHEM, fsread3, pname ) ) Then + mesg = 'Could not open '// E2C_CHEM // ' file' + Call M3exit ( pname, 0, 0, mesg, xstat1 ) + End If + n_opened_file = n_opened_file + 1 + + IF ( .NOT. DESC3( E2C_CHEM ) ) THEN + MESG = 'Could not get description of file "' // + & TRIM( E2C_CHEM ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + + call subhfile ( E2C_CHEM, gxoff, gyoff, + & startcol, endcol, startrow, endrow ) + + GMN_AVAIL = .false. + if (index1 ('GMN', nvars3d, vname3d) .gt. 0) then + GMN_AVAIL = .true. + end if + + vname = 'L1_NH3' + If ( .Not. Xtract3 (E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, NH4ps1) ) Then + MESG = 'Could not read "' // TRIM( vname ) // + & '" from file "' // TRIM( E2C_CHEM ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L2_NH3' + If ( .Not. Xtract3 (E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, NH4ps2) ) Then + MESG = 'Could not read "' // TRIM( vname ) // + & '" from file "' // TRIM( E2C_CHEM ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + +#ifdef m3dry_opt + + Allocate ( wep1 ( ncols, nrows, e2c_cats ), + & wep2 ( ncols, nrows, e2c_cats ), + & dep2 ( ncols, nrows, e2c_cats ), + & STAT=STAT ) + + vname = 'L1_SW' + If ( .Not. Xtract3 (E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, wep1)) Then + MESG = 'Could not read "' // TRIM( vname ) // + & '" from file "' // TRIM( E2C_CHEM ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L2_SW' + If ( .Not. Xtract3 (E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, wep2)) Then + MESG = 'Could not read "' // TRIM( vname ) // + & '" from file "' // TRIM( E2C_CHEM ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L2_DEP' + If ( .Not. Xtract3 (E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, dep2)) Then + MESG = 'Could not read "' // TRIM( vname ) // + & '" from file "' // TRIM( E2C_CHEM ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If +#else +#ifdef stage_opt + Allocate( Nit1 ( ncols,nrows,e2c_cats ), + & Nit2 ( ncols,nrows,e2c_cats ), + & L1_ON ( ncols,nrows,e2c_cats ), + & L2_ON ( ncols,nrows,e2c_cats ), + & BDc1 ( ncols,nrows,e2c_cats ), + & BDc2 ( ncols,nrows,e2c_cats ), + & STAT=STAT ) + + vname = 'L1_NITR' + If ( .Not. Xtract3 (E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, Nit1 ) ) Then + Write( mesg,9001 ) vname, E2C_CHEM + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L2_NITR' + If ( .Not. Xtract3 (E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, Nit2 ) ) Then + Write( mesg,9001 ) vname, E2C_CHEM + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L1_ON' + If ( .Not. Xtract3 (E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, L1_ON ) ) Then + Write( mesg,9001 ) vname, E2C_CHEM + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L2_ON' + If ( .Not. Xtract3 (E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, L2_ON ) ) Then + Write( mesg,9001 ) vname, E2C_CHEM + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L1_BD' + If ( .Not. Xtract3 (E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, BDc1 ) ) Then + Write( mesg,9001 ) vname, E2C_CHEM + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L2_BD' + If ( .Not. Xtract3 (E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, BDc2 ) ) Then + Write( mesg,9001 ) vname, E2C_CHEM + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + If ( GMN_AVAIL ) Then ! Using Fest-C 1.4 output + Allocate( GMN ( ncols,nrows,e2c_cats ), STAT = STAT ) + If ( STAT .Ne. 0 ) Then + mesg = 'Failure allocating GMN' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'GMN' + If ( .Not. Xtract3 (E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, GMN ) ) Then + Write( mesg,9001 ) vname, E2C_CHEM + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + End If + + Allocate( gamma1 ( ncols,nrows ), + & gamma2 ( ncols,nrows ), + & F1_NH4 ( ncols,nrows,e2c_cats ), + & F2_NH4 ( ncols,nrows,e2c_cats ), + & STAT=STAT ) + + if ( MEDC_AVAIL ) then + call subhfile ( INIT_MEDC_1, gxoff, gyoff, + & startcol, endcol, startrow, endrow ) + + vname = 'Gamma1' + If ( .Not. Xtract3 ( INIT_MEDC_1, vname, 1, 1, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, gamma1 ) ) Then + Write( mesg,9001 ) vname, INIT_MEDC_1 + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'Gamma2' + If ( .Not. Xtract3 ( INIT_MEDC_1, vname, 1, 1, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, gamma2 ) ) Then + Write( mesg,9001 ) vname, INIT_MEDC_1 + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L1_ANH3' + If ( .Not. Xtract3 ( E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, F1_NH4 ) ) Then + Write( mesg,9001 ) vname, E2C_CHEM + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L2_ANH3' + If ( .Not. Xtract3 ( E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, F2_NH4 ) ) Then + Write( mesg,9001 ) vname, E2C_CHEM + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + If( .not. GMN_AVAIL ) Then + + Allocate( L1_ON_Yest ( ncols,nrows,e2c_cats ), + & L2_ON_Yest ( ncols,nrows,e2c_cats ), + & F1_ON ( ncols,nrows,e2c_cats ), + & F2_ON ( ncols,nrows,e2c_cats ), + & STAT = STAT ) + If ( STAT .Ne. 0 ) Then + mesg = 'Failure allocating organic N vars' + Call M3EXIT( PNAME, 0, 0, mesg, XSTAT1 ) + End If + + If( MOD(cio_model_sdate,1000) .Eq. 1 ) Then + If( MOD(cio_model_sdate,4000) .Eq. 0 .And. + & MOD(cio_model_sdate,100000) .Ne. 0 ) Then + jdate_yest = (INT(cio_model_sdate/1000)-1)*1000+366 + Else If( MOD(cio_model_sdate,400000) .Eq. 0) Then + jdate_yest = (INT(cio_model_sdate/1000)-1)*1000+366 + Else ! not a leap year + jdate_yest = (INT(cio_model_sdate/1000)-1)*1000+365 + End If + Else + jdate_yest = cio_model_sdate-1 + End If + + If ( .Not. Open3( E2C_CHEM_YEST, fsread3, pname ) ) Then + mesg = 'Could not open '// E2C_CHEM_YEST // ' file' + Call M3exit ( pname, 0, 0, mesg, xstat1 ) + End If + n_opened_file = n_opened_file + 1 + + IF ( .NOT. DESC3( E2C_CHEM_YEST ) ) THEN + MESG = 'Could not get description of file "' // + & TRIM( E2C_CHEM_YEST ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + + call subhfile ( E2C_CHEM, gxoff, gyoff, + & startcol, endcol, startrow, endrow ) + + vname = 'L1_AON' + If ( .Not. Xtract3 (E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, F1_ON ) ) Then + Write( mesg,9001 ) vname, E2C_CHEM + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L2_AON' + If ( .Not. Xtract3 (E2C_CHEM, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, cio_model_sdate, 0, F2_ON ) ) Then + Write( mesg,9001 ) vname, E2C_CHEM + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + call subhfile ( E2C_CHEM_YEST, gxoff, gyoff, + & startcol, endcol, startrow, endrow ) + + vname = 'L1_ON' + If ( .Not. Xtract3 (E2C_CHEM_YEST, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, jdate_yest, 0, L1_ON_Yest ) ) Then + Write( mesg,9001 ) vname, E2C_CHEM + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + + vname = 'L2_ON' + If ( .Not. Xtract3 (E2C_CHEM_YEST, vname, 1, e2c_cats, startrow, endrow, + & startcol, endcol, jdate_yest, 0, L2_ON_Yest ) ) Then + Write( mesg,9001 ) vname, E2C_CHEM + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + End If + end if ! .not. GMN_AVAIL + end if ! MEDC_AVAIL + +9001 Format( 'Failure reading ', a, 1x, 'from ', a ) + +#endif ! end if stage option +#endif ! end if m3dry option + + end subroutine depv_data_setup + +! ------------------------------------------------------------------------- + subroutine medc_file_setup + + USE UTILIO_DEFN + use bidi_mod + + INCLUDE SUBST_FILES_ID ! file name parameters + + Character( 40 ), parameter :: pname = 'medc_file_setup' + + CHARACTER( 256 ) :: xmsg + integer :: v + integer :: startcol, endcol, startrow, endrow, gxoff, gyoff + + CALL INIT_BIDI( ) + + IF ( .NOT. OPEN3( INIT_MEDC_1, FSREAD3, PNAME ) ) THEN + XMSG = 'Open failure for ' // INIT_MEDC_1 + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + n_opened_file = n_opened_file + 1 + + call subhfile ( INIT_MEDC_1, gxoff, gyoff, + & startcol, endcol, startrow, endrow ) + + DO v = 1, Hg_TOT + IF ( .NOT. Xtract3( INIT_MEDC_1, MEDIA_NAMES( V ), 1, 1, + & startrow, endrow, startcol, endcol, + & cio_model_sdate, 0, CMEDIA(:,:,v) ) )THEN + xmsg = 'Could not read ' // trim( MEDIA_NAMES( V ) ) + & // ' from ' // trim( INIT_MEDC_1 ) + call m3exit( pname, cio_model_sdate, 0, xmsg, xstat1 ) + END IF + END DO + + end subroutine medc_file_setup + +! ------------------------------------------------------------------------- + subroutine soilinp_setup + + USE UTILIO_DEFN + use HGRD_DEFN, only : ncols, nrows + use RUNTIME_VARS, only : NEW_START,BIOGEMIS_MEGAN,BIOGEMIS_BEIS, + & BDSNP_MEGAN,IGNORE_SOILINP + + + INCLUDE SUBST_FILES_ID ! file name parameters + + integer, parameter :: mxhrs = 24 + Character( 40 ), parameter :: pname = 'soilinp_setup' + Character( 40 ), parameter :: msoilinp = 'MEGAN_SOILINP' + Character( 40 ), parameter :: bsoilinp = 'BEIS_SOILINP' + Character( 40 ), parameter :: bdsnpinp = 'BDSNPINP' + + CHARACTER( 16 ) :: var + CHARACTER( 256 ) :: mesg + integer :: stat, i, j, k + real t24sum(ncols,nrows),sw24sum(ncols,nrows) + + ALLOCATE( PTYPE( NCOLS,NROWS ), + & PULSEDATE( NCOLS,NROWS ), + & PULSETIME( NCOLS,NROWS ), + & RAINFALL( NCOLS,NROWS, mxhrs ), + & DDTTM( mxhrs ), + & STAT=STAT ) + + DDTTM = ' ' ! array + + if (BIOGEMIS_MEGAN) then + ALLOCATE (t24y ( ncols,nrows ), + & sw24y ( ncols,nrows ), + & lai_y ( ncols,nrows ), + & HRNO_SW ( NCOLS,NROWS, mxhrs ), + & HRNO_T2M ( NCOLS,NROWS, mxhrs ), + & stat=stat) + if (BDSNP_MEGAN) then + ALLOCATE (PFACTOR ( ncols,nrows ), + & DRYPERIOD ( ncols,nrows ), + & NDEPRES ( ncols,nrows ), + & NDEPRATE ( ncols,nrows ), + & SOILMPREV ( ncols,nrows ), + & stat=stat) + pfactor = 0.0 + dryperiod = 0.0 + soilmprev = 0.0 + ndepres =0.0 + ndeprate =0.0 + end if + + IF ( STAT .NE. 0 ) THEN + MESG = 'Failure BIOGEMIS_MEGAN arrays' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT3 ) + END IF + end if + + + if (BIOGEMIS_BEIS .and. .not. NEW_START .and. .not. IGNORE_SOILINP) then + IF ( .NOT. OPEN3( BSOILINP, FSREAD3, PNAME ) ) THEN + mesg = 'Open failure for ' // BSOILINP + Call M3EXIT( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + n_opened_file = n_opened_file + 1 + +! Get description of NO rain data file + IF ( .NOT. DESC3( BSOILINP ) ) THEN + MESG = 'Could not get description of file "' // + & TRIM( BSOILINP ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + +! Check that the file start date and time are consistent + IF ( SDATE3D .NE. cio_model_sdate ) THEN + WRITE( MESG, 94011 ) 'Cannot use BEIS_SOILINP file; ' // + & 'found date ', SDATE3D, ' expecting ', cio_model_sdate + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + + IF ( STIME3D .NE. cio_model_stime ) THEN + WRITE( MESG, 94011 ) 'Cannot use BEIS_SOILINP file; ' // + & 'found time ', STIME3D, ' expecting ', cio_model_stime + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + +94011 FORMAT( A, F10.2, 1X, A, I3, ',', I3 ) + + VAR = 'PTYPE' + IF ( .NOT. XTRACT3( BSOILINP, 'PTYPE', 1, 1, + & STRTROWSTD, ENDROWSTD, STRTCOLSTD, ENDCOLSTD, + & 0, 0, PTYPE ) ) THEN + MESG = 'Could not read "' // TRIM( VAR ) // + & '" from file "' // TRIM( BSOILINP ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + + VAR = 'PULSEDATE' + IF ( .NOT. XTRACT3( BSOILINP, VAR, 1, 1, + & STRTROWSTD, ENDROWSTD, STRTCOLSTD, ENDCOLSTD, + & 0, 0, PULSEDATE ) ) THEN + MESG = 'Could not read "' // TRIM( VAR ) // + & '" from file "' // TRIM( BSOILINP ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + + VAR = 'PULSETIME' + IF ( .NOT. XTRACT3( BSOILINP, VAR, 1, 1, + & STRTROWSTD, ENDROWSTD, STRTCOLSTD, ENDCOLSTD, + & 0, 0, PULSETIME ) ) THEN + MESG = 'Could not read "' // TRIM( VAR ) // + & '" from file "' // TRIM( BSOILINP ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + + + RAINFALL = 0.0 + + DDTTM = ' ' ! array + DO I = 1, mxhrs + WRITE( VAR, '(A8,I2.2)' ) 'RAINFALL', I + IF ( .NOT. XTRACT3( BSOILINP, VAR, 1, 1, + & STRTROWSTD, ENDROWSTD, STRTCOLSTD, ENDCOLSTD, + & 0, 0, RAINFALL( :,:,I ) ) ) THEN + MESG = 'Could not read "' // TRIM( VAR ) // + & '" from file "' // TRIM( BSOILINP ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + J = INDEX( VDESC3D( I+3 ), 'for' ) + 3 + K = LEN_TRIM( VDESC3D( I+3 ) ) + DDTTM( I ) = VDESC3D( I+3 )( J:K ) + END DO + + end if ! end beis section + + + if (BIOGEMIS_MEGAN .and. .not. NEW_START .and. .not. IGNORE_SOILINP) then + + IF ( .NOT. OPEN3( MSOILINP, FSREAD3, PNAME ) ) THEN + mesg = 'Open failure for ' // MSOILINP + Call M3EXIT( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + n_opened_file = n_opened_file + 1 + +! Get description of NO rain data file + IF ( .NOT. DESC3( MSOILINP ) ) THEN + MESG = 'Could not get description of file "' // + & TRIM( MSOILINP ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + +! Check that the file start date and time are consistent + IF ( SDATE3D .NE. cio_model_sdate ) THEN + WRITE( MESG, 94010 ) 'Cannot use MEGAN_SOILINP file; ' // + & 'found date ', SDATE3D, ' expecting ', cio_model_sdate + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + + IF ( STIME3D .NE. cio_model_stime ) THEN + WRITE( MESG, 94010 ) 'Cannot use MEGAN_SOILINP file; ' // + & 'found time ', STIME3D, ' expecting ', cio_model_stime + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + +94010 FORMAT( A, F10.2, 1X, A, I3, ',', I3 ) + + VAR = 'PTYPE' + IF ( .NOT. XTRACT3( MSOILINP, 'PTYPE', 1, 1, + & STRTROWSTD, ENDROWSTD, STRTCOLSTD, ENDCOLSTD, + & 0, 0, PTYPE ) ) THEN + MESG = 'Could not read "' // TRIM( VAR ) // + & '" from file "' // TRIM( MSOILINP ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + + VAR = 'PULSEDATE' + IF ( .NOT. XTRACT3( MSOILINP, VAR, 1, 1, + & STRTROWSTD, ENDROWSTD, STRTCOLSTD, ENDCOLSTD, + & 0, 0, PULSEDATE ) ) THEN + MESG = 'Could not read "' // TRIM( VAR ) // + & '" from file "' // TRIM( MSOILINP ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + + VAR = 'PULSETIME' + IF ( .NOT. XTRACT3( MSOILINP, VAR, 1, 1, + & STRTROWSTD, ENDROWSTD, STRTCOLSTD, ENDCOLSTD, + & 0, 0, PULSETIME ) ) THEN + MESG = 'Could not read "' // TRIM( VAR ) // + & '" from file "' // TRIM( MSOILINP ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + + sw24sum = 0.0 + t24sum = 0.0 + lai_y = 0.0 + RAINFALL = 0.0 + + DDTTM = ' ' ! array + DO I = 1, mxhrs + WRITE( VAR, '(A8,I2.2)' ) 'RAINFALL', I + IF ( .NOT. XTRACT3( MSOILINP, VAR, 1, 1, + & STRTROWSTD, ENDROWSTD, STRTCOLSTD, ENDCOLSTD, + & 0, 0, RAINFALL( :,:,I ) ) ) THEN + MESG = 'Could not read "' // TRIM( VAR ) // + & '" from file "' // TRIM( MSOILINP ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + J = INDEX( VDESC3D( I+3 ), 'for' ) + 3 + K = LEN_TRIM( VDESC3D( I+3 ) ) + DDTTM( I ) = VDESC3D( I+3 )( J:K ) + + WRITE( VAR, '(A2,I2.2)' ) 'SW', I + IF ( .NOT. XTRACT3( MSOILINP, VAR, 1, 1, + & STRTROWSTD, ENDROWSTD, STRTCOLSTD,ENDCOLSTD, + & 0, 0, sw24y( :,: ) ) ) THEN + MESG = 'Could not read "' // TRIM( VAR ) // + & '" from file "' // TRIM( MSOILINP ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + sw24sum = sw24y + sw24sum + + WRITE( VAR, '(A3,I2.2)' ) 'T2M', I + IF ( .NOT. XTRACT3( MSOILINP, VAR, 1, 1, + & STRTROWSTD, ENDROWSTD, STRTCOLSTD,ENDCOLSTD, + & 0, 0, t24y( :,: ) ) ) THEN + MESG = 'Could not read "' // TRIM( VAR ) // + & '" from file "' // TRIM( MSOILINP ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + t24sum = t24y + t24sum + + END DO ! looping over 24 hrs + + sw24y = sw24sum/mxhrs + t24y = t24sum/mxhrs + + IF ( .NOT. XTRACT3( MSOILINP, 'LAI', 1, 1, + & STRTROWSTD, ENDROWSTD, STRTCOLSTD,ENDCOLSTD, + & 0, 0, lai_y( :,: ) ) ) THEN + MESG = 'Could not read "' // 'LAI' // + & '" from file "' // TRIM( MSOILINP ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT2 ) + END IF + + if (BDSNP_MEGAN) then + ! BDSNP daily inputs + + IF ( .NOT. OPEN3( BDSNPINP, FSREAD3, PNAME ) ) THEN + mesg = 'Open failure for ' // BDSNPINP + Call M3EXIT( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + + IF ( .NOT. DESC3( BDSNPINP ) ) THEN + MESG = 'Could not get description of file "' // + & TRIM( BDSNPINP ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT1 ) + END IF + IF ( .NOT. XTRACT3( BDSNPINP, 'DRYPERIOD', + & 1, 1, STRTROWSTD, ENDROWSTD, STRTCOLSTD,ENDCOLSTD, + & 0, 0, dryperiod(:,:) ) ) THEN + mesg = 'Could not extract ' // BDSNPINP // ' file' + CALL M3EXIT ( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + IF ( .NOT. XTRACT3( BDSNPINP, 'NDEPRES', + & 1, 1, STRTROWSTD, ENDROWSTD, STRTCOLSTD,ENDCOLSTD, + & 0, 0, ndepres(:,:) ) ) THEN + mesg = 'Could not extract ' // BDSNPINP // ' file' + CALL M3EXIT ( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + IF ( .NOT. XTRACT3( BDSNPINP, 'NDEPRATE_DIAG', + & 1, 1, STRTROWSTD, ENDROWSTD, STRTCOLSTD,ENDCOLSTD, + & 0, 0, ndeprate(:,:) ) ) THEN + mesg = 'Could not extract ' // BDSNPINP // ' file' + CALL M3EXIT ( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + IF ( .NOT. XTRACT3( BDSNPINP, 'PFACTOR', + & 1, 1, STRTROWSTD, ENDROWSTD, STRTCOLSTD,ENDCOLSTD, + & 0, 0, pfactor(:,:) ) ) THEN + mesg = 'Could not extract ' // BDSNPINP // ' file' + CALL M3EXIT ( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + IF ( .NOT. XTRACT3( BDSNPINP, 'SOILMPREV', + & 1, 1, STRTROWSTD, ENDROWSTD,STRTCOLSTD,ENDCOLSTD, + & 0, 0, soilmprev(:,:) ) ) THEN + mesg = 'Could not extract ' // BDSNPINP // ' file' + CALL M3EXIT ( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + + + end if ! bdsnp check + end if ! megan check + + + end subroutine soilinp_setup + +! ------------------------------------------------------------------------- + subroutine retrieve_grid_cro_2d_data + + USE UTILIO_DEFN + USE HGRD_DEFN + USE LSM_Mod, ONLY: n_lufrac, init_lsm + + INCLUDE SUBST_FILES_ID ! file name parameters + + Character( 40 ), parameter :: pname = 'retrieve_grid_cro_2d_data' + integer :: gxoff, gyoff, + & STRTCOLGC2, ENDCOLGC2, STRTROWGC2, ENDROWGC2 + + CHARACTER( 120 ) :: XMSG = ' ' + Character( 16 ) :: vname + INTEGER :: STAT, L + + allocate (MSFX2(ncols, nrows), + & LWMASK(ncols, nrows), + & HT(ncols, nrows), + & LAT(ncols, nrows), + & LON(ncols, nrows), + & PURB(ncols, nrows), + & STAT=STAT) + IF ( STAT .NE. 0 ) THEN + XMSG = 'Failure allocating MSFX2 or other arrays' + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT3 ) + END IF + + CALL SUBHFILE ( GRID_CRO_2D, GXOFF, GYOFF, + & STRTCOLGC2, ENDCOLGC2, STRTROWGC2, ENDROWGC2 ) + +#ifdef twoway + IF ( .NOT. INTERPX( GRID_CRO_2D, 'MSFX2', PNAME, + & STRTCOLGC2, ENDCOLGC2, STRTROWGC2, ENDROWGC2, 1, 1, + & 0, 0, MSFX2 ) ) THEN + XMSG = ' Error interpolating variable MSFX2 from ' // GRID_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + IF ( .NOT. INTERPX( GRID_CRO_2D, 'LWMASK', PNAME, + & STRTCOLGC2, ENDCOLGC2, STRTROWGC2, ENDROWGC2, 1, 1, + & 0, 0, LWMASK ) ) THEN + XMSG = ' Error interpolating variable LWMASK from ' // GRID_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + IF ( .NOT. INTERPX( GRID_CRO_2D, 'HT', PNAME, + & STRTCOLGC2, ENDCOLGC2, STRTROWGC2, ENDROWGC2, 1, 1 , + & 0, 0, HT ) ) THEN + XMSG = ' Error interpolating variable HT from ' // GRID_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + IF ( .NOT. INTERPX( GRID_CRO_2D, 'LAT', PNAME, + & STRTCOLGC2, ENDCOLGC2, STRTROWGC2, ENDROWGC2, 1, 1 , + & 0, 0, LAT ) ) THEN + XMSG = ' Error interpolating variable LAT from ' // GRID_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + IF ( .NOT. INTERPX( GRID_CRO_2D, 'LON', PNAME, + & STRTCOLGC2, ENDCOLGC2, STRTROWGC2, ENDROWGC2, 1, 1 , + & 0, 0, LON ) ) THEN + XMSG = ' Error interpolating variable LON from ' // GRID_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + if (minkz) then + IF ( .NOT. INTERPX( GRID_CRO_2D, 'PURB', PNAME, + & STRTCOLGC2, ENDCOLGC2, STRTROWGC2, ENDROWGC2, 1, 1 , + & 0, 0, PURB ) ) THEN + XMSG = ' Error interpolating variable PURB from ' // GRID_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + else + purb = 0.0 + end if + + IF ( .NOT. LUCRO_AVAIL ) THEN + + CALL INIT_LSM( 0, 0 ) + + allocate (LUFRAC(ncols, nrows, n_lufrac), STAT=STAT) + IF ( STAT .NE. 0 ) THEN + XMSG = 'Failure allocating LUFRAC array' + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT3 ) + END IF + + DO l = 1, n_lufrac + Write( vname,'( "LUFRAC_",I2.2 )' ) l + IF ( .Not. INTERPX( GRID_CRO_2D, VNAME, PNAME, + & STRTCOLGC2, ENDCOLGC2, STRTROWGC2, ENDROWGC2, 1, 1, + & 0, 0, LUFRAC( :,:,l ) ) ) THEN + XMSG = 'Error interpolating variable' // TRIM( VNAME ) // ' from ' // GRID_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + END DO + + END IF + +#else + IF ( .NOT. XTRACT3( GRID_CRO_2D, 'MSFX2', + & 1, 1, STRTROWGC2, ENDROWGC2, STRTCOLGC2, ENDCOLGC2, + & 0, 0, MSFX2 ) ) THEN + XMSG = ' Error interpolating variable MSFX2 from ' // GRID_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + IF ( .NOT. XTRACT3( GRID_CRO_2D, 'LWMASK', + & 1, 1, STRTROWGC2, ENDROWGC2, STRTCOLGC2, ENDCOLGC2, + & 0, 0, LWMASK ) ) THEN + XMSG = ' Error interpolating variable LWMASK from ' // GRID_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + IF ( .NOT. XTRACT3( GRID_CRO_2D, 'HT', + & 1, 1, STRTROWGC2, ENDROWGC2, STRTCOLGC2, ENDCOLGC2, + & 0, 0, HT ) ) THEN + XMSG = ' Error interpolating variable HT from ' // GRID_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + IF ( .NOT. XTRACT3( GRID_CRO_2D, 'LAT', + & 1, 1, STRTROWGC2, ENDROWGC2, STRTCOLGC2, ENDCOLGC2, + & 0, 0, LAT ) ) THEN + XMSG = ' Error interpolating variable LAT from ' // GRID_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + IF ( .NOT. XTRACT3( GRID_CRO_2D, 'LON', + & 1, 1, STRTROWGC2, ENDROWGC2, STRTCOLGC2, ENDCOLGC2, + & 0, 0, LON ) ) THEN + XMSG = ' Error interpolating variable LON from ' // GRID_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + if (minkz) then + IF ( .NOT. XTRACT3( GRID_CRO_2D, 'PURB', + & 1, 1, STRTROWGC2, ENDROWGC2, STRTCOLGC2, ENDCOLGC2, + & 0, 0, PURB ) ) THEN + XMSG = ' Error interpolating variable PURB from ' // GRID_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + else + purb = 0.0 + end if + + IF ( .NOT. LUCRO_AVAIL ) THEN + + CALL INIT_LSM( 0, 0 ) + + allocate (LUFRAC(ncols, nrows, n_lufrac), STAT=STAT) + IF ( STAT .NE. 0 ) THEN + XMSG = 'Failure allocating LUFRAC array' + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT3 ) + END IF + + DO l = 1, n_lufrac + Write( vname,'( "LUFRAC_",I2.2 )' ) l + IF ( .Not. XTRACT3( GRID_CRO_2D, VNAME, + & 1, 1, STRTROWGC2, ENDROWGC2, STRTCOLGC2, ENDCOLGC2, + & 0, 0, LUFRAC( :,:,l ) ) ) THEN + XMSG = 'Error interpolating variable' // TRIM( VNAME ) // ' from ' // GRID_CRO_2D + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + END DO + + END IF +#endif + end subroutine retrieve_grid_cro_2d_data + +! ------------------------------------------------------------------------- + subroutine retrieve_grid_dot_2d_data + + USE UTILIO_DEFN + USE HGRD_DEFN + + INCLUDE SUBST_FILES_ID ! file name parameters + + Character( 40 ), parameter :: pname = 'retrieve_grid_dot_2d_data' + + INTEGER :: STAT + CHARACTER( 120 ) :: XMSG = ' ' + INTEGER :: gxoff, gyoff, + & STRTCOLGD2, ENDCOLGD2, STRTROWGD2, ENDROWGD2 + + ALLOCATE ( MSFD2( NCOLS+1, NROWS+1 ), STAT = STAT ) + IF ( STAT .NE. 0 ) THEN + XMSG = 'Failure allocating MSFD2 array' + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT3 ) + END IF + + CALL SUBHFILE ( GRID_DOT_2D, GXOFF, GYOFF, + & STRTCOLGD2, ENDCOLGD2, STRTROWGD2, ENDROWGD2 ) + +#ifdef twoway + IF ( .NOT. INTERPX( GRID_DOT_2D, 'MSFD2', PNAME, + & STRTCOLGD2, ENDCOLGD2, STRTROWGD2, ENDROWGD2, 1, 1, + & 0, 0, MSFD2 ) ) THEN + XMSG = 'Could not interpolate MSFD2 from ' // GRID_DOT_2D + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF +#else + IF ( .NOT. XTRACT3( GRID_DOT_2D, 'MSFD2', + & 1, 1, STRTROWGD2, ENDROWGD2, STRTCOLGD2, ENDCOLGD2, + & 0, 0, MSFD2 ) ) THEN + XMSG = 'Could not interpolate MSFD2 from ' // GRID_DOT_2D + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF +#endif + end subroutine retrieve_grid_dot_2d_data + +! ------------------------------------------------------------------------- + subroutine retrieve_ocean_data + + USE RXNS_DATA, ONLY : MECHNAME + USE UTILIO_DEFN + USE HGRD_DEFN + + INCLUDE SUBST_FILES_ID ! file name parameters + + Character( 40 ), parameter :: pname = 'retrieve_ocean_data' + integer :: startcol, endcol, startrow, endrow, gxoff, gyoff + + INTEGER :: STAT + CHARACTER( 120 ) :: XMSG = ' ' + + allocate (ocean(ncols, nrows), + & szone(ncols, nrows), + & chlr(ncols, nrows), + & dmsl(ncols, nrows), + & STAT=STAT) + IF ( STAT .NE. 0 ) THEN + XMSG = 'Failure allocating OPEN, SURF, CHLO, DMS array' + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT3 ) + END IF + + IF ( .NOT. OCEAN_CHEM ) THEN + + WRITE( LOGDEV, '(/,5x,A,/,5x,A,/5x,A)' ), + & 'CTM_OCEAN_CHEM set to FALSE. Open ocean and surf zone', + & 'fractions will be set to 0. There will be no oceanic', + & 'halogen-mediated loss of ozone, dms chemistry, or sea spray aerosol emissions.' + ocean = 0.0 + szone = 0.0 + dmsl = 0.0 + chlr = 0.0 + + If ( INDEX( MECHNAME, 'CB6R5M_AE7_AQ' ) .GT. 0 ) then + XMSG = 'CTM_OCEAN_CHEM must be set to TRUE when using CB6R5M_AE7_AQ mechanism' + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + endif + + ELSEIF ( OCEAN_CHEM .AND. .NOT. USE_MARINE_GAS_EMISSION ) THEN + + IF ( .NOT. OPEN3( OCEAN_1, FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open ' // OCEAN_1 + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + ELSE + n_opened_file = n_opened_file + 1 + + call subhfile ( OCEAN_1, gxoff, gyoff, + & startcol, endcol, startrow, endrow ) + + IF ( .NOT. XTRACT3( OCEAN_1, 'OPEN', + & 1, 1, startrow, endrow, startcol, endcol, + & 0, 0, ocean ) ) Then + XMSG = 'Could not read OPEN from ' // OCEAN_1 + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + IF ( .NOT. XTRACT3( OCEAN_1, 'SURF', + & 1, 1, startrow, endrow, startcol, endcol, + & 0, 0, szone ) ) Then + XMSG = 'Could not interpolate SURF from ' // OCEAN_1 + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + WHERE ( ocean .LT. 0.001 ) ocean = 0.0 ! ensure values are nonnegative and greater than 0.001 + WHERE ( szone .LT. 0.001 ) szone = 0.0 ! ensure values are nonnegative and greater than 0.001 + + dmsl = 0.0 + chlr = 0.0 + + ENDIF + + ELSEIF ( OCEAN_CHEM .AND. USE_MARINE_GAS_EMISSION ) THEN + + IF ( .NOT. OPEN3( OCEAN_1, FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open ' // OCEAN_1 + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + ELSE + n_opened_file = n_opened_file + 1 + + call subhfile ( OCEAN_1, gxoff, gyoff, + & startcol, endcol, startrow, endrow ) + + IF ( .NOT. XTRACT3( OCEAN_1, 'OPEN', + & 1, 1, startrow, endrow, startcol, endcol, + & 0, 0, ocean ) ) Then + XMSG = 'Could not read OPEN from ' // OCEAN_1 + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + IF ( .NOT. XTRACT3( OCEAN_1, 'SURF', + & 1, 1, startrow, endrow, startcol, endcol, + & 0, 0, szone ) ) Then + XMSG = 'Could not interpolate SURF from ' // OCEAN_1 + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + + WHERE ( ocean .LT. 0.001 ) ocean = 0.0 ! ensure values are nonnegative and greater than 0.001 + WHERE ( szone .LT. 0.001 ) szone = 0.0 ! ensure values are nonnegative and greater than 0.001 + + If ( INDEX( MECHNAME, 'CB6R5M_AE7_AQ' ) .GT. 0 ) then + + If ( .Not. XTRACT3( OCEAN_1, 'CHLO', + & 1, 1, startrow, endrow, startcol, endcol, + & 0, 0, chlr ) ) Then + XMSG = 'Could not read CHLO from ' // OCEAN_1 + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + End If + + If ( .Not. XTRACT3( OCEAN_1, 'DMS', + & 1, 1, startrow, endrow, startcol, endcol, + & 0, 0, dmsl ) ) Then + XMSG = 'Could not read DMS from ' // OCEAN_1 + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + End If + + ELSEIF ( INDEX( MECHNAME, 'CB6R5_AE7_AQ' ) .GT. 0 ) then + + chlr = 0.0 + + If ( .Not. XTRACT3( OCEAN_1, 'DMS', + & 1, 1, startrow, endrow, startcol, endcol, + & 0, 0, dmsl ) ) Then + XMSG = 'Could not read DMS from ' // OCEAN_1 + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + End If + + END IF + + END IF + END IF + + end subroutine retrieve_ocean_data + +! ------------------------------------------------------------------------- + subroutine retrieve_ltng_param_data + + USE UTILIO_DEFN + USE HGRD_DEFN + + INCLUDE SUBST_FILES_ID ! file name parameters + + Character( 40 ), parameter :: pname = 'retrieve_ltng_param_data' + Character( 40 ), parameter :: LTNGPARMS_FILE = 'LTNGPARMS_FILE' + + INTEGER :: STAT + CHARACTER( 120 ) :: XMSG = ' ' + integer :: startcol, endcol, startrow, endrow, gxoff, gyoff + + allocate (OCEAN_MASK(ncols, nrows), + & SLOPE(ncols, nrows), + & INTERCEPT(ncols, nrows), + & SLOPE_lg(ncols, nrows), + & INTERCEPT_lg(ncols, nrows), + & ICCG_SUM(ncols, nrows), + & ICCG_WIN(ncols, nrows), + & STAT=STAT) + IF ( STAT .NE. 0 ) THEN + XMSG = 'Failure allocating ltng parameter arrays' + CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT3 ) + END IF + + IF ( .NOT. OPEN3( LTNGPARMS_FILE, FSREAD3, PNAME ) ) THEN + XMSG = 'Open failure for ' // LTNGPARMS_FILE + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + END IF + n_opened_file = n_opened_file + 1 + + call subhfile ( LTNGPARMS_FILE, gxoff, gyoff, + & startcol, endcol, startrow, endrow ) + + IF ( .NOT. XTRACT3( LTNGPARMS_FILE, "OCNMASK", 1, 1, + & startrow, endrow, startcol, endcol, + & 0, 0, OCEAN_MASK ) ) Then + XMSG = 'Could not interpolate OPEN from ' // LTNGPARMS_FILE + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + End If + + IF ( .NOT. XTRACT3( LTNGPARMS_FILE, "SLOPE", 1, 1, + & startrow, endrow, startcol, endcol, + & 0, 0, SLOPE ) ) Then + XMSG = 'Could not interpolate OPEN from ' // LTNGPARMS_FILE + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + End If + + IF ( .NOT. XTRACT3( LTNGPARMS_FILE, "INTERCEPT", 1, 1, + & startrow, endrow, startcol, endcol, + & 0, 0, INTERCEPT ) ) Then + XMSG = 'Could not interpolate OPEN from ' // LTNGPARMS_FILE + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + End If + + IF ( .NOT. XTRACT3( LTNGPARMS_FILE, "SLOPE_lg", 1, 1, + & startrow, endrow, startcol, endcol, + & 0, 0, SLOPE_lg ) ) Then + XMSG = 'Could not interpolate OPEN from ' // LTNGPARMS_FILE + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + End If + + IF ( .NOT. XTRACT3( LTNGPARMS_FILE, "INTERCEPT_lg", 1, 1, + & startrow, endrow, startcol, endcol, + & 0, 0, INTERCEPT_lg ) ) Then + XMSG = 'Could not interpolate OPEN from ' // LTNGPARMS_FILE + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + End If + + IF ( .NOT. XTRACT3( LTNGPARMS_FILE, "ICCG_SUM", 1, 1, + & startrow, endrow, startcol, endcol, + & 0, 0, ICCG_SUM ) ) Then + XMSG = 'Could not interpolate OPEN from ' // LTNGPARMS_FILE + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + End If + + IF ( .NOT. XTRACT3( LTNGPARMS_FILE, "ICCG_WIN", 1, 1, + & startrow, endrow, startcol, endcol, + & 0, 0, ICCG_WIN ) ) Then + XMSG = 'Could not interpolate OPEN from ' // LTNGPARMS_FILE + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + End If + + end subroutine retrieve_ltng_param_data + +! ------------------------------------------------------------------------- + subroutine retrieve_boundary_data (jdate, jtime, vname) + + USE UTILIO_DEFN + USE HGRD_DEFN + USE VGRD_DEFN, ONLY : NLAYS + USE CGRID_SPCS + + INCLUDE SUBST_FILES_ID ! file name parameters + + integer, intent(in) :: jdate, jtime + character (*), intent(in), optional :: vname + + Character( 40 ), parameter :: pname = 'retrieve_boundary_data' + + LOGICAL, SAVE :: firstime = .true. + INTEGER :: STAT, i, j, begin, end, buf_loc, iterations, + & iter, loc_jdate_met, loc_jdate, loc_jtime_met, + & loc_jtime, v, beg_v, end_v + + CHARACTER( 120 ) :: XMSG = ' ' + + if (firstime) then + + head_bndy = -1 + tail_bndy = -1 + + end if ! firstime + + if (firstime) then + iterations = 2 + else + iterations = 1 + end if + + if (present(vname)) then + beg_v = binary_search (vname, cio_bndy_var_name(:,1), n_cio_bndy_vars) + end_v = beg_v + else + beg_v = 1 + end_v = n_cio_bndy_vars + end if + + loc_jdate = jdate + loc_jdate_met = jdate + loc_jtime = jtime + loc_jtime_met = jtime + + do iter = 1, iterations + do v = beg_v, end_v + buf_loc = mod((tail_bndy(v) + iter), 2) + + cio_bndy_data_tstamp(1, buf_loc, v) = loc_jdate + if (cio_bndy_var_name(v,2) == 'mb') then + cio_bndy_data_tstamp(2, buf_loc, v) = loc_jtime_met + else + cio_bndy_data_tstamp(2, buf_loc, v) = loc_jtime + end if + + begin = cio_bndy_data_inx(1,buf_loc,v) + end = cio_bndy_data_inx(2,buf_loc,v) + + if (cio_bndy_var_name(v,2) == 'mb') then +#ifdef twoway + cio_bndy_data(begin:end) = 0.0 +#else + if (.not. read3 (MET_BDY_3D, cio_bndy_var_name(v,1), -1, + & loc_jdate_met, loc_jtime_met, cio_bndy_data(begin:end) ) ) THEN + XMSG = 'Could not read ' // MET_BDY_3D // ' file' + CALL M3EXIT ( PNAME, loc_jdate_met, loc_jtime_met, XMSG, XSTAT1 ) + END IF +#endif + else if (cio_bndy_var_name(v,2) == 'bct') then + + if (.not. read3 (BCFILE, cio_bndy_var_name(v,1), -1, + & loc_jdate, loc_jtime, cio_bndy_data(begin:end) ) ) THEN + XMSG = 'Could not read ' // BCFILE // ' file' + CALL M3EXIT ( PNAME, loc_jdate, loc_jtime, XMSG, XSTAT1 ) + END IF + + else if (cio_bndy_var_name(v,2) == 'bc') then + + if (iter == 1) then + if (.not. read3 (BCFILE, cio_bndy_var_name(v,1), -1, + & loc_jdate, loc_jtime, cio_bndy_data(begin:end) ) ) THEN + XMSG = 'Could not read ' // BCFILE // ' file' + CALL M3EXIT ( PNAME, loc_jdate, loc_jtime, XMSG, XSTAT1 ) + END IF + else + cio_bndy_data_tstamp(1, buf_loc, v) = jdate + 999 ! this will ensure future never falls out of the circular buffer + end if + + else + call m3exit( 'Centralized I/O',0,0,' ==d== UNKOWNi Type of File',1 ) + end if + + end do + + CALL NEXTIME ( loc_jdate_met, loc_jtime_met, file_tstep(f_met)) + CALL NEXTIME ( loc_jdate, loc_jtime, file_tstep(f_bcon)) + + end do ! end iter + + if (firstime) then + firstime = .false. + head_bndy = 0 + tail_bndy = 1 + else + do v = beg_v, end_v + head_bndy(v) = mod(head_bndy(v)+1, 2) + tail_bndy(v) = mod(tail_bndy(v)+1, 2) + end do + end if + + end subroutine retrieve_boundary_data + +! ------------------------------------------------------------------------- + subroutine retrieve_stack_data (jdate, jtime, fname, vname) + + USE UTILIO_DEFN + USE STK_PRMS, only : MY_STRT_SRC, MY_END_SRC + + INCLUDE SUBST_FILES_ID ! file name parameters + + integer, intent(in) :: jdate, jtime + character (*), intent(in), optional :: fname, vname + + Character( 40 ), parameter :: pname = 'retrieve_stack_data' + + LOGICAL, SAVE :: firstime = .true. + INTEGER :: STAT, i, j, begin, end, buf_loc, iterations, + & iter, loc_jdate, loc_jtime, v, beg_v, end_v, + & beg_pt, end_pt, pt, fnum + + CHARACTER( 120 ) :: XMSG = ' ' + + if (firstime) then + + head_stack_emis = -1 + tail_stack_emis = -1 + + iterations = 2 + else + iterations = 1 + end if + + if (present(vname)) then + beg_pt = binary_search (fname, cio_stack_file_name, NPTGRPS) + end_pt = beg_pt + beg_v = binary_search (vname, cio_stack_var_name(:,beg_pt), n_cio_stack_emis_vars(beg_pt)) + end_v = beg_v + else + beg_pt = 1 + end_pt = NPTGRPS + end if + + do pt = beg_pt, end_pt + + if (firstime) then + loc_jdate = jdate + if (file_sym_date(f_stk_emis(pt))) loc_jdate = file_sdate(f_stk_emis(pt)) ! Representative day check + loc_jtime = jtime + else + loc_jdate = jdate + loc_jtime = jtime + end if + + if (.not. present(vname)) then + beg_v = 1 + end_v = n_cio_stack_emis_vars(pt) + end if + +! cio_stack_emis_data_inx + + do iter = 1, iterations + + do v = beg_v, end_v + buf_loc = mod((tail_stack_emis(v, pt) + iter), 2) + + cio_stack_emis_data_tstamp(1, buf_loc, v, pt) = loc_jdate + cio_stack_emis_data_tstamp(2, buf_loc, v, pt) = loc_jtime + + begin = cio_stack_emis_data_inx(1, buf_loc, v, pt) + end = cio_stack_emis_data_inx(2, buf_loc, v, pt) + + if (begin .gt. 0) then + IF ( .NOT. XTRACT3( cio_stack_file_name(pt), cio_stack_var_name(v, pt), + & 1,1, MY_STRT_SRC( pt ),MY_END_SRC( pt), 1,1, + & loc_jdate, loc_jtime, cio_stack_data(begin:end) ) ) THEN + XMSG = 'Could not extract ' // cio_stack_file_name(pt) // ' file' + CALL M3EXIT ( PNAME, loc_jdate, loc_jtime, XMSG, XSTAT1 ) + END IF + end if + end do + + CALL NEXTIME ( loc_jdate, loc_jtime, file_tstep(f_stk_emis(pt)) ) + end do ! end iter + end do + + if (firstime) then + firstime = .false. + head_stack_emis = 0 + tail_stack_emis = 1 + else + do pt = beg_pt, end_pt + do v = beg_v, end_v + head_stack_emis(v, pt) = mod(head_stack_emis(v, pt)+1, 2) + tail_stack_emis(v, pt) = mod(tail_stack_emis(v, pt)+1, 2) + end do + end do + end if + + end subroutine retrieve_stack_data + +#endif + +! ------------------------------------------------------------------------- + subroutine lus_setup + +! Function: + +! Set-up land-use categories for dust. Allocate and fill in: +! -- lut array --> landuse category fraction +! -- ladut array --> % of desertland + + + use RUNTIME_VARS +! use UTILIO_DEFN + use lus_data_module ! Data module that contains info. on different land schemes + use HGRD_DEFN, only : ncols, nrows +#ifdef twoway + use twoway_data_module +#endif + + INCLUDE SUBST_FILES_ID ! file name parameters + + character (24), parameter :: strg = 'incorrect num_land_cat, ' + character (40), parameter :: pname = 'lus_setup' + + character (256) :: xmsg + integer :: i, err, strtcol1,endcol1, strtrow1, endrow1, + & strtcol2, endcol2, strtrow2, endrow2, gxoff1, + & gyoff1, gxoff2, gyoff2 + + lufile( 1 ) = grid_cro_2d + +#ifndef mpas +! if ( .not. lucro_avail ) then ! TRUE if LUFRAC file isn't there +! +! if ( .not. open3( lufile( 1 ), fsread3, pname ) ) then +! xmsg = 'could not open ' // trim( lufile( 1 ) ) +! call m3exit ( pname, 0, 0, xmsg, xstat1 ) +! end if +! n_opened_file = n_opened_file + 1 +! +! ! Retrieve domain decomposition offsets for first lufile +! call subhfile( lufile( 1 ), gxoff1, gyoff1, strtcol1, +! & endcol1, strtrow1, endrow1 ) +! +! +! end if + +#endif + + ! determine land_scheme from GRID_CRO_2D + +#ifdef twoway + +C mminlu and num_land_cat are WRF global variables + + select case( mminlu ) + + case( 'USGS24' ) + if ( num_land_cat .ne. 24 ) then + write( xmsg, '(a, i3, a )' ) strg, num_land_cat, + & ' for ' // trim( mminlu ) + call m3exit ( pname, stdate, sttime, xmsg, xstat1 ) + end if + dust_land_scheme = 'USGS24' + case( 'NLCD40' ) + if ( num_land_cat .ne. 40 ) then + write( xmsg, '(a, i3, a )' ) strg, num_land_cat, + & ' for ' // trim( mminlu ) + call m3exit ( pname, stdate, sttime, xmsg, xstat1 ) + end if + dust_land_scheme = 'NLCD40' + case( 'NLCD-MODIS' ) + if ( num_land_cat .ne. 50 ) then + write( xmsg, '(a, i3, a )' ) strg, num_land_cat, + & ' for ' // trim( mminlu ) + call m3exit ( pname, stdate, sttime, xmsg, xstat1 ) + end if + dust_land_scheme = 'NLCD-MODIS' + case( 'MODIFIED_IGBP_MODIS_NOAH' ) + if ( num_land_cat .ne. 20 ) then + write( xmsg, '(a, i3, a )' ) strg, num_land_cat, + & ' for ' // trim( mminlu ) + call m3exit ( pname, stdate, sttime, xmsg, xstat1 ) + end if + dust_land_scheme = 'MODIS_NOAH' + case( 'MODIS' ) + if ( num_land_cat .ne. 20 ) then + write( xmsg, '(a, i3, a )' ) strg, num_land_cat, + & ' for ' // trim( mminlu ) + call m3exit ( pname, stdate, sttime, xmsg, xstat1 ) + end if + dust_land_scheme = 'MODIS' + case default + xmsg = 'Land use scheme not supported' + call m3exit ( pname, stdate, sttime, xmsg, xstat1 ) + + end select + +#else +#ifdef mpas +! dust_land_scheme = mminlu_mpas +#else + dust_land_scheme = cio_dust_land_scheme ! land scheme found from grid_cro_2D 'DLUSE' var-desc +#endif +#endif + + select case( dust_land_scheme ) ! After land scheme is determined allocate number of land use categories & number of dustland categories from lus_data_module + + case( 'USGS24' ) ! If USGS34 + n_lucat = n_lucat_usgs24 + n_dlcat = n_dlcat_usgs24 + allocate( vnmlu( n_lucat ), + & vnmld( n_dlcat ), + & dmsk( n_dlcat ), + & dmap( n_dlcat+1 ), stat = err ) + if ( err .ne. 0 ) then + xmsg = '*** Error allocating vnmlu, vnmld, dmsk or dmap' + call m3exit ( pname, stdate, sttime, xmsg, xstat1 ) + end if + vnmlu = vnmlu_usgs24 ! array assignment + vnmld = vnmld_usgs24 ! array assignment + dmsk = dmsk_usgs24 ! array assignment + dmap = dmap_usgs24 ! array assignment + + case( 'MODIS' ) ! If MODIS + n_lucat = n_lucat_modis + n_dlcat = n_dlcat_modis + allocate( vnmlu( n_lucat ), + & vnmld( n_dlcat ), + & dmsk( n_dlcat ), + & dmap( n_dlcat+1 ), stat = err ) + if ( err .ne. 0 ) then + xmsg = '*** Error allocating vnmlu, vnmld, dmsk or dmap' + call m3exit ( pname, stdate, sttime, xmsg, xstat1 ) + end if + vnmlu = vnmlu_modis ! array assignment + vnmld = vnmld_modis ! array assignment + dmsk = dmsk_modis ! array assignment + dmap = dmap_modis ! array assignment + + case( 'NLCD40' ) ! If NLCD40 + n_lucat = n_lucat_nlcd40 + n_dlcat = n_dlcat_nlcd40 + allocate( vnmlu( n_lucat ), + & vnmld( n_dlcat ), + & dmsk( n_dlcat ), + & dmap( n_dlcat+1 ), stat = err ) + if ( err .ne. 0 ) then + xmsg = '*** Error allocating vnmlu, vnmld, dmsk or dmap' + call m3exit ( pname, stdate, sttime, xmsg, xstat1 ) + end if + vnmlu = vnmlu_nlcd40 ! array assignment + vnmld = vnmld_nlcd40 ! array assignment + dmsk = dmsk_nlcd40 ! array assignment + dmap = dmap_nlcd40 ! array assignment + + case( 'NLCD-MODIS', 'NLCD50' ) ! If NCLD-MODIS or NCLD50 + n_lucat = n_lucat_nlcd_modis + n_dlcat = n_dlcat_nlcd_modis + allocate( vnmlu( n_lucat ), + & vnmld( n_dlcat ), + & dmsk( n_dlcat ), + & dmap( n_dlcat+1 ), stat = err ) + if ( err .ne. 0 ) then + xmsg = '*** Error allocating vnmlu, vnmld, dmsk or dmap' + call m3exit ( pname, stdate, sttime, xmsg, xstat1 ) + end if + vnmlu = vnmlu_nlcd_modis ! array assignment + vnmld = vnmld_nlcd_modis ! array assignment + dmsk = dmsk_nlcd_modis ! array assignment + dmap = dmap_nlcd_modis ! array assignment + + case( 'MODIS_NOAH' ) ! If MODIS-NOAH + n_lucat = n_lucat_modis_noah + n_dlcat = n_dlcat_modis_noah + allocate( vnmlu( n_lucat ), + & vnmld( n_dlcat ), + & dmsk( n_dlcat ), + & dmap( n_dlcat+1 ), stat = err ) + if ( err .ne. 0 ) then + xmsg = '*** Error allocating vnmlu, vnmld, dmsk or dmap' + call m3exit ( pname, stdate, sttime, xmsg, xstat1 ) + end if + vnmlu = vnmlu_modis_noah ! array assignment + vnmld = vnmld_modis_noah ! array assignment + dmsk = dmsk_modis_noah ! array assignment + dmap = dmap_modis_noah ! array assignment + + case default ! Other land-schemes not supported + xmsg = 'Land use scheme not supported' + call m3exit ( pname, stdate, sttime, xmsg, xstat1 ) + + end select + +! Writing Landuse categories to logfiles + write( logdev,* ) ' ' + write( logdev,* ) ' Land use scheme is ', trim( dust_land_scheme ) + write( logdev,* ) ' n_lucat,n_dlcat: ', n_lucat, n_dlcat + write( logdev,* ) ' desert land categories ------------------------' + do i = 1, n_dlcat + write( logdev,* ) ' ', trim( vnmld( i )%name ), ' ', trim( vnmld( i )%desc ) + end do + write( logdev,* ) ' land use categories ---------------------------' + do i = 1, n_lucat + write( logdev,* ) ' ', trim( vnmlu( i )%name ), ' ', trim( vnmlu( i )%desc ) + end do + write( logdev,* ) ' ' + + allocate( ladut( ncols,nrows,n_dlcat ), + & lut( ncols,nrows,n_lucat ), + & uland( ncols,nrows,4 ), stat = err ) + if ( err .ne. 0 ) then + xmsg = '*** Error allocating ladut, lut or uland' + call m3exit ( pname, stdate, sttime, xmsg, xstat1 ) + end if + + if ( .not. lucro_avail ) then ! TRUE if LUFRAC file isn't there or the land scheme is beld + +#ifdef mpas +! do i = 1, n_dlcat ! Loop through the number of desertland categories and fill in ladut array +! ladut( :,:,i) = lufrac( :,:,vnmld( i )%lu_idx ) ! Use mapped index in LUFRAC from lus_data_module to fill in ladut +! end do +! +! lut = lufrac ! landuse category fraction is lufrac that is already been extracted + +#else +! Get desert land (fraction) data (assume if BELD, all desert types are in file 1) + do i = 1, n_dlcat +#ifdef twoway + if ( .not. interpx( lufile( 1 ), vnmld( i )%name, pname, + & strtcol1, endcol1, strtrow1, endrow1, + & 1, 1, 0, 0, ladut( :,:,i ) ) ) then + xmsg = 'Could not read ' // trim( vnmld( i )%name ) + & // ' from ' // trim( lufile( 1 ) ) + call m3exit( pname, cio_model_sdate, cio_model_stime, xmsg, xstat1 ) + end if +#else + if ( .not. xtract3( lufile( 1 ), vnmld( i )%name, 1,1, + & strtrow1, endrow1,strtcol1, endcol1, + & 0, 0, ladut( :,:,i ) ) ) then + xmsg = 'Could not read ' // trim( vnmld( i )%name ) + & // ' from ' // trim( lufile( 1 ) ) + call m3exit( pname, cio_model_sdate, cio_model_stime, xmsg, xstat1 ) + end if +#endif + end do + +! Get land use (fraction) data + do i = 1, n_lucat-1 +#ifdef twoway + if ( .not. interpx( lufile( 1 ), vnmlu( i )%name, pname, + & strtcol1, endcol1, strtrow1, endrow1, + & 1, 1, 0, 0, lut( :,:,i ) ) ) then + xmsg = 'Could not read ' // trim( vnmlu( i )%name ) + & // ' from ' // trim( lufile( 1 ) ) + call m3exit( pname, cio_model_sdate, cio_model_stime, xmsg, xstat1 ) + end if +#else + if ( .not. xtract3( lufile( 1 ), vnmlu( i )%name, 1,1, + & strtrow1, endrow1,strtcol1, endcol1, + & 0, 0, lut( :,:,i ) ) ) then + xmsg = 'Could not read ' // trim( vnmlu( i )%name ) + & // ' from ' // trim( lufile( 1 ) ) + call m3exit( pname, cio_model_sdate, cio_model_stime, xmsg, xstat1 ) + end if +#endif + end do + + i = n_lucat +#ifdef twoway + if ( .not. interpx( lufile( 1 ), vnmlu( i )%name, pname, + & strtcol1, endcol1, strtrow1, endrow1, + & 1, 1, 0, 0, lut( :,:,i ) ) ) then + xmsg = 'Could not read ' // trim( vnmlu( i )%name ) + & // ' from ' // trim( lufile( 1 ) ) + call m3exit( pname, cio_model_sdate, cio_model_stime, xmsg, xstat1 ) + end if +#else + if ( .not. xtract3( lufile( 1 ), vnmlu( i )%name, 1,1, + & strtrow1, endrow1,strtcol1, endcol1, + & 0, 0, lut( :,:,i ) ) ) then + xmsg = 'Could not read ' // trim( vnmlu( i )%name ) + & // ' from ' // trim( lufile( 1 ) ) + call m3exit( pname, cio_model_sdate, cio_model_stime, xmsg, xstat1 ) + end if +#endif +#endif + + else ! IF LUFRAC is there + + do i = 1, n_dlcat ! Loop through the number of desertland categories and fill in ladut array + + ladut( :,:,i) = lufrac( :,:,vnmld( i )%lu_idx ) ! Use mapped index in LUFRAC from lus_data_module to fill in ladut + + end do + + lut = lufrac ! landuse category fraction is lufrac that is already been extracted + + end if + + end subroutine lus_setup + +! ------------------------------------------------------------------------- + + subroutine megan_setup ! reads in variables from MEGAN_PARAMS (see file_inputs.txt and run script) + use hgrd_defn, only : ncols,nrows + USE UTILIO_DEFN + use RUNTIME_VARS, only : logdev, USE_MEGAN_LAI, BDSNP_MEGAN, + & MGN_ONLN_DEP + + integer :: stat, i, megan_hr, megan_day, strtcol, + & endcol, strtrow, endrow, gxoff, gyoff + + character( 20 ) :: loc_time_stamp + real :: t24sum(ncols),sw24sum(ncols) + character( 40 ), parameter :: pname = 'megan_setup' + + character( 40 ), parameter :: MEGAN_LDF = 'MEGAN_LDF' + character( 40 ), parameter :: MEGAN_LAI = 'MEGAN_LAI' + character( 40 ), parameter :: MEGAN_EFS = 'MEGAN_EFS' + character( 40 ), parameter :: MEGAN_CTS = 'MEGAN_CTS' + character( 40 ), parameter :: BDSNP_NFILE = 'BDSNP_NFILE' + character( 40 ), parameter :: BDSNP_AFILE = 'BDSNP_AFILE' + character( 40 ), parameter :: BDSNP_NAFILE = 'BDSNP_NAFILE' + character( 40 ), parameter :: BDSNP_FFILE = 'BDSNP_FFILE' + character( 40 ), parameter :: BDSNP_LFILE = 'BDSNP_LFILE' + character( 256 ) :: mesg + character( 40 ) :: var + + if (BDSNP_MEGAN) then + allocate (bdsnp_fert( ncols,nrows), + & bdsnp_arid( ncols,nrows), + & bdsnp_nonarid( ncols,nrows), + & bdsnp_landtype( ncols,nrows), + & bdsnp_ndep( ncols,nrows,12), + & stat=stat) + IF ( STAT .NE. 0 ) THEN + MESG = 'Failure BIOGEMIS_MEGAN arrays in megan_setup' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT3 ) + END IF + bdsnp_fert = 0. + bdsnp_arid = 0. + bdsnp_nonarid = 0. + bdsnp_landtype = 0. + bdsnp_ndep = 0. + end if + +#ifdef mpas + + +! MPAS MIO not included + +#else +! NOT MPAS +! Open the CTS, LDF, LAI, and EFS files + IF ( .NOT. OPEN3( MEGAN_CTS, FSREAD3, PNAME ) ) THEN + mesg = 'Open failure for ' // MEGAN_CTS + Call M3EXIT( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + n_opened_file = n_opened_file + 1 + f_mbiog = n_opened_file + + IF ( .NOT. DESC3( MEGAN_CTS ) ) THEN + MESG = 'Could not get description of file "' // + & TRIM( MEGAN_CTS ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT1 ) + END IF + + file_sdate(f_mbiog) = sdate3d + file_stime(f_mbiog) = stime3d + file_tstep(f_mbiog) = tstep3d + file_xcell(f_mbiog) = xcell3d + file_ycell(f_mbiog) = ycell3d + + allocate (ctf(mxrec3d,ncols,nrows), stat = stat) + + if (stat .ne. 0) then + mesg = 'Failure allocating MEGAN input arrays' + call m3exit (pname, 0, 0, mesg, xstat1 ) + end if + + call subhfile( megan_cts , gxoff, gyoff, strtcol, + & endcol, strtrow, endrow ) + + megan_day = sdate3d + megan_hr = stime3d + + megan_hr = 0 + do I=1,mxrec3d + + IF ( .NOT. XTRACT3( MEGAN_CTS, 'CTS', + & 1, 1, strtrow, endrow, strtcol, endcol, + & 0, megan_hr, ctf(I,:,:) ) ) THEN + mesg = 'Could not extract ' // MEGAN_CTS // ' file' + CALL M3EXIT ( PNAME, megan_day, megan_hr, mesg, XSTAT1 ) + END IF + megan_hr = megan_hr + 10000 + !call nextime (megan_day, megan_hr, tstep3d) + + end do + + WHERE ( ctf .ne. ctf ) ctf = 0.0 ! ensure no NaNs + + IF ( .NOT. OPEN3( MEGAN_EFS, FSREAD3, PNAME ) ) THEN + mesg = 'Open failure for ' // MEGAN_EFS + Call M3EXIT( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + + IF ( .NOT. DESC3( MEGAN_EFS ) ) THEN + MESG = 'Could not get description of file "' // + & TRIM( MEGAN_EFS ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT1 ) + END IF + + allocate (efmaps(ncols,nrows,nvars3d), stat = stat) + + if (stat .ne. 0) then + mesg = 'Failure allocating MEGAN input arrays' + call m3exit (pname, 0, 0, mesg, xstat1 ) + end if + + call subhfile( megan_efs, gxoff, gyoff, strtcol, + & endcol, strtrow, endrow ) + + megan_day = sdate3d + megan_hr = stime3d + + IF ( .NOT. XTRACT3( MEGAN_EFS, 'ALL', + & 1, 1, strtrow, endrow, strtcol, endcol, + & megan_day, megan_hr, efmaps(:,:,:) ) ) THEN + mesg = 'Could not extract ' // MEGAN_EFS // ' file' + CALL M3EXIT ( PNAME, 0, megan_hr, mesg, XSTAT1 ) + END IF + + IF ( USE_MEGAN_LAI) THEN + IF ( .NOT. OPEN3( MEGAN_LAI, FSREAD3, PNAME ) ) THEN + mesg = 'Open failure for ' // MEGAN_LAI + Call M3EXIT( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + + IF ( .NOT. DESC3( MEGAN_LAI ) ) THEN + MESG = 'Could not get description of file "' // + & TRIM( MEGAN_LAI ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT1 ) + END IF + + + allocate (lai_m(ncols,nrows,nvars3d-2), stat = stat) + + if (stat .ne. 0) then + mesg = 'Failure allocating MEGAN input arrays' + call m3exit (pname, 0, 0, mesg, xstat1 ) + end if + + lai_m = 0.0 + + call subhfile( megan_lai, gxoff, gyoff, strtcol, + & endcol, strtrow, endrow ) + + megan_day = sdate3d + megan_hr = stime3d + + do I=1,nvars3d-2 ! lat/lon excluded + WRITE( VAR, '(A3,I2.2)' ) 'LAI', I + IF ( .NOT. XTRACT3( MEGAN_LAI, VAR, + & 1, 1, strtrow, endrow, strtcol, endcol, + & megan_day, megan_hr, lai_m(:,:,I) ) ) THEN + mesg = 'Could not extract ' // MEGAN_LAI // ' file' + CALL M3EXIT ( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + end do + END IF + + IF ( .NOT. OPEN3( MEGAN_LDF, FSREAD3, PNAME ) ) THEN + mesg = 'Open failure for ' // MEGAN_LDF + Call M3EXIT( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + + IF ( .NOT. DESC3( MEGAN_LDF ) ) THEN + MESG = 'Could not get description of file "' // + & TRIM( MEGAN_LDF ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT1 ) + END IF + + allocate (ldf(ncols,nrows,nvars3d), stat = stat) + + if (stat .ne. 0) then + mesg = 'Failure allocating MEGAN input arrays' + call m3exit (pname, 0, 0, mesg, xstat1 ) + end if + + call subhfile( megan_ldf, gxoff, gyoff, strtcol, + & endcol, strtrow, endrow ) + + megan_day = sdate3d + megan_hr = stime3d + + IF ( .NOT. XTRACT3( MEGAN_LDF, 'ALL', + & 1, 1, strtrow, endrow, strtcol, endcol, + & megan_day, megan_hr, LDF(:,:,:) ) ) THEN + mesg = 'Could not extract ' // MEGAN_LDF // ' file' + CALL M3EXIT ( PNAME, 0, megan_hr, mesg, XSTAT1 ) + END IF + if (BDSNP_MEGAN) then + + ! Optional BDSNP nitrogen input + if (.not. MGN_ONLN_DEP) then + IF ( .NOT. OPEN3( BDSNP_NFILE, FSREAD3, PNAME ) ) THEN + mesg = 'Open failure for ' // BDSNP_NFILE + Call M3EXIT( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + + IF ( .NOT. DESC3( BDSNP_NFILE ) ) THEN + MESG = 'Could not get description of file "' // + & TRIM( BDSNP_NFILE ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT1 ) + END IF + + + call subhfile( BDSNP_NFILE, gxoff, gyoff, strtcol, + & endcol, strtrow, endrow ) + + megan_day = sdate3d + megan_hr = stime3d + do i = 1,12 + write( var, '(A8,I2.2)' ) 'NITROGEN', i + IF ( .NOT. XTRACT3( BDSNP_NFILE, var, + & 1, 1, strtrow, endrow, strtcol, endcol, + & megan_day, megan_hr, bdsnp_ndep(:,:,i) ) ) THEN + mesg = 'Could not extract ' // BDSNP_NFILE // ' file' + CALL M3EXIT ( PNAME, 0, megan_hr, mesg, XSTAT1 ) + END IF + end do + end if + + ! BDSNP fertilizer input + + IF ( .NOT. OPEN3( BDSNP_FFILE, FSREAD3, PNAME ) ) THEN + mesg = 'Open failure for ' // BDSNP_FFILE + Call M3EXIT( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + + IF ( .NOT. DESC3( BDSNP_FFILE ) ) THEN + MESG = 'Could not get description of file "' // + & TRIM( BDSNP_FFILE ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT1 ) + END IF + + call subhfile( BDSNP_FFILE, gxoff, gyoff, strtcol, + & endcol, strtrow, endrow ) + + i = FLOAT( MOD( STDATE, 1000 ) ) + write( var, '(A4,I3.3)' ) 'FERT', i + IF ( .NOT. XTRACT3( BDSNP_FFILE, var, + & 1, 1, strtrow, endrow, strtcol, endcol, + & megan_day, megan_hr, bdsnp_fert(:,:) ) ) THEN + mesg = 'Could not extract ' // BDSNP_FFILE // ' file' + CALL M3EXIT ( PNAME, 0, megan_hr, mesg, XSTAT1 ) + END IF + + ! BDSNP arid input + + IF ( .NOT. OPEN3( BDSNP_AFILE, FSREAD3, PNAME ) ) THEN + mesg = 'Open failure for ' // BDSNP_AFILE + Call M3EXIT( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + + IF ( .NOT. DESC3( BDSNP_AFILE ) ) THEN + MESG = 'Could not get description of file "' // + & TRIM( BDSNP_AFILE ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT1 ) + END IF + + call subhfile( BDSNP_AFILE, gxoff, gyoff, strtcol, + & endcol, strtrow, endrow ) + + + IF ( .NOT. XTRACT3( BDSNP_AFILE, 'ARID', + & 1, 1, strtrow, endrow, strtcol, endcol, + & megan_day, megan_hr, bdsnp_arid(:,:) ) ) THEN + mesg = 'Could not extract ' // BDSNP_AFILE // ' file' + CALL M3EXIT ( PNAME, 0, megan_hr, mesg, XSTAT1 ) + END IF + + ! BDSNP nonarid input + + IF ( .NOT. OPEN3( BDSNP_NAFILE, FSREAD3, PNAME ) ) THEN + mesg = 'Open failure for ' // BDSNP_NAFILE + Call M3EXIT( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + + IF ( .NOT. DESC3( BDSNP_NAFILE ) ) THEN + MESG = 'Could not get description of file "' // + & TRIM( BDSNP_NAFILE ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT1 ) + END IF + + call subhfile( BDSNP_NAFILE, gxoff, gyoff, strtcol, + & endcol, strtrow, endrow ) + + + IF ( .NOT. XTRACT3( BDSNP_NAFILE, 'NONARID', + & 1, 1, strtrow, endrow, strtcol, endcol, + & megan_day, megan_hr, bdsnp_nonarid(:,:) ) ) THEN + mesg = 'Could not extract ' // BDSNP_NAFILE // ' file' + CALL M3EXIT ( PNAME, 0, megan_hr, mesg, XSTAT1 ) + END IF + + ! BDSNP landtype input + + IF ( .NOT. OPEN3( BDSNP_LFILE, FSREAD3, PNAME ) ) THEN + mesg = 'Open failure for ' // BDSNP_LFILE + Call M3EXIT( PNAME, 0, 0, mesg, XSTAT1 ) + END IF + + IF ( .NOT. DESC3( BDSNP_LFILE ) ) THEN + MESG = 'Could not get description of file "' // + & TRIM( BDSNP_LFILE ) // '"' + CALL M3EXIT( PNAME, 0, 0, MESG, XSTAT1 ) + END IF + + call subhfile( BDSNP_LFILE, gxoff, gyoff, strtcol, + & endcol, strtrow, endrow ) + + IF ( .NOT. XTRACT3( BDSNP_LFILE, 'LANDTYPE', + & 1, 1, strtrow, endrow, strtcol, endcol, + & megan_day, megan_hr, bdsnp_landtype(:,:) ) ) THEN + mesg = 'Could not extract ' // BDSNP_LFILE // ' file' + CALL M3EXIT ( PNAME, 0, megan_hr, mesg, XSTAT1 ) + END IF + + end if + +#endif + end subroutine megan_setup + +! ------------------------------------------------------------------------- + + subroutine centralized_io_init (in_ncols) + + use lsm_mod, only: n_lufrac, init_lsm + USE UTILIO_DEFN ! (Wei Li) , only : m3exit + USE RUNTIME_VARS, only: log_heading, logdev + +#ifdef mpas +! use hgrd_defn, only : ncols +! use RUNTIME_VARS, only : WB_DUST, ocean_chem +! use lus_defn, only : lus_init +#else + USE HGRD_DEFN + use cgrid_spcs, only : GC_DDEP, N_GC_DDEP +! use util_module, only : index1 + + INCLUDE SUBST_FILES_ID ! file name parameters +#endif + + integer, intent(in), optional :: in_ncols + + Character( 40 ), parameter :: pname = 'centralized_io_init' + + logical, save :: first_time = .true. + INTEGER :: STAT + CHARACTER( 120 ) :: XMSG = ' ' + Character( 16 ) :: vname + + if (first_time) then + first_time = .false. + call log_heading( logdev, 'Opening CMAQ Input Files' ) + +#ifdef mpas +! call gridded_files_setup +! +! call retrieve_lufrac_cro_data +! +! if (wb_dust) then +! call lus_setup +! end if +! +!! cio_logdev = 6 +! +! if ( WB_DUST ) then +! if (.not. lus_init (mminlu_mpas, lufrac_data) ) then +! print *, ' Error: Cannot initialize Land Use category' +! stop +! end if +! end if +! +! allocate (lwmask(in_ncols, 1), +! & lat(in_ncols, 1), +! & lon(in_ncols, 1), +! & ht(in_ncols, 1), +! & ocean(in_ncols, 1), +! & szone(in_ncols, 1), +! & stat=stat) +! +! lon = g2ddata(:,:,lon_ind) +! lat = g2ddata(:,:,lat_ind) +! ht = g2ddata(:,:,ht_ind) +! lwmask = g2ddata(:,:,lwmask_ind) +! +! call retrieve_ocean_data_mpas +! +! if (ocean_chem) then +! ocean = g2ddata(:,:,open_ind) +! szone = g2ddata(:,:,surf_ind) +! dmsl = g2ddata(:,:,dms_ind) +! chlr = g2ddata(:,:,chlo_ind) +! end if +! +! cio_model_sdate = stdate +! cio_model_stime = sttime +! +! call stack_files_setup_mpas +! +#else + cio_logdev = init3() + + cio_model_sdate = STDATE + cio_model_stime = STTIME + + east_pe = (mod(mype, npcol) .eq. npcol - 1) + west_pe = (mod(mype, npcol) .eq. 0) + north_pe = (mype .ge. npcol * (nprow - 1)) + south_pe = (mype .lt. npcol) + + cio_LTNG_NO = LTNG_NO + + MEDC_AVAIL = .true. + If ( .Not. Open3( INIT_MEDC_1, fsread3, pname ) ) Then + MEDC_AVAIL = .false. + if (abflux) then + E2C_CHEM_AVAIL = .true. + If ( .Not. Open3( E2C_CHEM, fsread3, pname ) ) Then + XMSG = 'Open failure for ' // E2C_CHEM + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + E2C_CHEM_AVAIL = .false. + END IF + n_opened_file = n_opened_file + 1 + else + E2C_CHEM_AVAIL = .false. + end if + END IF + + if (MEDC_AVAIL) then + n_opened_file = n_opened_file + 1 + end if + + call gridded_files_setup + + call boundary_files_setup + + call stack_files_setup + + if (BIOGEMIS_BEIS) then + call biogemis_setup + call beis_norm_emis_setup + end if + if (BIOGEMIS_MEGAN) then + call megan_setup + end if + + + if (ABFLUX) then + call depv_data_setup + end if + + if (LUCRO_AVAIL) then + call retrieve_lufrac_cro_data + end if + + if (WB_DUST) then + if (.not. PX_LSM) then + XMSG = 'WB_DUST requires PX LSM (PX_VERSION Y)' + Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) + end if + call lus_setup + + end if + + if (HGBIDI .and. (.not. NEW_START)) then ! two level check, 1. environment variable and then GC_DDEP species list + if ( index1 ( 'HG', N_GC_DDEP, GC_DDEP) .gt. 0 ) then + call medc_file_setup + end if + end if + + if (BIOGEMIS_BEIS .or. BIOGEMIS_MEGAN) then + call soilinp_setup + end if + + + call retrieve_grid_cro_2d_data + + call retrieve_grid_dot_2d_data + + call retrieve_ocean_data + + if (cio_LTNG_NO) then + call retrieve_ltng_param_data + end if +#endif + + end if + + call retrieve_time_dep_gridded_data (cio_model_sdate, cio_model_stime) + +#ifdef mpas +! call retrieve_stack_data_mpas (cio_model_sdate, cio_model_stime) +#else + call retrieve_boundary_data (cio_model_sdate, cio_model_stime) + + call retrieve_stack_data (cio_model_sdate, cio_model_stime) +#endif + + end subroutine centralized_io_init + +!----------------------------------------------------------------------- + SUBROUTINE DESID_INIT_REGIONS( ) +! +! This subroutine defines several hardcoded rules for emissions +! scaling that will apply by default. These include subtracting NH3 +! from fertilizer emissions if BiDi is turned on, moving all +! sulfuric acid vapor to the particle phase upon emission and +! splitting up the coarse mode anthropogenic emissions mass into +! speciated compounds. +!----------------------------------------------------------------------- + USE GRID_CONF + USE UTILIO_DEFN + USE desid_param_module + USE UTIL_FAMILY_MODULE +#ifdef mpas +! USE util_module, only : index1, upcase + +#endif + +#ifdef parallel + USE SE_MODULES ! stenex (using SE_UTIL_MODULE,SE_DATA_COPY_MODULE) +#else + USE NOOP_MODULES ! stenex (using NOOP_UTIL_MODULE,NOOP_DATA_COPY_MODULE) +#endif + +#ifdef sens + USE DDM3D_DEFN, ONLY: NP, NPMAX, S_NRGN, S_RGNLBL, IREGION +#endif + + IMPLICIT NONE + + TYPE( DESID_REG_TYPE) :: DESID_REG_READ( DESID_MAX_REG ) + INTEGER, PARAMETER :: NFILE0 = 200 + CHARACTER( 32 ) :: FILENAMES( NFILE0 ) = '' + CHARACTER( 32 ) :: VNAME + + INTEGER :: IRGN, NFILE, IDX, IFILE, IREAD, IVAR, IFAM, JRGN + INTEGER :: GXOFF, GYOFF, ENDCOL, ENDROW, STARTCOL, STARTROW + INTEGER :: N_REG_RULE + CHARACTER( 16 ) :: PNAME = "DESID_INIT_REGIONS" + CHARACTER( 250) :: XMSG + REAL, ALLOCATABLE :: REG_FACI(:,:), REG_FACJ(:,:) + integer :: ldate, ltime, floc + CHARACTER( 16 ) :: lvname + + ! Find the total number of regions to be processed + N_REG_RULE = 0 ! The first region is the entire domain + DO IRGN = 1,DESID_MAX_REG + IF ( DESID_REG_NML( IRGN )%LABEL .EQ. '' ) EXIT + N_REG_RULE = N_REG_RULE + 1 + END DO + + ! Allocate Vectors and Arrays for Each Region + ALLOCATE( DESID_REG( DESID_MAX_REG ) ) + DESID_REG( 1 )%LABEL = 'EVERYWHERE' + DESID_REG( 1 )%FILE = 'N/A' + DESID_REG( 1 )%VAR = 'N/A' + DESID_REG( 1 )%FILENUM = 1 + DESID_N_REG = 1 + + ALLOCATE( DESID_REG_FAC( NCOLS,NROWS,DESID_MAX_REG ) ) + DESID_REG_FAC = 0.0 + DESID_REG_FAC( :,:,1 ) = 1.0 + + ! Populate global Region properties structure. Also assign each + ! region a number according to the file it comes from. 1 = + ! domain-wide. + NFILE = 1 + FILENAMES( 1 ) = 'N/A' + + IF ( N_REG_RULE .GT. 0 ) THEN + DO IREAD = 1,N_REG_RULE + CALL UPCASE( DESID_REG_NML( IREAD )%LABEL ) + CALL UPCASE( DESID_REG_NML( IREAD )%FILE ) + CALL UPCASE( DESID_REG_NML( IREAD )%VAR ) + + DESID_REG_READ( IREAD )%LABEL = DESID_REG_NML( IREAD )%LABEL ! Region Name + DESID_REG_READ( IREAD )%FILE = DESID_REG_NML( IREAD )%FILE ! Logical filename + DESID_REG_READ( IREAD )%VAR = DESID_REG_NML( IREAD )%VAR ! Variable from file + ! used to inform mask + + IDX = INDEX1( DESID_REG_READ( IREAD )%FILE, NFILE, FILENAMES(1:NFILE) ) + IF ( IDX .NE. 0 ) THEN + DESID_REG_READ( IREAD )%FILENUM = IDX + ELSE + NFILE = NFILE + 1 + DESID_REG_READ( IREAD )%FILENUM = NFILE + FILENAMES( NFILE ) = DESID_REG_READ( IREAD )%FILE + END IF + END DO + + ! Process each region by looping through the pertinent files, + ! look up maps and save the data in a global array + DO IFILE = 1,NFILE + IF ( FILENAMES( IFILE ) .EQ. 'N/A' ) CYCLE + +#ifdef mpas +! floc = search_fname (filenames( ifile )) + +! ldate = 0 +! ltime = 0 +#else + ! Get domain decomp info from the emissions file + CALL SUBHFILE ( FILENAMES( IFILE ), GXOFF, GYOFF, + & STARTCOL, ENDCOL, STARTROW, ENDROW ) + + ! Open input file + IF ( .NOT. OPEN3( FILENAMES( IFILE ), FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open '// FILENAMES( IFILE ) // ' file' + CALL M3EXIT( PNAME, STDATE, STTIME, XMSG, XSTAT1 ) + END IF + n_opened_file = n_opened_file + 1 + + ! Retrieve File Header Information + IF ( .NOT. DESC3( FILENAMES( IFILE ) ) ) THEN + XMSG = 'Could not get ' // FILENAMES( IFILE ) // ' file description' + CALL M3EXIT( PNAME, STDATE, STTIME, XMSG, XSTAT1 ) + END IF + +#endif + + ! Read data from regions file into region array + DO IREAD = 1,N_REG_RULE + IF ( DESID_REG_READ( IREAD )%FILENUM .EQ. IFILE ) THEN + IF ( DESID_REG_READ( IREAD )%VAR .EQ. 'ALL' ) THEN + ! Populate the region array with all of the + ! variables on this file + IF ( DESID_REG_READ( IREAD )%LABEL .NE. 'ALL' ) THEN + XMSG = 'Error reading Region input in Emissions Control file.'// + & 'If the variable name is set to "ALL", then the label must'// + & 'also be set to "ALL".' + CALL M3EXIT( PNAME, STDATE, STTIME, XMSG, XSTAT1 ) + ELSE +!#ifdef mpas +! DO IVAR = 1, cio_emis_nvars(ifile) +! lvname = mio_file_data(floc)%var_name(ivar) +!#else + DO IVAR = 1,NVARS3D + lvname = vname3d( ivar ) +!#endif + DESID_N_REG = DESID_N_REG + 1 + IF ( DESID_N_REG .GT. DESID_MAX_REG ) THEN + XMSG = 'The number of DESID regions has exceeded '// + & 'the maximum. Set Desid_Max_Reg in the '// + & 'CMAQ_Control_DESID.nml file to a higher value.' + CALL M3EXIT( PNAME, SDATE3D, STIME3D, XMSG, XSTAT1 ) + END IF + DESID_REG( DESID_N_REG )%LABEL = lvname + DESID_REG( DESID_N_REG )%VAR = lvname + DESID_REG( DESID_N_REG )%FILE = DESID_REG_READ( IREAD )%FILE + DESID_REG( DESID_N_REG )%FILENUM = DESID_REG_READ( IREAD )%FILENUM + +#ifdef mpas +! call mio_fread (FILENAMES(IFILE), lvname, DESID_REG_FAC(:,1,DESID_N_REG)) +#else + IF ( .NOT. XTRACT3( FILENAMES( IFILE ), VNAME3D(IVAR), 1, 1, + & STARTROW, ENDROW, STARTCOL, ENDCOL, + & 0, 0, DESID_REG_FAC( 1,1,DESID_N_REG ) ) ) Then + XMSG = 'Could not read ' // VNAME3D(IVAR) // + & 'from file ' // FILENAMES( IFILE ) + CALL M3WARN ( PNAME, 0, 0, XMSG ) + End If +#endif + + END DO + END IF + ELSE + ! Populate the region array with only this variable + DESID_N_REG = DESID_N_REG + 1 + IF ( DESID_N_REG .GT. DESID_MAX_REG ) THEN + XMSG = 'The number of DESID regions has exceeded '// + & 'the maximum. Set Desid_Max_Reg in the '// + & 'CMAQ_Control_DESID.nml file to a higher value.' + CALL M3EXIT( PNAME, SDATE3D, STIME3D, XMSG, XSTAT1 ) + END IF + + DESID_REG( DESID_N_REG ) = DESID_REG_READ( IREAD ) + VNAME = DESID_REG_READ( IREAD )%VAR + +#ifdef mpas +! call mio_fread (FILENAMES(IFILE), VNAME, DESID_REG_FAC(:,1,DESID_N_REG)) +#else + IF ( .NOT. XTRACT3( FILENAMES( IFILE ), VNAME, 1, 1, + & STARTROW, ENDROW, STARTCOL, ENDCOL, + & 0, 0, DESID_REG_FAC( 1,1,DESID_N_REG ) ) ) Then + XMSG = 'Could not read ' // VNAME // + & 'from file ' // FILENAMES( IFILE ) + CALL M3WARN ( PNAME, 0, 0, XMSG ) + End If +#endif + + END IF + END IF + END DO + +#ifndef mpas +! ! Close Regions File +! IF ( .NOT. CLOSE3( FILENAMES( IFILE ) ) ) THEN +! XMSG = 'Could not close ' // FILENAMES( IFILE ) +! CALL M3EXIT( PNAME, SDATE3D, STIME3D, XMSG, XSTAT1 ) +! END IF +#endif + + ! Error Check the Regions Array + ! Any Negatives? + DO IRGN = 1,DESID_N_REG + IF ( ANY( DESID_REG_FAC( :,:,IRGN ) .LT. 0.0 ) ) THEN + XMSG = 'Region ' // TRIM( DESID_REG( IRGN )%LABEL) // ' on file ' // + & TRIM( FILENAMES( IFILE )) // ' contains a ' // + & 'negative value. The expected range is 0-1.' + CALL M3ERR( PNAME, STDATE, STTIME, XMSG, .TRUE. ) + ELSE IF ( ANY( DESID_REG_FAC( :,:,IRGN ) .GT. 1.01 ) ) THEN + XMSG = 'Region ' // TRIM( DESID_REG( IRGN )%LABEL) // ' on file ' // + & TRIM( FILENAMES( IFILE )) // ' contains a ' // + & 'value greater than 1. The expected range is 0-1.' + CALL M3ERR( PNAME, STDATE, STTIME, XMSG, .TRUE. ) + END IF + + ! Condition mask values to be at most 1.0 + DESID_REG_FAC( :,:,IRGN ) = MIN( 1.0, DESID_REG_FAC( :,:,IRGN ) ) + + END DO + + END DO ! IFILE + + ! Augment Emission Region Structure with Region Families + DO IFAM = 1,Desid_N_Reg_Fams + DESID_N_REG = DESID_N_REG + 1 + CALL UPCASE( RegionFamilyName( IFAM ) ) + DESID_REG( DESID_N_REG )%LABEL = RegionFamilyName( IFAM ) + DESID_REG( DESID_N_REG )%VAR = 'Family' + DESID_REG( DESID_N_REG )%FILE = 'Family' + DESID_REG( DESID_N_REG )%FILENUM = 0 + + DO IRGN = 1,RegionFamilyNum( IFAM ) + CALL UPCASE( RegionFamilyMembers( IFAM,IRGN ) ) + JRGN = INDEX1( RegionFamilyMembers( IFAM,IRGN ), DESID_N_REG-1, + & DESID_REG( 1:(DESID_N_REG-1) )%VAR ) + IF ( JRGN .GT. 0 ) + & DESID_REG_FAC( :,:,DESID_N_REG ) = + & MIN( 1.0, DESID_REG_FAC( :,:,DESID_N_REG ) + + & DESID_REG_FAC( :,:,JRGN ) ) + END DO + END DO + END IF + + DESID_REG = DESID_REG( 1:DESID_N_REG ) + DESID_REG_FAC = DESID_REG_FAC( :,:,1:DESID_N_REG ) + + ! Determine Which Regions are Subsets of Larger Regions and + ! save special relationship for use in EMISS_SCALING. + ALLOCATE( DESID_REG_SUB( DESID_N_REG, DESID_N_REG ) ) + DESID_REG_SUB(:,:) = .FALSE. ! Initialize with no region subsets + DESID_REG_SUB(1,:) = .TRUE. ! All regions are a subset of Region 1 (Everywhere) + DESID_REG_SUB(1,1) = .FALSE. ! No regions are subsets of themselves + + ALLOCATE( REG_FACI(GL_NCOLS,GL_NROWS), + & REG_FACJ(GL_NCOLS,GL_NROWS) ) + + DO IRGN = 2,DESID_N_REG +#ifdef parallel + CALL SUBST_GLOBAL_GATHER( DESID_REG_FAC(:,:,IRGN), REG_FACI ) +#else + REG_FACI = DESID_REG_FAC(:,:,IRGN) +#endif + DO JRGN = 1,DESID_N_REG +#ifdef parallel + CALL SUBST_GLOBAL_GATHER( DESID_REG_FAC(:,:,JRGN), REG_FACJ ) +#else + REG_FACJ = DESID_REG_FAC(:,:,JRGN) +#endif + IF ( MYPE .EQ. 0 ) THEN + IF ( JRGN .NE. IRGN .AND. + & ANY( REG_FACJ(:,:) .GT. 0. ) .AND. + & ALL( REG_FACI(:,:)+1.0E-6 .GT. + & REG_FACJ(:,:) ) ) THEN + ! Assume JRGN is a subset of IRGN. Both have to be + ! non-zero somewhere in the domain. + DESID_REG_SUB( IRGN,JRGN ) = .TRUE. + END IF + END IF ! Only perform algorithm on main processor + END DO + END DO + + DEALLOCATE( REG_FACI, REG_FACJ ) + +#ifdef parallel + CALL SUBST_GLOBAL_BCAST( DESID_REG_SUB ) +#endif + +#ifdef sens +! Populate IREGION(NCOLS,NROW,NLAYS,NPMAX) with regions data if specified +!' + + DO NP = 1, NPMAX + IF ( S_NRGN( NP ) .GT. 0 .AND. S_NRGN( NP ) .LT. 99 ) THEN ! + DO IRGN = 1, S_NRGN( NP ) + IREAD = INDEX1( S_RGNLBL(NP,IRGN), DESID_N_REG, DESID_REG%LABEL ) ! identify region + IF ( IREAD .EQ. 0 ) THEN + XMSG = " User specified DDM3D region - " // + & TRIM( S_RGNLBL(NP,IRGN) ) // + & " - not found in available emissions regions. " // + & " Check sensinput.dat file " + WRITE(LOGDEV,*) " Available region definitions: " + DO IFILE = 1, DESID_N_REG + WRITE(LOGDEV,*) IFILE, DESID_REG( IFILE )%LABEL + END DO + CALL M3EXIT( PNAME, 1, 1, XMSG, XSTAT1 ) + ELSE + IREGION(:,:,1,NP) = IREGION( :,:,1,NP ) + & + DESID_REG_FAC( :,:,IREAD ) + END IF + END DO +! Limit IREGION to < 1.0 incase some regions overlap. + IREGION(:,:,:,NP) = MIN ( IREGION(:,:,:,NP), 1.0 ) +! Copy up to layers above + DO IFILE = 1, NLAYS + IREGION(:,:,IFILE,NP) = IREGION(:,:,1,NP) + END DO + END IF + END DO + +#endif + + END SUBROUTINE DESID_INIT_REGIONS + +!----------------------------------------------------------------------- + SUBROUTINE DESID_READ_NAMELIST( ) +! +! This subroutine opens and reads the Emissions Control Namelist. It +! attempts to deal with errors like missing file or missing file +! sections by error checking and setting defaults. +!----------------------------------------------------------------------- + + use desid_param_module + use util_family_module + use RUNTIME_VARS, only: MISC_CTRL, DESID_CTRL, DESID_CHEM_CTRL, + & logdev, log_message, log_subheading + use PA_DEFN, ONLY : BudgetVariables, MAX_BUDGET_VARS_NML, BUDGET_DIAG +#ifdef mpas +! use util_module, only : junit, upcase +#endif + + IMPLICIT NONE + + ! Define Dummy Variables for Opening Emission Control Namelist + CHARACTER( 300 ) :: XMSG + INTEGER :: Desid_N_Diag_Rules, Desid_Max_Area, Desid_Max_Sd + INTEGER :: FUNIT + INTEGER :: IOST, IFAM, INUM, IRULE + CHARACTER( 200 ) :: TMPLINE + + ! Define Namelist Input from Control Files + ! CMAQ Control Util + Namelist / Budget_Options / Budget_Diag, BudgetVariables + + ! DESID Chem Control + Namelist / Desid_ScalingVars / Desid_Max_Rules + Namelist / Desid_Scaling / Desid_Rules_Nml + + ! DESID Control + Namelist / Desid_Options / Desid_MaxLays + + Namelist / Desid_AreaNormVars / Desid_Max_Area + Namelist / Desid_AreaNorm / Desid_Area_Nml + + Namelist / Desid_SizeDistVars / Desid_Max_Sd + Namelist / Desid_SizeDist / Desid_Sd_Nml + + Namelist / Desid_RegionDefVars / Desid_Max_Reg, + & Desid_N_Reg_Fams, + & Desid_Max_Reg_Fam_Members + Namelist / Desid_RegionDef / Desid_Reg_Nml + + Namelist / Desid_DiagVars / Desid_N_Diag_Rules, + & Desid_Max_Diag_Streams, + & Desid_Max_Diag_Spec + Namelist / Desid_Diag / Desid_Diag_Streams_Nml, + & Desid_Diag_Fmt_Nml, + & Desid_Diag_Spec_Nml + + CALL LOG_MESSAGE( LOGDEV, ' ' ) + CALL LOG_SUBHEADING( LOGDEV, 'Reading Emission Control Namelist') + + !!! Budget Options !!! + ! Allocate and Initialize Budget Variables + Budget_Diag = .FALSE. + ALLOCATE( BudgetVariables( Max_Budget_Vars_Nml ) ) + BudgetVariables = '' + + ! Retrieve the Name of the Emission Control File + IF ( MISC_CTRL .EQ. "MISC_CTRL_NML" ) THEN + XMSG = 'You have chosen not to indicate the location of an' // + & 'CMAQ Control namelist file. You must give a value ' // + & 'for the MISC_CTRL variable in the CMAQ runscript.' + CALL M3EXIT( 'DESID_READ_NAMELIST',0,0,XMSG,1 ) + END IF + + ! Open Emission Control Namelist File + FUNIT = JUNIT() + OPEN( FILE = MISC_CTRL, UNIT = FUNIT, STATUS = 'OLD', + & POSITION = 'REWIND', FORM='FORMATTED', IOSTAT = IOST ) + + ! Check for Error in File Open Process + IF ( IOST .NE. 0 ) THEN + WRITE( XMSG, '(A,A,A)' ),'ERROR: Could not read ', + & 'CMAQ control namelist file: ',TRIM( MISC_CTRL ) + CALL M3EXIT( 'DESID_READ_NAMELIST',0,0,XMSG,1 ) + END IF + + ! Read Budget Variables Specification Section + REWIND( FUNIT ) + READ( NML = Budget_Options, UNIT = FUNIT, IOSTAT= IOST ) + IF ( IOST .EQ. -1 ) THEN + WRITE( LOGDEV, "(5x,A,/,5x,A,/,5x,A,/,5x,A)" ), + & 'Note: The BudgetOptions section of the Emissions Control ', + & 'Namelist is missing. Default values for this section will be ', + & 'assumed.' + Budget_Diag = .FALSE. + BudgetVariables = 'ALL' + ELSE IF ( IOST .NE. 0 ) THEN + ! Read Error Detected for BudgetOptions + backspace( FUNIT ) + read( FUNIT, fmt='(A)' ) tmpline + XMSG = 'ERROR: There was a syntax error reading the Budget_Options '// + & 'variable in the CMAQ control namelist. Please check the format of '// + & 'each line for syntax errors. The invalid line was likely: ' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + WRITE( LOGDEV, '(8x,A)' ) TMPLINE + CALL M3EXIT ( 'DESID_READ_NAMELIST', 0, 0, 'CMAQ must Crash until you '// + & 'fix the Budget Variables specification', 1 ) + END IF + ! Capitalize All Budget Variables Names + DO IFAM = 1,Max_Budget_Vars_Nml + CALL UPCASE( BudgetVariables( IFAM ) ) + END DO + + CLOSE( FUNIT ) + + !----------------------------! + !!! DESID Chemical Mapping !!! + ! Retrieve the Name of the Emission Control File + IF ( DESID_CHEM_CTRL .EQ. "DESID_CHEM_CTRL_NML" ) THEN + XMSG = 'You have chosen not to indicate the location of an' // + & 'Emission Control namelist file. You must give a value ' // + & 'for the DESID_CHEM_CTRL variable in the CMAQ runscript.' + CALL M3EXIT( 'DESID_READ_NAMELIST',0,0,XMSG,1 ) + END IF + + ! Open Emission Control Namelist File + FUNIT = JUNIT() + OPEN( FILE = DESID_CHEM_CTRL, UNIT = FUNIT, STATUS = 'OLD', + & POSITION = 'REWIND', FORM='FORMATTED', IOSTAT = IOST ) + + ! Check for Error in File Open Process + IF ( IOST .NE. 0 ) THEN + WRITE( XMSG, '(A,A,A)' ),'ERROR: Could not read ', + & 'emissions control namelist file: ',TRIM( DESID_CHEM_CTRL ) + CALL M3EXIT( 'DESID_READ_NAMELIST',0,0,XMSG,1 ) + END IF + + ! Read the number of Max Emissions Rules to inform scaling operations + REWIND( FUNIT ) + READ( NML = Desid_ScalingVars, UNIT = FUNIT, IOSTAT=IOST ) + IF ( IOST .EQ. -1 ) THEN + ! The DESID_Max_Rules Variable was completely missing + XMSG = 'WARNING: Maximum Number of DESID Scaling Rules was not specified. '// + & 'If you intended to specify Desid_Max_Rules, check the DESID_CHEM_CTRL file.' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + DESID_MAX_RULES = 500 + + ELSE IF ( IOST .NE. 0 ) THEN + ! Read Error Detected for DESID_RULES_NML + backspace( FUNIT ) + read( FUNIT, fmt='(A)' ) tmpline + XMSG = 'ERROR: There was a syntax error reading ithe max number of '// + & 'Emission Scaling Rules for use by the DESID module. Please '// + & 'check the format of each line for syntax errors. The '// + & 'invalid line was likely: ' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + WRITE( LOGDEV, '(8x,A)' ) TMPLINE + CALL M3EXIT ( 'DESID_READ_NAMELIST', 0, 0, 'CMAQ must Crash until you '// + & 'fix Desid_Max_Rules', 1 ) + END IF + + ! Allocate Initialize Namelist Variables + ALLOCATE( DESID_RULES_NML( DESID_MAX_RULES ), STAT=IOST ) + CALL CHECKMEM( IOST, 'DESID_RULES_NML','DESID_READ_NAMELIST') + DESID_RULES_NML%REGION = '' + DESID_RULES_NML%STREAM = '' + DESID_RULES_NML%EMVAR = '' + DESID_RULES_NML%SPEC = '' + DESID_RULES_NML%PHASE = '' + DESID_RULES_NML%OP = '' + DESID_RULES_NML%BASIS = '' + DESID_RULES_NML%FAC = 0. + + ! Read the Emissions Rules to inform scaling operations + REWIND( FUNIT ) + READ( NML = Desid_Scaling, UNIT = FUNIT, IOSTAT=IOST ) + IF ( IOST .EQ. -1 ) THEN + ! The DESID_RULES_NML Variable was completely missing + XMSG = 'WARNING: There were no valid Emission Scaling Rules specified '// + & 'for use by the DESID module. If you intended to specify '// + & 'rules in the emission control file, check the file you have '// + & 'provided for DESID_CHEM_CTRL.' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + DESID_RULES_NML%REGION = '' + DESID_RULES_NML%STREAM = '' + DESID_RULES_NML%EMVAR = '' + DESID_RULES_NML%SPEC = '' + DESID_RULES_NML%PHASE = '' + DESID_RULES_NML%OP = '' + DESID_RULES_NML%BASIS = '' + DESID_RULES_NML%FAC = 0. + + ELSE IF ( IOST .NE. 0 ) THEN + ! Read Error Detected for DESID_RULES_NML + backspace( FUNIT ) + read( FUNIT, fmt='(A)' ) tmpline + XMSG = 'ERROR: There was a syntax error reading Emission Scaling '// + & 'Rules for use by the DESID module. Please check the format of '// + & 'each line for syntax errors. The invalid line was likely: ' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + WRITE( LOGDEV, '(8x,A)' ) TMPLINE + CALL M3EXIT ( 'DESID_READ_NAMELIST', 0, 0, 'CMAQ must Crash until you '// + & 'fix the Emission Scaling Rules', 1 ) + END IF + + CALL LOG_MESSAGE( LOGDEV,' ' ) + CALL LOG_MESSAGE( LOGDEV,'Performing Basic Error Checks for Emission Scaling Rules' ) + + ! Check that the operator field is correct since it has not so + ! many possible values. + DO IRULE = 1,DESID_MAX_RULES + IF( DESID_RULES_NML( IRULE )%SPEC .EQ. '' ) EXIT + IF( DESID_RULES_NML( IRULE )%OP .NE. 'a' .AND. DESID_RULES_NML( IRULE )%OP .NE. 'A' .AND. + & DESID_RULES_NML( IRULE )%OP .NE. 'o' .AND. DESID_RULES_NML( IRULE )%OP .NE. 'O'.AND. + & DESID_RULES_NML( IRULE )%OP .NE. 'm' .AND. DESID_RULES_NML( IRULE )%OP .NE. 'M' ) THEN + WRITE( XMSG, '(A23,I4,A27,A3)'),'Emission Scaling Rule #',IRULE, + & ' has a bad operator value: ',DESID_RULES_NML(IRULE)%OP + call m3exit ( 'DESID_READ_NAMELIST', 0, 0, XMSG, 1 ) + END IF + ENDDO + + CLOSE( FUNIT ) + + !-----------------------------! + !!! Open DESID Control File !!! + !-----------------------------! + ! Retrieve the Name of the Emission Control File + IF ( DESID_CTRL .EQ. "DESID_CTRL_NML" ) THEN + XMSG = 'You have chosen not to indicate the location of an' // + & 'Emission Control namelist file. You must give a value ' // + & 'for the DESID_CTRL variable in the CMAQ runscript.' + CALL M3EXIT( 'DESID_READ_NAMELIST',0,0,XMSG,1 ) + END IF + + ! Open Emission Control Namelist File + FUNIT = JUNIT() + OPEN( FILE = DESID_CTRL, UNIT = FUNIT, STATUS = 'OLD', + & POSITION = 'REWIND', FORM='FORMATTED', IOSTAT = IOST ) + + ! Check for Error in File Open Process + IF ( IOST .NE. 0 ) THEN + WRITE( XMSG, '(A,A,A)' ),'ERROR: Could not read ', + & 'emissions control namelist file: ',TRIM( DESID_CTRL ) + CALL M3EXIT( 'DESID_READ_NAMELIST',0,0,XMSG,1 ) + END IF + + !----------------------! + !!! DESID Top Layer !!! + ! Read the Maximum Emissions Layer + REWIND( FUNIT ) + READ( NML = Desid_Options, UNIT = FUNIT, IOSTAT=IOST ) + IF ( IOST .EQ. -1 ) THEN + ! The Desid_Max_Lays Variable was completely missing + XMSG = 'WARNING: Maximum Layer for emissions input was not specified. '// + & 'If you intended to specify Desid_Max_Lays, check the DESID_CTRL file.' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + Desid_MaxLays = 0 + + ELSE IF ( IOST .NE. 0 ) THEN + ! Read Error Detected for Desid_Max_Lays + backspace( FUNIT ) + read( FUNIT, fmt='(A)' ) tmpline + XMSG = 'ERROR: There was a syntax error reading the max number of '// + & 'Emission Layers for use by the DESID module. Please '// + & 'check the format of each line for syntax errors. The '// + & 'invalid line was likely: ' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + WRITE( LOGDEV, '(8x,A)' ) TMPLINE + CALL M3EXIT ( 'DESID_READ_NAMELIST', 0, 0, 'CMAQ must Crash until you '// + & 'fix Desid_Max_Lays', 1 ) + END IF + + !------------------------------! + !!! DESID Area Normalization !!! + ! Read the number of Max Emissions Rules to inform scaling operations + REWIND( FUNIT ) + READ( NML = Desid_AreaNormVars, UNIT = FUNIT, IOSTAT=IOST ) + IF ( IOST .EQ. -1 ) THEN + ! The DESID_Max_Rules Variable was completely missing + XMSG = 'WARNING: Maximum Number of DESID Area Normalization Rules was not specified. '// + & 'If you intended to specify Desid_Max_Area, check the DESID_CTRL file.' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + DESID_MAX_AREA = 30 + + ELSE IF ( IOST .NE. 0 ) THEN + ! Read Error Detected for DESID_RULES_NML + backspace( FUNIT ) + read( FUNIT, fmt='(A)' ) tmpline + XMSG = 'ERROR: There was a syntax error reading the max number of '// + & 'Emission Area Normalization Rules for use by the DESID module. Please '// + & 'check the format of each line for syntax errors. The '// + & 'invalid line was likely: ' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + WRITE( LOGDEV, '(8x,A)' ) TMPLINE + CALL M3EXIT ( 'DESID_READ_NAMELIST', 0, 0, 'CMAQ must Crash until you '// + & 'fix Desid_Max_Area', 1 ) + END IF + + ! Allocate Initialize Namelist Variables + ALLOCATE( DESID_AREA_NML( DESID_MAX_AREA ), STAT=IOST ) + CALL CHECKMEM( IOST, 'DESID_AREA_NML','DESID_READ_NAMELIST') + DESID_AREA_NML%STREAM = 'ALL' + DESID_AREA_NML%AREA = 'AUTO' + DESID_AREA_NML%ADJ = 'AUTO' + + ! Read the Area Normalization Registry + REWIND( FUNIT ) + READ( NML = Desid_AreaNorm, UNIT = FUNIT, IOSTAT=IOST ) + IF ( IOST .EQ. -1 ) THEN + XMSG = 'Note: The Area Normalization section of the Emissions Control '// + & 'Interface is missing. Default values for this section will be '// + & 'assumed.' + CALL LOG_MESSAGE( LOGDEV,' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + DESID_AREA_NML%STREAM = 'ALL' + DESID_AREA_NML%AREA = 'AUTO' + DESID_AREA_NML%ADJ = 'AUTO' + ELSE IF ( IOST .NE. 0 ) THEN + ! Read Error Detected for DESID_AREA_NML + backspace( FUNIT ) + read( FUNIT, fmt='(A)' ) tmpline + XMSG = 'ERROR: There was a syntax error reading the Area Normalization '// + & 'variable for use by the DESID module. Please check the format of '// + & 'each line for syntax errors. The invalid line was likely: ' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + WRITE( LOGDEV, '(8x,A)' ) TMPLINE + CALL M3EXIT ( 'DESID_READ_NAMELIST', 0, 0, 'CMAQ must Crash until you '// + & 'fix the Area Normalization section', 1 ) + END IF + + !-----------------------------! + !!! DESID Region Definition !!! + ! Read the number of Max Emissions Rules to inform scaling operations + REWIND( FUNIT ) + READ( NML = Desid_RegionDefVars, UNIT = FUNIT, IOSTAT=IOST ) + IF ( IOST .EQ. -1 ) THEN + ! The DESID_Max_Rules Variable was completely missing + XMSG = 'WARNING: Maximum Number of DESID Region Def Variables was not specified. '// + & 'If you intended to specify Desid_Max_Reg, check the DESID_CTRL file.' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + DESID_MAX_REG = 30 + + ELSE IF ( IOST .NE. 0 ) THEN + ! Read Error Detected for DESID_RULES_NML + backspace( FUNIT ) + read( FUNIT, fmt='(A)' ) tmpline + XMSG = 'ERROR: There was a syntax error reading the max number of '// + & 'Region Definitions for use by the DESID module. Please '// + & 'check the format of each line for syntax errors. The '// + & 'invalid line was likely: ' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + WRITE( LOGDEV, '(8x,A)' ) TMPLINE + CALL M3EXIT ( 'DESID_READ_NAMELIST', 0, 0, 'CMAQ must Crash until you '// + & 'fix Desid_Max_Reg', 1 ) + END IF + + ! Allocate and Initialize Namelist Variables + ALLOCATE( DESID_REG_NML( DESID_MAX_REG ), STAT=IOST ) + CALL CHECKMEM( IOST, 'DESID_REG_NML','DESID_READ_NAMELIST') + DESID_REG_NML%LABEL = '' + DESID_REG_NML%FILE = '' + DESID_REG_NML%VAR = '' + + ! Read the Regions Registry + REWIND( FUNIT ) + READ( NML = Desid_RegionDef, UNIT = FUNIT, IOSTAT=IOST ) + IF ( IOST .EQ. -1 ) THEN + XMSG = 'Note: The Desid_RegionDef component of the Emissions Control '// + & 'Interface is missing. Default values for this section will be '// + & 'assumed.' + CALL LOG_MESSAGE( LOGDEV,' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + DESID_REG_NML%LABEL = '' + DESID_REG_NML%FILE = '' + DESID_REG_NML%VAR = '' + ELSE IF ( IOST .NE. 0 ) THEN + ! Read Error Detected for DESID_REG_NML + backspace( FUNIT ) + read( FUNIT, fmt='(A)' ) tmpline + XMSG = 'ERROR: There was a syntax error reading the Desid_RegionDef '// + & 'variable for use by the DESID module. Please check the format of '// + & 'each line for syntax errors. The invalid line was likely: ' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + WRITE( LOGDEV, '(8x,A)' ) TMPLINE + CALL M3EXIT ( 'DESID_READ_NAMELIST', 0, 0, 'CMAQ must Crash until you '// + & 'fix Desid_RegionDef', 1 ) + END IF + + + !------------------------------! + !!! DESID Size Distributions !!! + ! Read the number of Max Size Dist Rules to inform scaling operations + REWIND( FUNIT ) + READ( NML = Desid_SizeDistVars, UNIT = FUNIT, IOSTAT=IOST ) + IF ( IOST .EQ. -1 ) THEN + ! The DESID_Max_Sd Variable was completely missing + XMSG = 'WARNING: Maximum Number of DESID Size Dist Rules was not specified. '// + & 'If you intended to specify Desid_Max_Sd, check the DESID_CTRL file.' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + DESID_MAX_SD = 10 + + ELSE IF ( IOST .NE. 0 ) THEN + ! Read Error Detected for DESID_RULES_NML + backspace( FUNIT ) + read( FUNIT, fmt='(A)' ) tmpline + XMSG = 'ERROR: There was a syntax error reading the max number of '// + & 'Size Distribution RUles for use by the DESID module. Please '// + & 'check the format of each line for syntax errors. The '// + & 'invalid line was likely: ' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + WRITE( LOGDEV, '(8x,A)' ) TMPLINE + CALL M3EXIT ( 'DESID_READ_NAMELIST', 0, 0, 'CMAQ must Crash until you '// + & 'fix Desid_Max_Sd', 1 ) + END IF + + ! Allocate and Initialize Namelist Variables + ALLOCATE( DESID_SD_NML( DESID_MAX_SD ), STAT=IOST ) + CALL CHECKMEM( IOST, 'DESID_SD_NML','DESID_READ_NAMELIST') + DESID_SD_NML%STREAM = '' + DESID_SD_NML%MODE = '' + DESID_SD_NML%MODE_REF = '' + + !!! Read the size distribution specification section + REWIND( FUNIT ) + READ( NML = Desid_SizeDist, UNIT = FUNIT, IOSTAT=IOST ) + IF ( IOST .EQ. -1 ) THEN + XMSG = 'Note: The Desid_SizeDist component of the Emissions Control '// + & 'Interface is missing. Default values for this section '// + & 'will be assumed.' + CALL LOG_MESSAGE( LOGDEV,' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + DESID_SD_NML%STREAM = '' + DESID_SD_NML%MODE = '' + DESID_SD_NML%MODE_REF = '' + ELSE IF ( IOST .NE. 0 ) THEN + ! Read Error Detected for DESID_SD_NML + backspace( FUNIT ) + read( FUNIT, fmt='(A)' ) tmpline + XMSG = 'ERROR: There was a syntax error reading the Desid_SizeDist '// + & 'variable for use by the DESID module. Please check the format of '// + & 'each line for syntax errors. The invalid line was likely: ' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + WRITE( LOGDEV, '(8x,A)' ) TMPLINE + CALL M3EXIT ( 'DESID_READ_NAMELIST', 0, 0, 'CMAQ must Crash until you '// + & 'fix the Size Distribution Rule', 1 ) + END IF + + !----------------------------------! + !!! DESID Diagnostic File Inputs !!! + ! Read the number of Max Emissions Rules to inform scaling operations + REWIND( FUNIT ) + READ( NML = Desid_DiagVars, UNIT = FUNIT, IOSTAT=IOST ) + IF ( IOST .EQ. -1 ) THEN + ! The DESID_N_Diag_Rules Variable was completely missing + XMSG = 'WARNING: Number of DESID Diagnostic Rules was not specified. '// + & 'If you intended to specify Desid_N_Diag_Rules, check the DESID_CTRL file.' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + DESID_N_DIAG_RULES = 0 + DESID_MAX_DIAG_STREAMS = 0 + DESID_MAX_DIAG_SPEC = 0 + + ELSE IF ( IOST .NE. 0 ) THEN + ! Read Error Detected for DESID_N_DIAG_RULES + backspace( FUNIT ) + read( FUNIT, fmt='(A)' ) tmpline + XMSG = 'ERROR: There was a syntax error reading the number of '// + & 'Diagnostic Rules for use by the DESID module. Please '// + & 'check the format of each line for syntax errors. The '// + & 'invalid line was likely: ' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + WRITE( LOGDEV, '(8x,A)' ) TMPLINE + CALL M3EXIT ( 'DESID_READ_NAMELIST', 0, 0, 'CMAQ must Crash until you '// + & 'fix Desid_N_Diag_Rules', 1 ) + END IF + + ! Allocate and Initialize Namelist Variables + ALLOCATE( DESID_DIAG_STREAMS_NML( DESID_N_DIAG_RULES,DESID_MAX_DIAG_SPEC ), + & DESID_DIAG_FMT_NML( DESID_N_DIAG_RULES ), + & DESID_DIAG_SPEC_NML( DESID_N_DIAG_RULES,DESID_MAX_DIAG_SPEC ), + & STAT=IOST ) + CALL CHECKMEM( IOST, 'DESID_DIAG_NML','DESID_READ_NAMELIST') + Desid_Diag_Streams_Nml = '' + Desid_Diag_Fmt_Nml = '' + Desid_Diag_Spec_Nml = '' + + ! Read the Emissions Diagnostic Section + REWIND( FUNIT ) + READ( NML = Desid_Diag, UNIT = FUNIT, IOSTAT=IOST ) + IF ( IOST .EQ. -1 ) THEN + ! The Emissions Diagnostic Section was completely missing + XMSG = 'WARNING: There were no valid Emission Diagnostic Values specified '// + & 'for use by the DESID module. If you intended to specify '// + & 'diagnostic output in the emission control interface, check the '// + & 'file you have provided for DESID_CTRL_NML.' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + Desid_Diag_Streams_Nml = '' + Desid_Diag_Fmt_Nml = '' + Desid_Diag_Spec_Nml = '' + ELSE IF ( IOST .NE. 0 ) THEN + ! Read Error for Emissions Diagnostic + backspace( FUNIT ) + read( FUNIT, fmt='(A)' ) tmpline + XMSG = 'ERROR: There was a syntax error reading Emission Diagnostic '// + & 'Variables for output by the DESID module. Please check the format of '// + & 'each line for syntax errors. The invalid line was likely: ' + CALL LOG_MESSAGE( LOGDEV, ' ') + CALL LOG_MESSAGE( LOGDEV, XMSG ) + WRITE( LOGDEV, '(8x,A)' ) TMPLINE + CALL M3EXIT ( 'DESID_READ_NAMELIST', 0, 0, 'CMAQ must Crash until you '// + & 'fix the Emission Diagnostic Specification.', 1 ) + END IF + + CLOSE( UNIT = FUNIT ) + + END SUBROUTINE DESID_READ_NAMELIST + +!#ifdef mpas +! ------------------------------------------------------------------------- +! subroutine r_interpolate_var_1d (vname, date, time, data) +! +! use hgrd_defn, only : ncols, nrows +! use vgrd_defn, only : nlays +! USE UTILIO_DEFN +! use centralized_io_util_module, only : binary_search +! +! character (*), intent(in) :: vname +! integer, intent(in) :: date, time +! real, intent(out) :: data(:) +! +! integer :: var_loc +! character (40) :: msg +! +! var_loc = binary_search (vname, vname_2d, n2d_data) +! +! if (var_loc .gt. 0) then +! data = g2ddata(:,1,var_loc) +! else +! write (msg, *) ' Error: Cannot find species ', trim(vname) +! call prog_interrupt ( 'interpolate_var', 0, 0, msg, 1) +! end if +! +! end subroutine r_interpolate_var_1d +! +!! ------------------------------------------------------------------------- +! subroutine r_interpolate_var_1ds (fname, vname, date, time, data) +! +! use stk_prms, only : my_strt_src, my_end_src, my_nsrc +! use util_module, only : nextime, secsdiff +! use centralized_io_util_module, only : binary_search +! use util_module, only : time2sec +! +! character (*), intent(in) :: fname, vname +! integer, intent(in) :: date, time +! real, intent(out) :: data(:) +! +! integer :: head_beg_ind, head_end_ind, +! & tail_beg_ind, tail_end_ind, +! & store_beg_ind, store_end_ind, +! & var_loc, loc_head, loc_tail, m, r, c, +! & loc_jdate, loc_jtime, dsize, pt, loc_tstep +! integer, save :: prev_time = -1 +! integer, save :: prev_head_time = -1 +! integer, save :: prev_tail_time = -1 +! integer, save :: lcount = 0 +! real, save :: ratio1, ratio2 +! character(200) :: xmsg +! +! pt = binary_search (fname, cio_stack_file_name, NPTGRPS) +! +! var_loc = binary_search (vname, cio_stack_var_name(:,pt), n_cio_stack_emis_vars(pt)) +! +! if (var_loc .lt. 0) then +! write (cio_logdev, '(a9, a, a33)') 'Warning: ', trim(vname), ' is not available in a stack file.' +! write (xmsg, '(A9,A,A,A)' ) 'ERROR: ',trim(vname), ' is not available ', +! & 'on a Stack Emisison file. Simulation will now terminate.' +! call m3exit ( 'Centralized I/O Module', date, time, xmsg, 1 ) +! else +! dsize = my_nsrc(pt) +! +! loc_tstep = file_tstep(f_stk_emis(pt)) +! +! loc_head = head_stack_emis(var_loc, pt) +! loc_tail = tail_stack_emis(var_loc, pt) +! +! if ((cio_stack_emis_data_tstamp(1, loc_tail, var_loc, pt) .lt. date) .or. +!! & ((cio_stack_emis_data_tstamp(1, loc_tail, var_loc, pt) .eq. date) .and. +!! & (cio_stack_emis_data_tstamp(2, loc_tail, var_loc, pt) .eq. 0)) .or. +! & ((cio_stack_emis_data_tstamp(2, loc_tail, var_loc, pt) .lt. time) .and. +! & (cio_stack_emis_data_tstamp(1, loc_tail, var_loc, pt) .eq. date))) then +! +! loc_jdate = cio_stack_emis_data_tstamp(1, loc_tail, var_loc, pt) +! loc_jtime = cio_stack_emis_data_tstamp(2, loc_tail, var_loc, pt) +! CALL NEXTIME ( loc_jdate, loc_jtime, loc_tstep ) +! call retrieve_stack_data_mpas (loc_jdate, loc_jtime, fname, vname) +! loc_head = head_stack_emis(var_loc, pt) +! loc_tail = tail_stack_emis(var_loc, pt) +! end if +! +! if ((cio_stack_emis_data_tstamp(1, 2, var_loc, pt) .eq. date) .and. +! & (cio_stack_emis_data_tstamp(2, 2, var_loc, pt) .eq. time)) then +! count = count + 1 +! else +! +! cio_stack_emis_data_tstamp(1, 2, var_loc, pt) = date +! cio_stack_emis_data_tstamp(2, 2, var_loc, pt) = time +! +! if ((prev_time .ne. time) .or. +! & (prev_head_time .ne. cio_stack_emis_data_tstamp(2, loc_head, var_loc, pt)) .or. +! & (prev_tail_time .ne. cio_stack_emis_data_tstamp(2, loc_tail, var_loc, pt))) then +! +! if (cio_stack_emis_data_tstamp(1, loc_head, var_loc, pt) .eq. date) then +! ratio2 = real(secsdiff(time, cio_stack_emis_data_tstamp(2, loc_head, var_loc, pt))) +! & / real(time2sec(loc_tstep)) +! ratio1 = 1.0 - ratio2 +! else +! ratio2 = real(secsdiff(240000, cio_stack_emis_data_tstamp(2, loc_head, var_loc, pt))) +! & / real(time2sec(loc_tstep)) +! ratio1 = 1.0 - ratio2 +! end if +! prev_time = time +! prev_head_time = cio_stack_emis_data_tstamp(2, loc_head, var_loc, pt) +! prev_tail_time = cio_stack_emis_data_tstamp(2, loc_tail, var_loc, pt) +! +! if ( (ratio1 .lt. 0) .or. (ratio2 .lt. 0) +! & .or. (ratio1 .gt. 1) .or. (ratio2 .gt. 1)) then +! write(logdev,'(5X,a,a)'), +! & 'ERROR: Incorrect Interpolation in 1-D Stack Interpolation for variable: ', +! & trim(vname) +! +! write(logdev,'(5X,a,i7,a,i6)'), +! & 'Requested TIME & DATE: ',date,':',time +! +! write(logdev,'(5X,a,i7,a,i6,a,i7,a,i6)'), +! & 'Interpolation Bounds ',cio_stack_emis_data_tstamp(1,0,var_loc,pt), +! & ':',cio_stack_emis_data_tstamp(2,0,var_loc,pt),' to ', +! & cio_stack_emis_data_tstamp(1,1,var_loc,pt),':',cio_stack_emis_data_tstamp(2,1,var_loc,pt) +! call m3exit( 'Centralized I/O',date,time,'',1 ) +! write(logdev,'(5X,a)'), +! & 'ERROR: Program EXIT in subroutine r_interpolate_var_1ds in module centralized io' +! end if +! else +! lcount = lcount + 1 +! end if +! +! head_beg_ind = cio_stack_emis_data_inx(1,loc_head,var_loc, pt) +! head_end_ind = cio_stack_emis_data_inx(2,loc_head,var_loc, pt) +! tail_beg_ind = cio_stack_emis_data_inx(1,loc_tail,var_loc, pt) +! tail_end_ind = cio_stack_emis_data_inx(2,loc_tail,var_loc, pt) +! store_beg_ind = cio_stack_emis_data_inx(1,2,var_loc, pt) +! store_end_ind = cio_stack_emis_data_inx(2,2,var_loc, pt) +! +! cio_stack_data(store_beg_ind:store_end_ind) = cio_stack_data(head_beg_ind:head_end_ind) * ratio1 +! & + cio_stack_data(tail_beg_ind:tail_end_ind) * ratio2 +! +! end if +! +! store_beg_ind = cio_stack_emis_data_inx(1,2,var_loc, pt) +! +! data(1:dsize) = cio_stack_data(store_beg_ind:store_beg_ind+dsize-1) +! +! end if +! +! end subroutine r_interpolate_var_1ds +! +!! ------------------------------------------------------------------------- +! subroutine r_interpolate_var_2d (vname, date, time, data, +! & scol, ecol, srow, erow, slay) +! +! use hgrd_defn, only : ncols, nrows +! use vgrd_defn, only : nlays +! USE UTILIO_DEFN +! use centralized_io_util_module, only : binary_search +! +! character (*), intent(in) :: vname +! integer, intent(in) :: date, time +! real, intent(out) :: data(:,:) +! integer, intent(in), optional :: scol, ecol, srow, erow, slay +! +! integer :: var_loc +! character (40) :: msg +! +! var_loc = binary_search (vname, vname_2d, n2d_data) +! +! if (var_loc .gt. 0) then +! data = g2ddata(:,:,var_loc) +! else +! write (msg, *) ' Error: Cannot find species ', trim(vname) +! call prog_interrupt ( 'interpolate_var', 0, 0, msg, 1) +! end if +! +! end subroutine r_interpolate_var_2d +! +!! ------------------------------------------------------------------------- +! subroutine i_interpolate_var_2d (vname, date, time, data) +! +! use hgrd_defn, only : ncols, nrows +! use vgrd_defn, only : nlays +! USE UTILIO_DEFN +! use centralized_io_util_module, only : binary_search +! +! character (*), intent(in) :: vname +! integer, intent(in) :: date, time +! integer, intent(out) :: data(:,:) +! +! integer :: var_loc +! character (40) :: msg +! +! var_loc = binary_search (vname, vname_2d, n2d_data) +! +! if (var_loc .gt. 0) then +! data = g2ddata(:,:,var_loc) +! else +! write (msg, *) ' Error: Cannot find species ', trim(vname) +! call prog_interrupt ( 'interpolate_var', 0, 0, msg, 1) +! end if +! +! end subroutine i_interpolate_var_2d +! +!! ------------------------------------------------------------------------- +! subroutine r_interpolate_var_2dx (vname, date, time, data, flag) +! +! use hgrd_defn, only : ncols, nrows +! use vgrd_defn, only : nlays +! USE UTILIO_DEFN +! use centralized_io_util_module, only : binary_search +! +! character (*), intent(in) :: vname +! integer, intent(in) :: date, time +! logical, intent(in) :: flag +! real, intent(out) :: data(:,:) +! +! integer :: var_loc +! character (40) :: msg +! +! var_loc = binary_search (vname, vname_2d, n2d_data) +! +! if (var_loc .gt. 0) then +! data = g2ddata(:,:,var_loc) +! else +! write (msg, *) ' Error: Cannot find species ', trim(vname) +! call prog_interrupt ( 'interpolate_var', 0, 0, msg, 1) +! end if +! +! end subroutine r_interpolate_var_2dx +! +!! ------------------------------------------------------------------------- +! subroutine r_interpolate_var_3d (vname, date, time, data, fname) +! +! use hgrd_defn, only : ncols, nrows +! USE UTILIO_DEFN +! use util_module, only : nextime, secsdiff +! use centralized_io_util_module, only : binary_search +! use util_module, only : time2sec +! +! character (*), intent(in) :: vname +! integer, intent(in) :: date, time +! real, intent(out) :: data(:,:,:) +! character (*), intent(in), optional :: fname +! +! integer :: var_loc, slen, loc_head, loc_tail, +! & loc_jdate, loc_jtime, beg_k, end_k, +! & m, k, r, c, +! & head_beg_ind, head_end_ind, +! & tail_beg_ind, tail_end_ind, +! & store_beg_ind, store_end_ind, loc_tstep, fnum +! integer, save :: prev_time = -1 +! integer, save :: prev_head_time = -1 +! integer, save :: lcount = 0 +! real, save :: ratio1, ratio2 +! character (40) :: msg, loc_vname +! character (20) :: loc_mpas_time_stamp +! +! if (present(fname)) then +! slen = len_trim(fname) +! loc_vname = trim(vname) // fname(slen-3:slen) +! else +! loc_vname = vname +! end if +! +! var_loc = binary_search (loc_vname, vname_3d, n3d_data) +! +! if (var_loc .gt. 0) then +! data = g3ddata(:,:,:,var_loc) +! else +! +! var_loc = binary_search (loc_vname, cio_grid_var_name(:,1), n_cio_grid_vars) +! +! if (var_loc .lt. 0) then +! write (msg, *) ' Error: Cannot find species ', trim(vname) +! call prog_interrupt ( 'interpolate_var', 0, 0, msg, 1) +! else +! loc_head = head_grid(var_loc) +! loc_tail = tail_grid(var_loc) +! +! +! if (cio_grid_var_name(var_loc,3) == 'm') then +! loc_tstep = file_tstep(f_met) +! else if ((cio_grid_var_name(var_loc,2) == 'e2d') .or. +! & (cio_grid_var_name(var_loc,2) == 'e3d')) then +! +! slen = len_trim(cio_grid_var_name(var_loc,1)) +! read (cio_grid_var_name(var_loc,1)(slen-2:slen), *) fnum +! +! loc_tstep = file_tstep(f_emis(fnum)) +! else if (cio_grid_var_name(var_loc,2) == 'lnt') then +! loc_tstep = file_tstep(f_ltng) +! else if (cio_grid_var_name(var_loc,2) == 'ic') then +! loc_tstep = file_tstep(f_icon) +! else if (cio_grid_var_name(var_loc,2) == 'bct') then +! loc_tstep = file_tstep(f_bcon) +! else if (cio_grid_var_name(var_loc,2) == 'is') then +! loc_tstep = file_tstep(f_is_icon) +! end if +! +! call julian_to_mpas_date_time (date, time, loc_mpas_time_stamp) +! +! if (cio_mpas_grid_data_tstamp(loc_tail, var_loc) .lt. loc_mpas_time_stamp) then +! +! call mpas_date_time_to_julian (cio_mpas_grid_data_tstamp(loc_tail, var_loc), loc_jdate, loc_jtime) +! +! call retrieve_time_dep_gridded_data (loc_jdate, loc_jtime, loc_vname) +! loc_head = head_grid(var_loc) +! loc_tail = tail_grid(var_loc) +! end if +! +! if ((cio_grid_data_tstamp(1, 2, var_loc) .eq. date) .and. +! & (cio_grid_data_tstamp(2, 2, var_loc) .eq. time)) then +! count = count + 1 +! else +! +! cio_grid_data_tstamp(1, 2, var_loc) = date +! cio_grid_data_tstamp(2, 2, var_loc) = time +! +! +! if ((prev_time .ne. time) .or. +! & (prev_head_time .ne. cio_grid_data_tstamp(2, loc_head, var_loc))) then +! if (cio_grid_data_tstamp(1, loc_head, var_loc) .eq. date) then +! ratio2 = real(secsdiff(time, cio_grid_data_tstamp(2, loc_head, var_loc))) +! & / real(time2sec(loc_tstep)) +! ratio1 = 1.0 - ratio2 +! else +! ratio2 = real(secsdiff(240000, cio_grid_data_tstamp(2, loc_head, var_loc))) +! & / real(time2sec(loc_tstep)) +! ratio1 = 1.0 - ratio2 +! end if +! prev_time = time +! prev_head_time = cio_grid_data_tstamp(2, loc_head, var_loc) +! else +! lcount = lcount + 1 +! end if +! +! head_beg_ind = cio_grid_data_inx(1,loc_head,var_loc) +! head_end_ind = cio_grid_data_inx(2,loc_head,var_loc) +! tail_beg_ind = cio_grid_data_inx(1,loc_tail,var_loc) +! tail_end_ind = cio_grid_data_inx(2,loc_tail,var_loc) +! store_beg_ind = cio_grid_data_inx(1,2,var_loc) +! store_end_ind = cio_grid_data_inx(2,2,var_loc) +! +! cio_grid_data(store_beg_ind:store_end_ind) = cio_grid_data(head_beg_ind:head_end_ind) * ratio1 +! & + cio_grid_data(tail_beg_ind:tail_end_ind) * ratio2 +! +! end if +! +! beg_k = 1 +! if (cio_grid_var_name(var_loc, 2) .eq. 'e2d') then +! end_k = 1 +! else +! end_k = size(data,3) +! end if +! +! store_beg_ind = cio_grid_data_inx(1,2,var_loc) +! m = store_beg_ind - 1 +! do k = beg_k, end_k +! do r = 1, size(data,2) +! do c = 1, size(data,1) +! m = m + 1 +! data(c,r,k) = cio_grid_data(m) +! end do +! end do +! end do +! +! end if +! end if +! +! end subroutine r_interpolate_var_3d +! +!#else +! ------------------------------------------------------------------------- + subroutine r_interpolate_var_1ds (fname, vname, date, time, data) + +! Function: Interpolation for Stack Group Real 1-D Data + + USE UTILIO_DEFN + USE STK_PRMS, only : MY_STRT_SRC, MY_END_SRC + + character (*), intent(in) :: fname, vname + integer, intent(in) :: date, time + real, intent(out) :: data(:) + + integer :: head_beg_ind, head_end_ind, + & tail_beg_ind, tail_end_ind, + & store_beg_ind, store_end_ind, + & var_loc, loc_head, loc_tail, m, r, c, + & loc_jdate, loc_jtime, dsize, pt, loc_tstep + integer, save :: prev_time = -1 + integer, save :: prev_head_time = -1 + integer, save :: prev_tail_time = -1 + integer, save :: lcount = 0 + real, save :: ratio1, ratio2 + character(200) :: xmsg + + pt = binary_search (fname, cio_stack_file_name, NPTGRPS) + + var_loc = binary_search (vname, cio_stack_var_name(:,pt), n_cio_stack_emis_vars(pt)) + + if (var_loc .lt. 0) then + write (cio_logdev, '(a9, a, a33)') 'Warning: ', trim(vname), ' is not available in a stack file.' + write (xmsg, '(A9,A,A,A)' ) 'ERROR: ',trim(vname), ' is not available ', + & 'on a Stack Emisison file. Simulation will now terminate.' + call m3exit ( 'Centralized I/O Module', date, time, xmsg, 1 ) + else + dsize = MY_END_SRC( pt ) - MY_STRT_SRC( pt ) + 1 + + loc_tstep = file_tstep(f_stk_emis(pt)) + + loc_head = head_stack_emis(var_loc, pt) + loc_tail = tail_stack_emis(var_loc, pt) + + if ((cio_stack_emis_data_tstamp(1, loc_tail, var_loc, pt) .lt. date) .or. +! & ((cio_stack_emis_data_tstamp(1, loc_tail, var_loc, pt) .eq. date) .and. +! & (cio_stack_emis_data_tstamp(2, loc_tail, var_loc, pt) .eq. 0)) .or. + & ((cio_stack_emis_data_tstamp(2, loc_tail, var_loc, pt) .lt. time) .and. + & (cio_stack_emis_data_tstamp(1, loc_tail, var_loc, pt) .eq. date))) then + + loc_jdate = cio_stack_emis_data_tstamp(1, loc_tail, var_loc, pt) + loc_jtime = cio_stack_emis_data_tstamp(2, loc_tail, var_loc, pt) + CALL NEXTIME ( loc_jdate, loc_jtime, loc_tstep ) + call retrieve_stack_data (loc_jdate, loc_jtime, fname, vname) + loc_head = head_stack_emis(var_loc, pt) + loc_tail = tail_stack_emis(var_loc, pt) + end if + + if ((cio_stack_emis_data_tstamp(1, 2, var_loc, pt) .eq. date) .and. + & (cio_stack_emis_data_tstamp(2, 2, var_loc, pt) .eq. time)) then + count = count + 1 + else + + cio_stack_emis_data_tstamp(1, 2, var_loc, pt) = date + cio_stack_emis_data_tstamp(2, 2, var_loc, pt) = time + + if ((prev_time .ne. time) .or. + & (prev_head_time .ne. cio_stack_emis_data_tstamp(2, loc_head, var_loc, pt)) .or. + & (prev_tail_time .ne. cio_stack_emis_data_tstamp(2, loc_tail, var_loc, pt))) then + + if (cio_stack_emis_data_tstamp(1, loc_head, var_loc, pt) .eq. date) then + ratio2 = real(time_diff(time, cio_stack_emis_data_tstamp(2, loc_head, var_loc, pt))) + & / real(time2sec(loc_tstep)) + ratio1 = 1.0 - ratio2 + else + ratio2 = real(time_diff(240000, cio_stack_emis_data_tstamp(2, loc_head, var_loc, pt))) + & / real(time2sec(loc_tstep)) + ratio1 = 1.0 - ratio2 + end if + prev_time = time + prev_head_time = cio_stack_emis_data_tstamp(2, loc_head, var_loc, pt) + prev_tail_time = cio_stack_emis_data_tstamp(2, loc_tail, var_loc, pt) + +#ifdef verbose_cio + if ( (ratio1 .lt. 0) .or. (ratio2 .lt. 0) + & .or. (ratio1 .gt. 1) .or. (ratio2 .gt. 1)) then + write(logdev,'(5X,a,a)'), + & 'ERROR: Incorrect Interpolation in 1-D Stack Interpolation for variable: ', + & trim(vname) + + write(logdev,'(5X,a,i7,a,i6)'), + & 'Requested TIME & DATE: ',date,':',time + + write(logdev,'(5X,a,i7,a,i6,a,i7,a,i6)'), + & 'Interpolation Bounds ',cio_stack_emis_data_tstamp(1,0,var_loc,pt), + & ':',cio_stack_emis_data_tstamp(2,0,var_loc,pt),' to ', + & cio_stack_emis_data_tstamp(1,1,var_loc,pt),':',cio_stack_emis_data_tstamp(2,1,var_loc,pt) + call m3exit( 'Centralized I/O',date,time,'',1 ) + write(logdev,'(5X,a)'), + & 'ERROR: Program EXIT in subroutine r_interpolate_var_1ds in module centralized io' + end if +#endif + else + lcount = lcount + 1 + end if + + head_beg_ind = cio_stack_emis_data_inx(1,loc_head,var_loc, pt) + head_end_ind = cio_stack_emis_data_inx(2,loc_head,var_loc, pt) + tail_beg_ind = cio_stack_emis_data_inx(1,loc_tail,var_loc, pt) + tail_end_ind = cio_stack_emis_data_inx(2,loc_tail,var_loc, pt) + store_beg_ind = cio_stack_emis_data_inx(1,2,var_loc, pt) + store_end_ind = cio_stack_emis_data_inx(2,2,var_loc, pt) + + cio_stack_data(store_beg_ind:store_end_ind) = cio_stack_data(head_beg_ind:head_end_ind) * ratio1 + & + cio_stack_data(tail_beg_ind:tail_end_ind) * ratio2 + + end if + + store_beg_ind = cio_stack_emis_data_inx(1,2,var_loc, pt) + + data(1:dsize) = cio_stack_data(store_beg_ind:store_beg_ind+dsize-1) + + end if + + end subroutine r_interpolate_var_1ds + +! ------------------------------------------------------------------------- + subroutine r_interpolate_var_2d (vname, date, time, data, + & scol, ecol, srow, erow, slay) + +! Function: Interpolation for generic Real 2-D Data + + USE UTILIO_DEFN + use HGRD_DEFN, only : ncols, nrows + USE VGRD_DEFN, ONLY : NLAYS + + character (*), intent(in) :: vname + integer, intent(in) :: date, time + real, intent(out) :: data(:,:) + integer, intent(in), optional :: scol, ecol, srow, erow, slay + + integer :: head_beg_ind, head_end_ind, + & tail_beg_ind, tail_end_ind, + & store_beg_ind, store_end_ind, + & var_loc, loc_head, loc_tail, m, r, c, + & loc_jdate, loc_jtime, adj_lvl, adj1, adj2, + & loc_size_spatial, loc_tstep, str_len, fnum + integer, save :: prev_time = -1 + integer, save :: prev_head_time = -1 + integer, save :: prev_tail_time = -1 + integer, save :: lcount = 0 + real, save :: ratio1, ratio2 + character(200) :: xmsg + + var_loc = binary_search (vname, cio_grid_var_name(:,1), n_cio_grid_vars) + if (var_loc .lt. 0) then + write (xmsg, '(A9,A,A,A)' ) 'ERROR: ',trim(vname), ' is not available ', + & 'on any 2D file. Simulation will now terminate.' + call m3exit ( 'Centralized I/O Module', date, time, xmsg, 1 ) + else + loc_head = head_grid(var_loc) + loc_tail = tail_grid(var_loc) + + if (cio_grid_var_name(var_loc,3) == 'm') then + loc_tstep = file_tstep(f_met) + else if ((cio_grid_var_name(var_loc,2) == 'e2d') .or. + & (cio_grid_var_name(var_loc,2) == 'e3d')) then + + str_len = len_trim(cio_grid_var_name(var_loc,1)) + read (cio_grid_var_name(var_loc,1)(str_len-2:str_len), *) fnum + + loc_tstep = file_tstep(f_emis(fnum)) + else if (cio_grid_var_name(var_loc,2) == 'lnt') then + loc_tstep = file_tstep(f_ltng) + else if (cio_grid_var_name(var_loc,2) == 'ic') then + loc_tstep = file_tstep(f_icon) + else if (cio_grid_var_name(var_loc,2) == 'bct') then + loc_tstep = file_tstep(f_bcon) + else if (cio_grid_var_name(var_loc,2) == 'is') then + loc_tstep = file_tstep(f_is_icon) + end if + + if (cio_grid_var_name(var_loc,2) .eq. 'md3') then + loc_size_spatial = size_d2dx + else + loc_size_spatial = size_c3d / nlays + end if + + if ((cio_grid_data_tstamp(1, loc_tail, var_loc) .lt. date) .or. + & ((cio_grid_data_tstamp(2, loc_tail, var_loc) .lt. time) .and. + & (cio_grid_data_tstamp(1, loc_tail, var_loc) .eq. date))) then + + loc_jdate = cio_grid_data_tstamp(1, loc_tail, var_loc) + loc_jtime = cio_grid_data_tstamp(2, loc_tail, var_loc) + + CALL NEXTIME ( loc_jdate, loc_jtime, loc_tstep ) + + call retrieve_time_dep_gridded_data (loc_jdate, loc_jtime, vname) + loc_head = head_grid(var_loc) + loc_tail = tail_grid(var_loc) + end if + + if ((cio_grid_data_tstamp(1, 2, var_loc) .eq. date) .and. + & (cio_grid_data_tstamp(2, 2, var_loc) .eq. time)) then + count = count + 1 + else + + cio_grid_data_tstamp(1, 2, var_loc) = date + cio_grid_data_tstamp(2, 2, var_loc) = time + + if ((prev_time .ne. time) .or. + & (prev_head_time .ne. cio_grid_data_tstamp(2, loc_head, var_loc)) .or. + & (prev_tail_time .ne. cio_grid_data_tstamp(2, loc_tail, var_loc))) then + + if (cio_grid_data_tstamp(1, loc_head, var_loc) .eq. date) then + ratio2 = real(time_diff(time, cio_grid_data_tstamp(2, loc_head, var_loc))) + & / real(time2sec(loc_tstep)) + ratio1 = 1.0 - ratio2 + else + ratio2 = real(time_diff(240000, cio_grid_data_tstamp(2, loc_head, var_loc))) + & / real(time2sec(loc_tstep)) + ratio1 = 1.0 - ratio2 + end if + prev_time = time + prev_head_time = cio_grid_data_tstamp(2, loc_head, var_loc) + prev_tail_time = cio_grid_data_tstamp(2, loc_tail, var_loc) + +#ifdef verbose_cio + if ( (ratio1 .lt. 0) .or. (ratio2 .lt. 0) + & .or. (ratio1 .gt. 1) .or. (ratio2 .gt. 1)) then + write(logdev,'(5X,a,a)'), + & 'ERROR: Incorrect Interpolation in 2-D Generic Real Interpolation for variable: ', + & trim(vname) + + write(logdev,'(5X,a,i7,a,i6)'), + & 'Requested TIME & DATE: ',date,':',time + + write(logdev,'(5X,a,i7,a,i6,a,i7,a,i6)'), + & 'Interpolation Bounds ',cio_grid_data_tstamp(1,0,var_loc), + & ':',cio_grid_data_tstamp(2,0,var_loc),' to ', + & cio_grid_data_tstamp(1,1,var_loc),':',cio_grid_data_tstamp(2,1,var_loc) + + write(logdev,'(5X,a)'), + & 'ERROR: Program EXIT in subroutine r_interpolate_var_2d in module centralized io' + + call m3exit( 'Centralized I/O',date,time,'',1 ) + end if +#endif + else + lcount = lcount + 1 + end if + + head_beg_ind = cio_grid_data_inx(1,loc_head,var_loc) + head_end_ind = cio_grid_data_inx(2,loc_head,var_loc) + tail_beg_ind = cio_grid_data_inx(1,loc_tail,var_loc) + tail_end_ind = cio_grid_data_inx(2,loc_tail,var_loc) + store_beg_ind = cio_grid_data_inx(1,2,var_loc) + store_end_ind = cio_grid_data_inx(2,2,var_loc) + + cio_grid_data(store_beg_ind:store_end_ind) = cio_grid_data(head_beg_ind:head_end_ind) * ratio1 + & + cio_grid_data(tail_beg_ind:tail_end_ind) * ratio2 + end if + + adj_lvl = 0 + adj1 = 0 + adj2 = 0 + if (present(slay)) then + if (cio_grid_var_name(var_loc,2) .eq. 'mc3') then + if ((window) .and. + & ((size(data,1) - ncols) .eq. 0)) then + adj1 = ncols + 3 + adj2 = 2 + end if + adj_lvl = (slay - 1) * loc_size_spatial + else if (cio_grid_var_name(var_loc,2) .eq. 'md3') then + adj_lvl = (slay - 1) * size_d2dx +#ifndef twoway + if (.not. east_pe) then + adj2 = 1 + end if +#endif + end if + else if (cio_grid_var_name(var_loc,2) .eq. 'mc2') then +#ifndef twoway + if (.not. east_pe) then + adj2 = 1 + end if +#endif + end if + + store_beg_ind = cio_grid_data_inx(1,2,var_loc) + m = store_beg_ind - 1 + adj_lvl + adj1 + + do r = 1, size(data,2) + do c = 1, size(data,1) + m = m + 1 + data(c,r) = cio_grid_data(m) + end do + m = m + adj2 + end do + end if + + end subroutine r_interpolate_var_2d + +! ------------------------------------------------------------------------- + subroutine i_interpolate_var_2d (vname, date, time, data) + +! Function: Interpolation for generic 4 byte Integer 2-D Data + + USE UTILIO_DEFN + use HGRD_DEFN, only : ncols, nrows + USE VGRD_DEFN, ONLY : NLAYS + + character (*), intent(in) :: vname + integer, intent(in) :: date, time + integer, intent(out) :: data(:,:) + + integer :: head_beg_ind, head_end_ind, + & tail_beg_ind, tail_end_ind, + & store_beg_ind, store_end_ind, + & var_loc, loc_head, loc_tail, m, r, c, + & loc_jdate, loc_jtime, adj_lvl, adj1, adj2, + & loc_size_spatial, loc_tstep, str_len, fnum + integer, save :: prev_time = -1 + integer, save :: prev_head_time = -1 + integer, save :: prev_tail_time = -1 + integer, save :: lcount = 0 + real, save :: ratio1, ratio2 + character(200) :: xmsg + + var_loc = binary_search (vname, cio_grid_var_name(:,1), n_cio_grid_vars) + if (var_loc .lt. 0) then + write (xmsg, '(A9,A,A,A)' ) 'ERROR: ',trim(vname), ' is not available ', + & 'on any 2D file. Simulation will now terminate.' + call m3exit ( 'Centralized I/O Module', date, time, xmsg, 1 ) + else + loc_head = head_grid(var_loc) + loc_tail = tail_grid(var_loc) + + if (cio_grid_var_name(var_loc,3) == 'm') then + loc_tstep = file_tstep(f_met) + else if ((cio_grid_var_name(var_loc,2) == 'e2d') .or. + & (cio_grid_var_name(var_loc,2) == 'e3d')) then + + str_len = len_trim(cio_grid_var_name(var_loc,1)) + read (cio_grid_var_name(var_loc,1)(str_len-2:str_len), *) fnum + + loc_tstep = file_tstep(f_emis(fnum)) + else if (cio_grid_var_name(var_loc,2) == 'lnt') then + loc_tstep = file_tstep(f_ltng) + else if (cio_grid_var_name(var_loc,2) == 'ic') then + loc_tstep = file_tstep(f_icon) + else if (cio_grid_var_name(var_loc,2) == 'bct') then + loc_tstep = file_tstep(f_bcon) + else if (cio_grid_var_name(var_loc,2) == 'is') then + loc_tstep = file_tstep(f_is_icon) + end if + + if (cio_grid_var_name(var_loc,2) .eq. 'md3') then + loc_size_spatial = size_d2dx + else + loc_size_spatial = size_c3d / nlays + end if + + if ((cio_grid_data_tstamp(1, loc_tail, var_loc) .lt. date) .or. + & ((cio_grid_data_tstamp(2, loc_tail, var_loc) .lt. time) .and. + & (cio_grid_data_tstamp(1, loc_tail, var_loc) .eq. date))) then + + loc_jdate = cio_grid_data_tstamp(1, loc_tail, var_loc) + loc_jtime = cio_grid_data_tstamp(2, loc_tail, var_loc) + CALL NEXTIME ( loc_jdate, loc_jtime, loc_tstep ) + call retrieve_time_dep_gridded_data (loc_jdate, loc_jtime, vname) + loc_head = head_grid(var_loc) + loc_tail = tail_grid(var_loc) + end if + + if ((cio_grid_data_tstamp(1, 2, var_loc) .eq. date) .and. + & (cio_grid_data_tstamp(2, 2, var_loc) .eq. time)) then + count = count + 1 + else + + cio_grid_data_tstamp(1, 2, var_loc) = date + cio_grid_data_tstamp(2, 2, var_loc) = time + + if ((prev_time .ne. time) .or. + & (prev_head_time .ne. cio_grid_data_tstamp(2, loc_head, var_loc)) .or. + & (prev_tail_time .ne. cio_grid_data_tstamp(2, loc_tail, var_loc))) then + + if (cio_grid_data_tstamp(1, loc_head, var_loc) .eq. date) then + ratio2 = real(time_diff(time, cio_grid_data_tstamp(2, loc_head, var_loc))) + & / real(time2sec(loc_tstep)) + ratio1 = 1.0 - ratio2 + else + ratio2 = real(time_diff(240000, cio_grid_data_tstamp(2, loc_head, var_loc))) + & / real(time2sec(loc_tstep)) + ratio1 = 1.0 - ratio2 + end if + prev_time = time + prev_head_time = cio_grid_data_tstamp(2, loc_head, var_loc) + prev_tail_time = cio_grid_data_tstamp(2, loc_tail, var_loc) + +#ifdef verbose_cio + if ( (ratio1 .lt. 0) .or. (ratio2 .lt. 0) + & .or. (ratio1 .gt. 1) .or. (ratio2 .gt. 1)) then + write(logdev,'(5X,a,a)'), + & 'ERROR: Incorrect Interpolation in 2-D Generic Integer Interpolation for variable: ', + & trim(vname) + + write(logdev,'(5X,a,i7,a,i6)'), + & 'Requested TIME & DATE: ',date,':',time + + write(logdev,'(5X,a,i7,a,i6,a,i7,a,i6)'), + & 'Interpolation Bounds ',cio_grid_data_tstamp(1,0,var_loc), + & ':',cio_grid_data_tstamp(2,0,var_loc),' to ', + & cio_grid_data_tstamp(1,1,var_loc),':',cio_grid_data_tstamp(2,1,var_loc) + + call m3exit( 'Centralized I/O',date,time,'',1 ) + write(logdev,'(5X,a)'), + & 'ERROR: Program EXIT in subroutine i_interpolate_var_2d in module centralized io' + + end if +#endif + else + lcount = lcount + 1 + end if + + head_beg_ind = cio_grid_data_inx(1,loc_head,var_loc) + head_end_ind = cio_grid_data_inx(2,loc_head,var_loc) + tail_beg_ind = cio_grid_data_inx(1,loc_tail,var_loc) + tail_end_ind = cio_grid_data_inx(2,loc_tail,var_loc) + store_beg_ind = cio_grid_data_inx(1,2,var_loc) + store_end_ind = cio_grid_data_inx(2,2,var_loc) + + cio_grid_data(store_beg_ind:store_end_ind) = cio_grid_data(head_beg_ind:head_end_ind) * ratio1 + & + cio_grid_data(tail_beg_ind:tail_end_ind) * ratio2 + + end if + + adj_lvl = 0 + adj1 = 0 + adj2 = 0 + + store_beg_ind = cio_grid_data_inx(1,2,var_loc) + m = store_beg_ind - 1 + adj_lvl + adj1 + + do r = 1, size(data,2) + do c = 1, size(data,1) + m = m + 1 + data(c,r) = int(cio_grid_data(m)) + end do + m = m + adj2 + end do + end if + + end subroutine i_interpolate_var_2d + +! ------------------------------------------------------------------------- + subroutine r_interpolate_var_2db (vname, date, time, data, type, lvl) + +! Function: Interpolation for Boundary Real 2-D Data + + USE UTILIO_DEFN + USE HGRD_DEFN + USE VGRD_DEFN, ONLY : NLAYS + + character (*), intent(in) :: vname + character (1), intent(in) :: type + integer, intent(in) :: date, time + real, intent(out) :: data(:,:) + integer, intent(in), optional :: lvl + + integer :: head_beg_ind, head_end_ind, + & tail_beg_ind, tail_end_ind, + & store_beg_ind, store_end_ind, + & var_loc, loc_head, loc_tail, m, r, c,k, ib, + & loc_jdate, loc_jtime, starting_pt, mype_p1, + & beg_k, end_k, loc_tstep + integer, save :: lns_size, lew_size, gns_size, gew_size, + & ls_start, ls_end, ln_start, ln_end, + & le_start, le_end, lw_start, lw_end, + & gs_skip, ge_skip, gn_skip, gw_skip + logical, save :: loc_firstime = .true. + integer, save :: prev_time = -1 + real :: ratio1, ratio2 + character(200) :: xmsg + + if (loc_firstime) then + loc_firstime = .false. + + mype_p1 = mype + 1 + LNS_SIZE = NTHIK * ( NCOLS + NTHIK ) + LEW_SIZE = NTHIK * ( NROWS + NTHIK ) + + LS_START = 1 + LS_END = LNS_SIZE + LE_START = LS_END + 1 + LE_END = LE_START + LEW_SIZE - 1 + LN_START = LE_END + 1 + LN_END = LN_START + LNS_SIZE - 1 + LW_START = LN_END + 1 + LW_END = LW_START + LEW_SIZE - 1 + + GNS_SIZE = NTHIK * ( GL_NCOLS + NTHIK ) + GEW_SIZE = NTHIK * ( GL_NROWS + NTHIK ) + + GS_SKIP = NTHIK*( COLSX_PE( 1, mype_p1 ) - 1 ) - LS_START + 1 + GE_SKIP = GNS_SIZE + NTHIK*( ROWSX_PE( 1, mype_p1 ) - 1 ) - LE_START + 1 + GN_SKIP = GNS_SIZE + GEW_SIZE + NTHIK*( COLSX_PE( 1, mype_p1 ) - 1 ) - LN_START + 1 + GW_SKIP = 2*GNS_SIZE + GEW_SIZE + NTHIK*( ROWSX_PE( 1, mype_p1 ) - 1 ) - LW_START + 1 + + end if + + var_loc = binary_search (vname, cio_bndy_var_name(:,1), n_cio_bndy_vars) + + if (var_loc .lt. 0) then + write (xmsg, '(A9,A,A,A)' ) 'ERROR: ',trim(vname), ' is not available ', + & 'on any BNDY file. Simulation will now terminate.' + call m3exit ( 'Centralized I/O Module', date, time, xmsg, 1 ) + else + loc_head = head_bndy(var_loc) + loc_tail = tail_bndy(var_loc) + + if (cio_bndy_var_name(var_loc,2) == 'mb') then + loc_tstep = file_tstep(f_met) + else + loc_tstep = file_tstep(f_bcon) + end if + + if (cio_bndy_var_name(var_loc, 2) .ne. 'bc') then + if ((cio_bndy_data_tstamp(1, loc_tail, var_loc) .lt. date) .or. + & ((cio_bndy_data_tstamp(2, loc_tail, var_loc) .lt. time) .and. + & (cio_bndy_data_tstamp(1, loc_tail, var_loc) .eq. date))) then + + loc_jdate = cio_bndy_data_tstamp(1, loc_tail, var_loc) + loc_jtime = cio_bndy_data_tstamp(2, loc_tail, var_loc) + + CALL NEXTIME ( loc_jdate, loc_jtime, loc_tstep ) + + call retrieve_boundary_data (loc_jdate, loc_jtime, vname) + + loc_head = head_bndy(var_loc) + loc_tail = tail_bndy(var_loc) + end if + end if + + if ((cio_bndy_data_tstamp(1, 2, var_loc) .eq. date) .and. + & (cio_bndy_data_tstamp(2, 2, var_loc) .eq. time)) then + count = count + 1 + else + + cio_bndy_data_tstamp(1, 2, var_loc) = date + cio_bndy_data_tstamp(2, 2, var_loc) = time + + head_beg_ind = cio_bndy_data_inx(1,loc_head,var_loc) + head_end_ind = cio_bndy_data_inx(2,loc_head,var_loc) + tail_beg_ind = cio_bndy_data_inx(1,loc_tail,var_loc) + tail_end_ind = cio_bndy_data_inx(2,loc_tail,var_loc) + store_beg_ind = cio_bndy_data_inx(1,2,var_loc) + store_end_ind = cio_bndy_data_inx(2,2,var_loc) + + if (cio_bndy_var_name(var_loc, 2) == 'bc') then + cio_bndy_data(store_beg_ind:store_end_ind) = cio_bndy_data(head_beg_ind:head_end_ind) + else + if (cio_bndy_data_tstamp(1, loc_head, var_loc) .eq. date) then + ratio2 = real(time_diff(time, cio_bndy_data_tstamp(2, loc_head, var_loc))) + & / real(time2sec(loc_tstep)) + ratio1 = 1.0 - ratio2 + else + ratio2 = real(time_diff(240000, cio_bndy_data_tstamp(2, loc_head, var_loc))) + & / real(time2sec(loc_tstep)) + ratio1 = 1.0 - ratio2 + end if + prev_time = time + +#ifdef verbose_cio + if ( (ratio1 .lt. 0) .or. (ratio2 .lt. 0) + & .or. (ratio1 .gt. 1) .or. (ratio2 .gt. 1)) then + write(logdev,'(5X,a)'), + & 'ERROR: Incorrect Interpolation in 2-D Boundary Interpolation for variable: ', + & trim(vname) + + write(logdev,'(5X,a,i7,a,i6)'), + & 'Requested TIME & DATE: ',date,':',time + + write(logdev,'(5X,a,i7,a,i6,a,i7,a,i6)'), + & 'Interpolation Bounds ',cio_bndy_data_tstamp(1,0,var_loc), + & ':',cio_bndy_data_tstamp(2,0,var_loc),' to ', + & cio_bndy_data_tstamp(1,1,var_loc),':',cio_bndy_data_tstamp(2,1,var_loc) + + call m3exit( 'Centralized I/O',date,time,'',1 ) + + write(logdev,'(5X,a)'), + & 'ERROR: Program EXIT in subroutine r_interpolate_var_2db in module centralized io' + + end if +#endif + cio_bndy_data(store_beg_ind:store_end_ind) = cio_bndy_data(head_beg_ind:head_end_ind) * ratio1 + & + cio_bndy_data(tail_beg_ind:tail_end_ind) * ratio2 + + end if + + end if + + if (present(lvl)) then + beg_k = lvl + end_k = lvl + else + beg_k = 1 + end_k = nlays + end if + + data = 0.0 + store_beg_ind = cio_bndy_data_inx(1,2,var_loc) + DO k = beg_k, end_k + starting_pt = store_beg_ind + (k - 1) * size_b2d - 1 +! Construct SOUTH boundary + IF ( SOUTH_PE ) THEN + m = starting_pt + GS_SKIP + DO IB = LS_START, LS_END + data( IB,k ) = cio_bndy_data( m+IB ) + END DO + END IF + +! Construct EAST boundary + IF ( EAST_PE ) THEN + m = starting_pt + GE_SKIP + DO IB = LE_START, LE_END + data( IB,k ) = cio_bndy_data( m+IB) + END DO + END IF + +! Construct NORTH boundary + IF ( NORTH_PE ) THEN + m = starting_pt + GN_SKIP + DO IB = LN_START, LN_END + data( IB,k ) = cio_bndy_data( m+IB) + END DO + END IF + +! Construct WEST boundary + IF ( WEST_PE ) THEN + m = starting_pt + GW_SKIP + DO IB = LW_START, LW_END + data( IB,k ) = cio_bndy_data( m+IB) + END DO + END IF + END DO + + end if + + end subroutine r_interpolate_var_2db + +! ------------------------------------------------------------------------- + subroutine r_interpolate_var_3d (vname, date, time, data, fname) + +!Function: Interpolation for generic Real 3-D Data + + USE UTILIO_DEFN + use HGRD_DEFN, only : ncols, nrows + + character (*), intent(in) :: vname + integer, intent(in) :: date, time + real, intent(out) :: data(:,:,:) + character (*), intent(in), optional :: fname + + integer :: head_beg_ind, head_end_ind, + & tail_beg_ind, tail_end_ind, + & store_beg_ind, store_end_ind, + & var_loc, loc_head, loc_tail, m, r, c, k, + & loc_jdate, loc_jtime, beg_k, end_k, dot, + & col_size, extra_c, extra_r, adj1, adj2, adj3, + & slen, str_len, fnum, loc_tstep + + character (20) :: loc_vname + integer, save :: prev_time = -1 + integer, save :: prev_head_time = -1 + integer, save :: prev_tail_time = -1 + integer, save :: lcount = 0 + real, save :: ratio1, ratio2 + character(200) :: xmsg + + if (present(fname)) then + slen = len_trim(fname) + loc_vname = trim(vname) // fname(slen-3:slen) + else + loc_vname = vname + end if + + var_loc = binary_search (loc_vname, cio_grid_var_name(:,1), n_cio_grid_vars) + if (var_loc .lt. 0) then + write (xmsg, '(A9,A,A,A)' ) 'ERROR: ',trim(vname), ' is not available ', + & 'on any 3D file. Simulation will now terminate.' + call m3exit ( 'Centralized I/O Module', date, time, xmsg, 1 ) + else + loc_head = head_grid(var_loc) + loc_tail = tail_grid(var_loc) + + if (cio_grid_var_name(var_loc,3) == 'm') then + loc_tstep = file_tstep(f_met) + else if ((cio_grid_var_name(var_loc,2) == 'e2d') .or. + & (cio_grid_var_name(var_loc,2) == 'e3d')) then + + str_len = len_trim(cio_grid_var_name(var_loc,1)) + read (cio_grid_var_name(var_loc,1)(str_len-2:str_len), *) fnum + + loc_tstep = file_tstep(f_emis(fnum)) + else if (cio_grid_var_name(var_loc,2) == 'lnt') then + loc_tstep = file_tstep(f_ltng) + else if (cio_grid_var_name(var_loc,2) == 'ic') then + loc_tstep = file_tstep(f_icon) + else if (cio_grid_var_name(var_loc,2) == 'bct') then + loc_tstep = file_tstep(f_bcon) + else if (cio_grid_var_name(var_loc,2) == 'is') then + loc_tstep = file_tstep(f_is_icon) + end if + + if (cio_grid_var_name(var_loc,2) .ne. 'ic') then + if ((cio_grid_data_tstamp(1, loc_tail, var_loc) .lt. date) .or. + & ((cio_grid_data_tstamp(2, loc_tail, var_loc) .lt. time) .and. + & (cio_grid_data_tstamp(1, loc_tail, var_loc) .eq. date))) then + + loc_jdate = cio_grid_data_tstamp(1, loc_tail, var_loc) + loc_jtime = cio_grid_data_tstamp(2, loc_tail, var_loc) + + CALL NEXTIME ( loc_jdate, loc_jtime, loc_tstep ) + + call retrieve_time_dep_gridded_data (loc_jdate, loc_jtime, loc_vname) + loc_head = head_grid(var_loc) + loc_tail = tail_grid(var_loc) + end if + end if + + if ((cio_grid_data_tstamp(1, 2, var_loc) .eq. date) .and. + & (cio_grid_data_tstamp(2, 2, var_loc) .eq. time)) then + count = count + 1 + else + + head_beg_ind = cio_grid_data_inx(1,loc_head,var_loc) + head_end_ind = cio_grid_data_inx(2,loc_head,var_loc) + tail_beg_ind = cio_grid_data_inx(1,loc_tail,var_loc) + tail_end_ind = cio_grid_data_inx(2,loc_tail,var_loc) + store_beg_ind = cio_grid_data_inx(1,2,var_loc) + store_end_ind = cio_grid_data_inx(2,2,var_loc) + + if ((cio_grid_var_name(var_loc, 2) .eq. 'ic') .or. + & (cio_grid_var_name(var_loc, 2) .eq. 'is')) then + cio_grid_data(store_beg_ind:store_end_ind) = cio_grid_data(head_beg_ind:head_end_ind) + else + cio_grid_data_tstamp(1, 2, var_loc) = date + cio_grid_data_tstamp(2, 2, var_loc) = time + + if ((prev_time .ne. time) .or. + & (prev_head_time .ne. cio_grid_data_tstamp(2, loc_head, var_loc)) .or. + & (prev_tail_time .ne. cio_grid_data_tstamp(2, loc_tail, var_loc))) then + + if (cio_grid_data_tstamp(1, loc_head, var_loc) .eq. date) then + ratio2 = real(time_diff(time, cio_grid_data_tstamp(2, loc_head, var_loc))) + & / real(time_to_sec(loc_tstep)) + ratio1 = 1.0 - ratio2 + else + ratio2 = real(time_diff(240000, cio_grid_data_tstamp(2, loc_head, var_loc))) + & / real(time_to_sec(loc_tstep)) + ratio1 = 1.0 - ratio2 + end if + prev_time = time + prev_head_time = cio_grid_data_tstamp(2, loc_head, var_loc) + prev_tail_time = cio_grid_data_tstamp(2, loc_tail, var_loc) + +#ifdef verbose_cio + if ( (ratio1 .lt. 0) .or. (ratio2 .lt. 0) + & .or. (ratio1 .gt. 1) .or. (ratio2 .gt. 1)) then + write(logdev,'(5X,a)'), + & 'ERROR: Incorrect Interpolation in 3-D Generic Interpolation for variable: ', + & trim(vname) + + write(logdev,'(5X,a,i7,a,i6)'), + & 'Requested TIME & DATE: ',date,':',time + + write(logdev,'(5X,a,i7,a,i6,a,i7,a,i6)'), + & 'Interpolation Bounds ',cio_grid_data_tstamp(1,0,var_loc), + & ':',cio_grid_data_tstamp(2,0,var_loc),' to ', + & cio_grid_data_tstamp(1,1,var_loc),':',cio_grid_data_tstamp(2,1,var_loc) + + call m3exit( 'Centralized I/O',date,time,'',1 ) + write(logdev,'(5X,a)'), + & 'ERROR: Program EXIT in subroutine r_interpolate_var_3d in module centralized io' + + end if +#endif + else + lcount = lcount + 1 + end if + + cio_grid_data(store_beg_ind:store_end_ind) = cio_grid_data(head_beg_ind:head_end_ind) * ratio1 + & + cio_grid_data(tail_beg_ind:tail_end_ind) * ratio2 + end if + end if + + beg_k = 1 + if (cio_grid_var_name(var_loc, 2) .eq. 'e2d') then + end_k = 1 + else + end_k = size(data,3) + end if + + adj1 = 0 + adj2 = 0 + adj3 = 0 + if (window) then + if (((size(data,1) - ncols) .eq. 0) .and. + & (cio_grid_var_name(var_loc, 2) .eq. 'mc3')) then + adj1 = ncols + 3 + adj2 = 2 + adj3 = 2 * ncols + 4 + else if (cio_grid_var_name(var_loc, 2) .eq. 'md3') then + adj1 = 0 + + if (.not. east_pe) then + adj2 = 1 + else + adj2 = 0 + end if + + if (north_pe .and. east_pe) then + adj3 = 0 + else if (north_pe) then + adj3 = 1 + else if (east_pe) then + adj3 = x_dot_ncols + else + adj3 = x_dot_ncols + 1 + end if +#ifdef twoway + adj2 = 0 + adj3 = 0 +#endif + end if + else + extra_c = 0 + extra_r = 0 + + if (cio_grid_var_name(var_loc, 2) .eq. 'md3') then + extra_c = x_dot_ncols - size(data, 1) + extra_r = x_dot_nrows - size(data, 2) + col_size = dot_ncols + dot = 1 + else + extra_c = x_cro_ncols - size(data, 1) + extra_r = x_cro_nrows - size(data, 2) + col_size = cro_ncols + dot = 0 + end if + + if ((cio_grid_var_name(var_loc, 2) .ne. 'e2d') .and. + & (cio_grid_var_name(var_loc, 2) .ne. 'e3d') .and. + & (cio_grid_var_name(var_loc, 2) .ne. 'ic') .and. + & (cio_grid_var_name(var_loc, 2) .ne. 'is')) then + adj2 = extra_c + adj3 = extra_r * col_size + extra_c + if (north_pe .and. east_pe) then + adj3 = 0 + else if (north_pe) then + adj3 = adj3 - 1 + end if + end if + + end if + + store_beg_ind = cio_grid_data_inx(1,2,var_loc) + m = store_beg_ind - 1 + adj1 + + do k = beg_k, end_k + do r = 1, size(data,2) + do c = 1, size(data,1) + m = m + 1 + data(c,r,k) = cio_grid_data(m) + end do + m = m + adj2 + end do + if (window .and. (cio_grid_var_name(var_loc, 2) .eq. 'md3')) then + m = m - adj2 + adj3 + else + m = m + adj3 + end if + end do + end if + + end subroutine r_interpolate_var_3d +!#endif !ifdefine mpas for the few functions in the interface (Wei Li) + + END MODULE CENTRALIZED_IO_MODULE diff --git a/src/model/src/centralized_io_util_module.F b/src/model/src/centralized_io_util_module.F index f5b0653..c37a99e 100644 --- a/src/model/src/centralized_io_util_module.F +++ b/src/model/src/centralized_io_util_module.F @@ -25,12 +25,17 @@ ! 02/01/19, D. Wong: initial implementation ! 08/01/19, D. Wong: modified code to work with two-way model ! 11/20/19, F. Sidi: Modified time to sec to handle negative numbers +! 03/05/20, D. Wong: Expanded CIO functionalities to MPAS as well +! 07/07/20, D. Wong: Formulated a robust routine to compute JDATE1 - JDATE2 +! and JDATE + NDAYS !------------------------------------------------------------------------! module centralized_io_util_module implicit none + private :: leap_year + interface quicksort module procedure quicksort1d, & quicksort2d @@ -38,6 +43,23 @@ module centralized_io_util_module contains +! ----------------------------------------------------------- + logical function leap_year (year) + + integer :: year + + if (mod(year, 4) .ne. 0) then + leap_year = .false. + else if (mod(year, 400) .eq. 0) then + leap_year = .true. + else if (mod(year, 100) .eq. 0) then + leap_year = .false. + else + leap_year = .true. + endif + + end function leap_year + ! ------------------------------------------------------------------------- recursive subroutine quicksort1d (name, begin, end) @@ -202,7 +224,7 @@ integer function time_diff (time1, time2) end function time_diff !-------------------------------------------------------------------------- - integer function next_day (jday) + integer function next_day (jday) ! This function determermins the next day for time interpolation implicit none @@ -236,7 +258,91 @@ integer function next_day (jday) End If End If - end function next_day + end function next_day + +! ------------------------------------------------------------------------- + integer function cal_date (date1, date2, operator) + + integer, intent(in) :: date1, date2 + character, intent(in) :: operator + + integer :: ldate1, ldate2, yr1, yr2, day1, day2, dsum, y, + & adj, adj_yr, remainder, ndays + logical :: done + + if (operator == '-') then + if (date1 <= date2) then + ldate1 = date1 + ldate2 = date2 + adj = -1 + else + ldate1 = date2 + ldate2 = date1 + adj = 1 + end if + + yr1 = ldate1 / 1000 + yr2 = ldate2 / 1000 + day1 = mod(ldate1, 1000) + day2 = mod(ldate2, 1000) + + dsum = 0 + do y = yr1, yr2 + if (leap_year(y)) then + dsum = dsum + 366 + else + dsum = dsum + 365 + end if + end do + + dsum = dsum - day1 + if (leap_year(yr2)) then + dsum = dsum - 366 + day2 + else + dsum = dsum - 365 + day2 + end if + + cal_date = dsum * adj + + else if (operator == '+') then + + yr1 = date1 / 1000 + day1 = mod(date1, 1000) + if (date2 < 0) then + adj_yr = -1 + adj = 1 + else + adj_yr = 1 + adj = -1 + end if + + day1 = day1 + date2 + done = .false. + do while (.not. done) + if (leap_year(yr1)) then + ndays = 366 + else + ndays = 365 + end if + if ((day1 > 0) .and. (day1 <= ndays)) then + done = .true. + else + yr1 = yr1 + adj_yr + day1 = day1 + ndays * adj + end if + end do + + if ((date2 < 0) .and. (leap_year(yr1))) then + cal_date = yr1 * 1000 + day1 + 1 + else + cal_date = yr1 * 1000 + day1 + end if + + else + call m3exit ( 'cal_date', 0, 0, ' Abort: Invalid operator', 2) + end if + + end function cal_date !-------------------------------------------------------------------------- @@ -277,6 +383,6 @@ function interp_linear1_internal(x,y,xout) result(yout) return - end function interp_linear1_internal + end function interp_linear1_internal end module centralized_io_util_module diff --git a/src/model/src/o3totcol.f b/src/model/src/o3totcol.f index 9f8c7fc..a500cee 100644 --- a/src/model/src/o3totcol.f +++ b/src/model/src/o3totcol.f @@ -17,10 +17,7 @@ ! subject to their copyright restrictions. ! !------------------------------------------------------------------------! -! RCS file, release, date & time of last delta, author, state, [and locker] -! $Header: /project/yoj/arc/CCTM/src/phot/phot_inline/o3totcol.f,v 1.2 2011/10/21 16:11:28 yoj Exp $ - - subroutine o3totcol ( latitude, longitude, jdate, ozone ) + subroutine o3totcol ( latitude, longitude, jdate, jtime, ozone ) !---------------------------------------------------------------------- ! Function: @@ -37,6 +34,7 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) ! Jun 2015 J.Young: maintain code stnds !---------------------------------------------------------------------- + use runtime_vars use utilio_defn implicit none @@ -44,11 +42,15 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) ! arguments integer, intent( in ) :: jdate ! Julian day of the year (yyyyddd) + integer, intent( in ) :: jtime ! time (hhmmss) real, intent( in ) :: latitude ! latitude of point on earth's surface real, intent( in ) :: longitude ! longitude of point on earth's surface real, intent( inout ) :: ozone ! total column ozone [DU] +! parameters + + real, parameter :: sec2day = 1.0 / 8.64E+4 ! local variables character( 16 ), save :: tmfile = 'OMI' @@ -64,14 +66,17 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) integer :: ios integer :: nrecs integer :: jyear - integer, save :: nlat - integer, save :: nlon + integer :: time - integer, save :: logdev ! output log unit number + integer, save :: nlat ! = 17 ! or 19 + integer, save :: nlon ! = 17 integer, save :: nt integer, save :: it + integer, save :: icolumn_prev = 1 + integer, save :: icolumn_next = 2 integer, save :: tmunit integer, save :: jdate_prev = 0 + integer, save :: jtime_prev = 0 integer, save :: jstdate, jenddate, jtdate_temp real :: flag( 8 ) @@ -84,25 +89,24 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) real :: tdate_temp, tdate real, save :: x1 - real, save :: stdate, enddate + real, save :: strdate, enddate + real, save :: max_lat, min_lat real, allocatable, save :: t( : ) real, allocatable, save :: lat( : ) real, allocatable, save :: lon( : ) real, allocatable, save :: oz( :, :, : ) ! two timesteps for interpolation - character( 8 ) :: label - logical, save :: firsttime = .true. - real, external :: yr2day - character*24, external :: dt2str + character( 8 ) :: label !(Wei li) + real, external :: yr2day !(Wei Li: from io/ioapi/yr2day.F) + character*24, external :: dt2str !(Wei Li) !---------------------------------------------------------------------- if ( firsttime ) then firsttime = .false. - logdev = init3() tmunit = getefile( tmfile, .true., .true., pname ) @@ -111,10 +115,13 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) call m3exit ( pname, jdate, 0, xmsg, xstat1 ) end if - ! read nlat, nlon + ! read nlat, nlon (Wei Li) rewind( tmunit ) - read( tmunit, * ) label, nlat - read( tmunit, * ) label, nlon + read( tmunit, *) label, nlat + read( tmunit, *) label, nlon + + write(logdev,'(a,i7,a,i7)')'OMI Ozone column data has Lat by Lon Resolution: ', + & nlat,'X',nlon allocate ( lat( nlat ), stat = allocstat ) if ( allocstat .ne. 0 ) then @@ -127,10 +134,18 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) xmsg = 'Failure allocating lon' call m3exit ( pname, jdate, 0, xmsg, xstat1 ) end if + +! Assign values to array of longitudes: lon +! x2 = 360.0 / real( nlon - 1 ) +! do ilon = 1, nlon +! lon( ilon ) = -180.0 + x2 * real( ilon - 1 ) +! end do - read( tmunit, * ) label, label, lon ! read in longitudes + !read in longitudes instead (Wei Li) + read( tmunit, * ) label, label, lon nrecs = 0 + ! read( tmunit, * ) !skip header record. Wei Li:no need here do read( tmunit, *, iostat=ios ) if ( ios .ne. 0 ) exit @@ -152,9 +167,9 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) rewind( tmunit ) ! skip header records - do it = 1, 3 - read( tmunit, * ) - end do + read( tmunit, * ) + read( tmunit, * ) + read( tmunit, * ) ! When adding x lines of data to OMI.dat, increase upper limit by x ! Note: ilat(1) => North to South in degrees @@ -168,102 +183,112 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) end do end do - stdate = minval( t ) + max_lat = maxval( lat ) + min_lat = minval( lat ) + strdate = minval( t ) enddate = maxval( t ) end if ! firsttime - if ( jdate .ne. jdate_prev ) then -! reset oz and jdate_prev - jdate_prev = jdate - oz = 0.0 - + if ( jdate .ne. jdate_prev .or. jtime .ne. jtime_prev ) then ! Use a temporary dummy variable jdate_temp so as not to overwrite jdate + jtime_prev = jtime jyear = jdate / 1000 - tdate = real( jyear ) + real( jdate - jyear * 1000 ) * yr2day( jyear ) + time = mod(jtime, 100) + 60*mod(jtime/100, 100)+ 3600*(jtime/10000) + + tdate = real( jyear ) + & + ( real( jdate - jyear * 1000 ) + real( time ) * sec2day ) * yr2day( jyear ) + tdate_temp = tdate ! Determine if the ozone database includes the requested jdate - + if ( tdate .ge. enddate ) then ! Submitted date is outside of ozone database range. ! Total column ozone will be estimated from the corresponding Julian Day ! of the prior year - - if ( tdate .ge. enddate ) then - tdate_temp = aint( enddate ) + ( tdate - aint( tdate ) ) - if ( tdate_temp .gt. enddate ) then - tdate_temp = tdate_temp - 1.0 - end if - jenddate = int( enddate ) * 1000 - & + int( ( 1.0 / yr2day( int( enddate ) ) ) + tdate_temp = aint( enddate ) + ( tdate - aint( tdate ) ) + if ( tdate_temp .gt. enddate ) then + tdate_temp = tdate_temp - 1.0 + end if + jenddate = int( enddate ) * 1000 + & + int( ( 1.0 / yr2day( int( enddate ) ) ) & * ( enddate - aint( enddate ) ) ) - jtdate_temp = int( tdate_temp ) * 1000 - & + nint( ( 1.0 / yr2day( int( tdate_temp ) ) ) - & * ( tdate_temp - aint( tdate_temp ) ) ) - xmsg = 'Requested date is beyond available data on OMI file: <' - & // dt2str( jenddate, 0 ) - call m3warn ( pname, jdate, 0, xmsg ) - xmsgs( 1 ) = 'Total column ozone will be estimated from the corresponding Julian Day ' - xmsgs( 2 ) = 'of the last available year on the ' - & // 'OMI input file:' // dt2str( jtdate_temp, 0 ) // '<<---<<' - xmsgs( 3 ) = ' ' - call m3parag ( 3, xmsgs ) - + jtdate_temp = int( tdate_temp ) * 1000 + & + nint( ( 1.0 / yr2day( int( tdate_temp ) ) ) + & * ( tdate_temp - aint( tdate_temp ) ) ) + if( jdate_prev .ne. jdate )then ! write message to log + xmsg = 'Requested date is beyond available data on OMI file: <' + & // dt2str( jenddate, 0 ) + call m3warn ( pname, jdate, 0, xmsg ) + xmsgs( 1 ) = 'Total column ozone will be estimated from the corresponding Julian Day ' + xmsgs( 2 ) = 'of the last available year on the ' + & // 'OMI input file:' // dt2str( jtdate_temp, 0 ) // '<<---<<' + write(xmsgs( 3 ),'(A,F14.8)')'Exact date: ',tdate_temp + call m3parag ( 3, xmsgs ) + end if + else if ( tdate .le. strdate ) then ! Submitted date is outside of ozone database range. ! Total column ozone will be estimated from the corresponding Julian Day of ! the subsequent year - - else if ( tdate .le. stdate ) then - tdate_temp = real( int( stdate ) ) + ( tdate - real( int( tdate ) ) ) - if ( tdate_temp .lt. stdate ) then - tdate_temp = tdate_temp + 1.0 - end if - jstdate = int( stdate ) * 1000 - & + int( ( 1.0 / yr2day( int( stdate ) ) ) - & * ( stdate - aint( stdate ) ) ) - jtdate_temp = int( tdate_temp ) * 1000 - & + nint( ( 1.0 / yr2day( int( tdate_temp ) ) ) - & * ( tdate_temp - aint( tdate_temp ) ) ) - xmsg = 'Requested date preceeds available data on OMI file: >' - & // dt2str( jstdate, 0 ) - call m3warn ( pname, jdate, 0, xmsg ) - xmsgs( 1 ) = 'Total column ozone will be estimated from the corresponding Julian Day' - xmsgs( 2 ) = 'of the next available year on the OMI input file:' - & // dt2str( jtdate_temp, 0 ) // '<<---<<' - xmsgs( 3 ) = ' ' - call m3parag ( 3, xmsgs ) + tdate_temp = real( int( strdate ) ) + ( tdate - real( int( tdate ) ) ) + if ( tdate_temp .lt. strdate ) then + tdate_temp = tdate_temp + 1.0 + end if + jstdate = int( strdate ) * 1000 + & + int( ( 1.0 / yr2day( int( strdate ) ) ) + & * ( strdate - aint( strdate ) ) ) + jtdate_temp = int( tdate_temp ) * 1000 + & + nint( ( 1.0 / yr2day( int( tdate_temp ) ) ) + & * ( tdate_temp - aint( tdate_temp ) ) ) + if( jdate_prev .ne. jdate )then ! write message to log + xmsg = 'Requested date preceeds available data on OMI file: >' + & // dt2str( jstdate, 0 ) + call m3warn ( pname, jdate, 0, xmsg ) + xmsgs( 1 ) = 'Total column ozone will be estimated from the corresponding Julian Day' + xmsgs( 2 ) = 'of the next available year on the OMI input file:' + & // dt2str( jtdate_temp, 0 ) // '<<---<<' + xmsgs( 3 ) = ' ' + call m3parag ( 3, xmsgs ) + end if ! Submitted date falls within the satellite data measurement gap beginning ! on 24 Nov 1994 and ending on 22 Jul 1996. - else if ( ( tdate .ge. 1994.899 ) .and. - & ( tdate .le. 1996.557 ) ) then + else if ( ( tdate .ge. 1994.899 ) .and. + & ( tdate .le. 1996.557 ) ) then - if ( tdate .le. 1995.738 ) then - tdate_temp = tdate - 1.0 ! use previous year - else - tdate_temp = tdate + 1.0 ! use subsequent year - end if - jtdate_temp = int( tdate_temp ) * 1000 + if ( tdate .le. 1995.738 ) then + tdate_temp = tdate - 1.0 ! use previous year + else + tdate_temp = tdate + 1.0 ! use subsequent year + end if + jtdate_temp = int( tdate_temp ) * 1000 & + nint( ( 1.0 / yr2day( int( tdate_temp ) ) ) & * ( tdate_temp - aint( tdate_temp ) ) ) - xmsg = 'Requested date falls within satellite data' - & // ' measurement gap: 24 Nov 1994 - 22 Jul 1996' - call m3warn ( pname, jdate, 0, xmsg ) - xmsgs( 1 ) = 'Total column ozone will be estimated from the corresponding Julian Day' - xmsgs( 2 ) = 'of the closest available year on the OMI input file:' - & // dt2str( jtdate_temp, 0 ) // '<<---<<' - xmsgs( 3 ) = ' ' - call m3parag ( 3, xmsgs ) - - else - xmsgs( 1 ) = 'Total column ozone will be interpolated to day ' - & // dt2str( jdate, 0 ) - xmsgs( 2 ) = 'from data available on the OMI input file' - xmsgs( 3 ) = ' ' - call m3parag ( 3, xmsgs ) - end if + if( jdate_prev .ne. jdate )then ! write message to log + xmsg = 'Requested date falls within satellite data' + & // ' measurement gap: 24 Nov 1994 - 22 Jul 1996' + call m3warn ( pname, jdate, 0, xmsg ) + xmsgs( 1 ) = 'Total column ozone will be estimated from the corresponding Julian Day' + xmsgs( 2 ) = 'of the closest available year on the OMI input file:' + & // dt2str( jtdate_temp, 0 ) // '<<---<<' + xmsgs( 3 ) = ' ' + call m3parag ( 3, xmsgs ) + end if + else + if( jdate_prev .ne. jdate )then ! write message to log + xmsgs( 1 ) = 'Total column ozone will be interpolated to day ' + & // dt2str( jdate, 0 ) + xmsgs( 2 ) = 'from data available on the OMI input file' + xmsgs( 3 ) = ' ' + call m3parag ( 3, xmsgs ) + end if + end if + + if( jdate_prev .ne. jdate )then ! need to update day interpolation points + jdate_prev = jdate + oz = 0.0 ! When adding x lines of data to OMI.dat, increase upper limit by x ! and increase the dimension of t as needed @@ -272,41 +297,44 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) ! i.e. (it) < (jdate_temp) < (it+1) ! where it is the index var for the database ! and determine the interpolation factor ?x1? between the bounding dates +! reset oz and jdate_prev - x1 = 0.0 - x1loop: do it = 1, nt-1 - if ( ( tdate_temp .ge. t( it ) ) .and. - & ( tdate_temp .le. t( it+1 ) ) ) then - x1 = ( tdate_temp - t( it ) ) / ( t( it+1) - t( it ) ) - exit x1loop - end if - end do x1loop - + x1 = 0.0 + x1loop: do it = 1, nt-1 + if ( ( tdate_temp .ge. t( it ) ) .and. + & ( tdate_temp .le. t( it+1 ) ) ) then + icolumn_prev = it + icolumn_next = it + 1 + exit x1loop + end if + end do x1loop ! Determine the corresponding bounding ozone values for all lats and lons - - rewind( tmunit ) - ! skip header records - do i = 1, 3 - read( tmunit, * ) - end do + rewind( tmunit ) + ! skip header records + read( tmunit,* ) + read( tmunit,* ) + read( tmunit,* ) - do i = 1, it-1 - do ilat = 1, nlat - read( tmunit,* ) - end do - end do + do i = 1, it-1 + do ilat = 1, nlat + read( tmunit,* ) + end do + end do - do ilat = 1, nlat - read( tmunit,* ) t( it ), lat( ilat ), ( oz( ilat, ilon, 1 ), ilon=1,(nlon-1) ) - oz( ilat, nlon, 1 ) = oz( ilat, 1, 1 ) - end do + do ilat = 1, nlat + read( tmunit,* ) t( it ), lat( ilat ), ( oz( ilat, ilon, 1 ), ilon=1,(nlon-1) ) + oz( ilat, nlon, 1 ) = oz( ilat, 1, 1 ) + end do - do ilat = 1, nlat - read( tmunit,* ) t( it+1 ), lat( ilat ), ( oz( ilat, ilon, 2 ), ilon=1,(nlon-1) ) - oz( ilat, nlon, 2 ) = oz( ilat, 1, 2 ) - end do + do ilat = 1, nlat + read( tmunit,* ) t( it+1 ), lat( ilat ), ( oz( ilat, ilon, 2 ), ilon=1,(nlon-1) ) + oz( ilat, nlon, 2 ) = oz( ilat, 1, 2 ) + end do + end if + + x1 = ( tdate_temp - t( icolumn_prev ) ) / ( t( icolumn_next ) - t( icolumn_prev ) ) - end if ! jdate .ne. jdate_prev + end if ! jdate .ne. jdate_prev and jtime .ne. jday flag = 0.0 ozone = 0.0 @@ -314,13 +342,13 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) x2 = 0.0 x3 = 0.0 -! Handle the special case of abs(lat) > 80. +! Handle the special case of lat > max_lat or lat < min_lat. ! use a dummy latitude variable latitudem so as to prevent overwriting latitude - if ( latitude .gt. 80.0 ) then - latitudem = 80.0 - else if ( latitude .lt. -80.0 ) then - latitudem = -80.0 + if ( latitude .gt. max_lat ) then + latitudem = max_lat + else if ( latitude .lt. min_lat ) then + latitudem = min_lat else latitudem = latitude end if @@ -420,9 +448,9 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) total = sum( flag ) -! Special case of abs(lat) > 80 +! Special case of min_lat > lat or lat > max_lat - if ( latitude .ge. 80.0 ) then + if ( latitude .ge. max_lat ) then np_oz = 0.0 icount = 0 @@ -444,7 +472,7 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) np_oz = np_oz / real( icount ) - else if ( latitude .le. -80.0 ) then + else if ( latitude .le. min_lat ) then sp_oz = 0.0 icount = 0 @@ -473,15 +501,15 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) if ( total .le. 0.0 ) then ozone = 300.0 else - if ( latitude .ge. 80.0 ) then + if ( latitude .ge. max_lat ) then np_oz = np_oz / total - ozone = ( ( latitude - 80.0 ) * 0.1 ) * np_oz - & + ( 1.0 - ( ( ( latitude - 80.0 ) * 0.1 ) ) ) * ozone / total + ozone = ( ( latitude - max_lat ) * 0.1 ) * np_oz + & + ( 1.0 - ( ( ( latitude - max_lat ) * 0.1 ) ) ) * ozone / total - else if ( latitude .le. -80.0 ) then + else if ( latitude .le. min_lat ) then sp_oz = sp_oz / total - ozone = ( ( latitude + 80.0 ) * 0.1 ) * sp_oz - & + ( 1.0 - ( ( ( latitude + 80.0 ) * 0.1 ) ) ) * ozone / total + ozone = ( ( latitude - min_lat ) * 0.1 ) * sp_oz + & + ( 1.0 - ( ( ( latitude - min_lat ) * 0.1 ) ) ) * ozone / total else ozone = ozone / total @@ -490,8 +518,36 @@ subroutine o3totcol ( latitude, longitude, jdate, ozone ) 899 if ( ozone .lt. 100.0 ) then ozone = 100.0 - else if ( ozone .gt. 600.0 ) then - ozone = 600.0 +! xmsg = 'interpolated ozone column below 100 DU' +! write(logdev,'(A,20(F10.4,1X))')'For time:',tdate_temp +! write(logdev,'(A,20(F10.4,1X))')'At lat,lon:',latitude,longitude +! write(logdev,'(A,20(F10.4,1X))')'Intepolated data' +! write(logdev,'(A,20(F10.4,1X))')'Time Point 1', +! & t( icolumn_prev ),lat( ilat ),lat( ilat+1 ),lon( ilon),lon( ilon+1 ), +! & oz( ilat, ilon+1, 1 ), oz( ilat , ilon , 1 ), +! & oz( ilat+1, ilon+1, 1 ), oz( ilat+1, ilon , 1 ) +! write(logdev,'(A,20(F10.4,1X))')'Time Point 2', +! & t( icolumn_next ),lat( ilat ),lat( ilat+1 ),lon( ilon),lon( ilon+1 ), +! & oz( ilat, ilon+1, 2 ), oz( ilat , ilon , 2 ), +! & oz( ilat+1, ilon+1, 2 ), oz( ilat+1, ilon , 2 ) +! write(logdev,'(A,20(F10.4,1X))')'Weights, x1, x2,x3: ',x1, x2,x3 +! CALL M3EXIT( 'o3totcol', JDATE, JTIME, XMSG, XSTAT1 ) + else if ( ozone .gt. 800.0 ) then +! xmsg = 'interpolated ozone column above 800 DU' +! write(logdev,'(A,20(F10.4,1X))')'For time:',tdate_temp +! write(logdev,'(A,20(F10.4,1X))')'At lat,lon:',latitude,longitude +! write(logdev,'(A,20(F10.4,1X))')'Intepolated data' +! write(logdev,'(A,20(F10.4,1X))')'Time Point 1', +! & t( icolumn_prev ),lat( ilat ),lat( ilat+1 ),lon( ilon),lon( ilon+1 ), +! & oz( ilat, ilon+1, 1 ), oz( ilat , ilon , 1 ), +! & oz( ilat+1, ilon+1, 1 ), oz( ilat+1, ilon , 1 ) +! write(logdev,'(A,20(F10.4,1X))')'Time Point 2', +! & t( icolumn_next ),lat( ilat ),lat( ilat+1 ),lon( ilon),lon( ilon+1 ), +! & oz( ilat, ilon+1, 2 ), oz( ilat , ilon , 2 ), +! & oz( ilat+1, ilon+1, 2 ), oz( ilat+1, ilon , 2 ) +! write(logdev,'(A,20(F10.4,1X))')'Weights, x1, x2,x3: ',x1, x2,x3 +! CALL M3EXIT( 'o3totcol', JDATE, JTIME, XMSG, XSTAT1 ) + ozone = 800.0 end if return diff --git a/src/model/src/phot.F b/src/model/src/phot.F index 99862a3..1504088 100644 --- a/src/model/src/phot.F +++ b/src/model/src/phot.F @@ -17,15 +17,8 @@ ! subject to their copyright restrictions. ! !------------------------------------------------------------------------! - -! RCS file, release, date & time of last delta, author, state, [and locker] -! $Header: /project/yoj/arc/CCTM/src/phot/phot_inline/phot.F,v 1.7 2011/10/21 16:11:28 yoj Exp $ - -! what(1) key, module and SID; SCCS file; date and time of last delta: -! %W% %P% %G% %U% - !::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) + SUBROUTINE PHOT ( CGRID, JDATE, JTIME, DTSTEP ) !----------------------------------------------------------------------- ! @@ -37,11 +30,11 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) ! Preconditions: HGRD_INIT() called from PAR_INIT, which is called from ! DRIVER ! -! Subroutines/Functions called: INIT3, M3EXIT, SUBHFILE, CGRID_MAP, +! Subroutines/Functions called: M3EXIT, SUBHFILE, CGRID_MAP, ! OPPHOT, LOAD_CSQY_DATA, LOAD_OPTICS_DATA, INITIALIZE_ALBEDO, ! GET_PHOT_MET, UPDATE_SUN, GET_ALBEDO, GET_DROPLET_OPTICS, ! GET_ICE_OPTICS, GET_AGGREGATE_OPTICS, CLEAR_HYDROMETEOR_OPTICS, -! GET_AERO_DATA, O3TOTCOL, and NEW_OPTICS +! GET_AERO_DATA, O3TOTCOL, and NEW_OPTICS, GET_ENVLIST ! ! Revision History. ! Started 10/08/2004 with existing PHOT and JPROC coded by @@ -89,7 +82,7 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) ! reads this input file ! - added call to a routine called AERO_PHOTDATA that returns opacity data ! on the aerosol distribution -! - revised NEW_OPTICS' arguments based on aerosol redesign in CMAQ +! - revised NEW_OPTICS' arguments based on aerosol redesign in CMAQ ! version 5.0 ! March 29, 2011 S.Roselle ! - Replaced I/O API include files with UTILIO_DEFN @@ -101,9 +94,9 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) ! 3) reading and calculation of met and geo data ! now acomplished by a fortran module ! 4) changed description and accounting of cloud effects -! from 2D liquid water clouds to 3D resolved and subgrid +! from 2D liquid water clouds to 3D resolved and subgrid ! clouds with multi-phases of water -! 5) inserted calculation of aerosol optical properites via +! 5) inserted calculation of aerosol optical properties via ! fortran module to improve efficiency in radiative ! transfer solution ! 6) moved the O3TOTCOL routine from the PHOT_MOD to simplify @@ -112,14 +105,17 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) ! June 10 15 J.Young: Modified diagnostic output timestamp to fix for other than one ! hour time steps. ! Aug 12, 15 D. Wong: Replaced MYPE with IO_PE_INCLUSIVE for parallel I/O implementation +! Feb 01, 19 David Wong: Implemented centralized I/O approach, removed all MY_N +! clauses !---------------------------------------------------------------------- C...modules + USE RUNTIME_VARS, ONLY : START_DATE => STDATE, START_TIME => STTIME USE RXNS_DATA ! chemistry varaibles and data + USE GRID_CONF ! horizontal & vertical domain specifications USE CGRID_SPCS ! CGRID species number and offsets - USE PCGRID_DEFN ! get cgrid USE UTILIO_DEFN USE AERO_DATA ! describes aerosol distribution USE PHOT_MOD ! photolysis in-line module - inherits CSQY_DATA module @@ -127,12 +123,12 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) USE PHOTOLYSIS_ALBEDO ! surface albedo data and routines USE PHOT_MET_DATA ! Met and Grid data USE CLOUD_OPTICS ! data and routines for optics of cloud hydrometeors -! USE STRATOS_O3_MINFRACS ! annual minimum fraction of ozone column density above Pressure TOP -! USE SEAS_STRAT_O3_FRACS ! monthly minimum fraction of ozone column density above Pressure TOP USE SEAS_STRAT_O3_MIN ! monthly minimum fraction of ozone column density above Pressure TOP -!Used for canopy shade calculation + !Used for canopy shade calculation (Wei Li) USE ASX_DATA_MOD, ONLY : MET_DATA !uses met data - USE centralized_io_util_module, ONLY: IntegrateTrapezoid, interp_linear1_internal !basic utilities + USE CENTRALIZED_IO_MODULE, ONLY : LAT, LON, HT + USE centralized_io_util_module, ONLY: IntegrateTrapezoid,interp_linear1_internal + USE ELMO_DATA, ONLY : ELMO_AOD_550, ELMO_EXT_550 #ifdef parallel USE SE_MODULES ! stenex (using SE_UTIL_MODULE) @@ -145,21 +141,14 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) !...include files INCLUDE SUBST_FILES_ID ! file name parameters -! INCLUDE SUBST_CONST ! physical constants--moved to PHOT_MOD. !...arguments - INTEGER, INTENT( IN ) :: MDATE ! "centered" Julian date (YYYYDDD) - INTEGER, INTENT( IN ) :: MTIME ! "centered" time (HHMMSS) + REAL, POINTER :: CGRID( :,:,:,: ) ! Species concentrations INTEGER, INTENT( IN ) :: JDATE ! current Julian date (YYYYDDD) INTEGER, INTENT( IN ) :: JTIME ! current time (HHMMSS) INTEGER, INTENT( IN ) :: DTSTEP( : ) ! time step vector (HHMMSS) -! REAL RJ( NCOLS,NROWS,NLAYS, NPHOTAB ) - REAL, INTENT( OUT ) :: RJ( :,:,:,: ) ! gridded J-values (1/min units) - -! REAL CGRID( NCOLS,NROWS,NLAYS, * ) ! Conc array - REAL, SAVE, POINTER :: CGRID( :,:,:,: ) ! species concentrations !...parameters @@ -170,7 +159,7 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) REAL, PARAMETER :: PRES_CONV = 1.0 / STDATMPA ! conversion factor Pa to atm REAL, PARAMETER :: ZTOA = 50.0E3 ! height of top of atmosphere [ m ] (=50km) ! based a 2005 WRF model Documentation - + REAL, PARAMETER :: EPSLON = 1.0E-30 ! Small number !...external functions: none @@ -178,24 +167,27 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) !...local variables LOGICAL, SAVE :: FIRSTIME = .TRUE. ! Flag for first call to PHOT - LOGICAL, SAVE :: PHOTDIAG ! Flag for PHOTDIAG file LOGICAL, SAVE :: CALL_INIT_ALBEDO = .TRUE. LOGICAL, SAVE :: CALL_GET_ALBEDO = .TRUE. - + LOGICAL :: ZERO_ICE CHARACTER( 3 ), ALLOCATABLE, SAVE :: WLTXT( : ) CHARACTER( 16 ) :: VARNM CHARACTER( 16 ), SAVE :: PNAME = 'PHOT' - CHARACTER( 16 ), SAVE :: CTM_PHOTDIAG = 'CTM_PHOTDIAG' + CHARACTER( 16 ) :: V_LIST( 2 ) + CHARACTER( 16 ) :: REQUESTED_WAVE + CHARACTER( 16 ), ALLOCATABLE :: WAVE_LIST( : ) CHARACTER( 80 ) :: VARDESC ! environment variable description CHARACTER( 240 ) :: XMSG = ' ' - INTEGER, SAVE :: LOGDEV - INTEGER, SAVE :: LGC_O3 ! pointer to O3 in CGRID - INTEGER, SAVE :: LGC_NO2 ! pointer to NO2 in CGRID + INTEGER, SAVE :: LGC_O3 = 0 ! pointer to O3 in CGRID + INTEGER, SAVE :: LGC_NO2 = 0 ! pointer to NO2 in CGRID + INTEGER, SAVE :: LGC_CO = 0 ! pointer to CO in CGRID + INTEGER, SAVE :: LGC_SO2 = 0 ! pointer to SO2 in CGRID + INTEGER, SAVE :: LGC_HCHO = 0 ! pointer to formaldehyde in CGRID INTEGER, SAVE :: TSTEP ! output timestep in sec INTEGER ESTAT ! status from environment var check @@ -207,23 +199,23 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) INTEGER IWL INTEGER L INTEGER V, N, MODE - LOGICAL JTIME_CHK ! To check for JTIME to write RJ values - INTEGER ODATE ! output date - INTEGER OTIME ! output time + + LOGICAL :: JTIME_CHK ! To check for JTIME to write RJ values + INTEGER, SAVE :: ODATE ! output date + INTEGER, SAVE :: OTIME ! output time + INTEGER, SAVE :: OSTEP ! time since last write diagnostics INTEGER ALLOCSTAT + INTEGER ITMSTEP ! one half synchronization timestep (sec) + INTEGER MIDDATE ! Date at time step midpoint + INTEGER MIDTIME ! Time at time step midpoint + INTEGER, SAVE :: TDATE - INTEGER, SAVE :: GXOFF, GYOFF ! global origin offset from file INTEGER, SAVE :: PECOL_OFFSET ! Local Column Offset for processor INTEGER, SAVE :: PEROW_OFFSET ! Local Column Offset for processor INTEGER, SAVE :: TSTEP_COUNT ! counter between calls to write diagnostics -! for INTERPX - INTEGER, SAVE :: STRTCOLGC2, ENDCOLGC2, STRTROWGC2, ENDROWGC2 - INTEGER, SAVE :: STRTCOLMC2, ENDCOLMC2, STRTROWMC2, ENDROWMC2 - INTEGER, SAVE :: STRTCOLMC3, ENDCOLMC3, STRTROWMC3, ENDROWMC3 - REAL CURRHR ! current GMT hour REAL JULIAN_DAY ! time of year [days] REAL CURRHR_LST ! local standard time at each grid cell @@ -251,19 +243,19 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) REAL RES_SKY_TRANSD ! direct transmission coefficient based on resolved sky REAL :: TOTAL_O3_COLUMN ! total ozone column density, DU - + REAL, SAVE :: JYEAR = 0.0 ! year REAL, SAVE :: JD_STRAT_O3MIN = 0.0 ! Julian day (YYYYDDD) of min fraction for stratos ozone INTEGER, PARAMETER :: DAYS( 12 ) = (/ 0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30 /) INTEGER, SAVE :: IMONTH = 0 - REAL, ALLOCATABLE, SAVE :: ETOT_SFC ( : ) ! total downward irradiance at sfc [ Watts / m**2 ] - REAL, ALLOCATABLE, SAVE :: TAUO3_TOP( : ) ! optical depth of ozone above model domain - REAL, ALLOCATABLE, SAVE :: TAU_RAY ( : ) ! Rayleigh optical depth above model domain - REAL, ALLOCATABLE, SAVE :: TAUC_AERO( :,: ) ! aerosol optical depth at layer bottom - REAL, ALLOCATABLE, SAVE :: TAU_TOT ( :,: ) ! total optical depth at layer bottom - REAL, ALLOCATABLE, SAVE :: TAU_CLOUD( :,: ) ! cloud optical depth at layer bottom + REAL, ALLOCATABLE, SAVE :: ETOT_SFC ( : ) ! total downward irradiance at sfc [ Watts / m**2 ] + REAL, ALLOCATABLE, SAVE :: TAUO3_TOP( : ) ! optical depth of ozone above model domain + REAL, ALLOCATABLE, SAVE :: TAU_RAY ( : ) ! Rayleigh optical depth above model domain + REAL, ALLOCATABLE, SAVE :: TAUC_AERO( :,: ) ! aerosol optical depth at layer bottom + REAL, ALLOCATABLE, SAVE :: TAU_TOT ( :,: ) ! total optical depth at layer bottom + REAL, ALLOCATABLE, SAVE :: TAU_CLOUD( :,: ) ! cloud optical depth at layer bottom REAL, ALLOCATABLE, SAVE :: SSA ( : ) ! aerosol single scattering albedo, column average @@ -288,27 +280,26 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) REAL, ALLOCATABLE, SAVE :: BLKRJ_RES( :, : ) ! photolysis rates REAL, ALLOCATABLE, SAVE :: BLKRJ_ACM( :, : ) ! photolysis rates - + LOGICAL, ALLOCATABLE, SAVE :: CLOUDS( : ) ! Does layer have clouds? LOGICAL :: NEW_PROFILE ! Has atmospheric temperature and density profile changed? LOGICAL :: DARK ! Are this processor's cells in darkness? -! Canopy in-line control - CHARACTER( 20 ), SAVE :: CTM_CANOPY_SHADE = 'CTM_CANOPY_SHADE ' ! env var for in-line +! Canopy in-line control (Wei Li) + CHARACTER( 20 ), SAVE :: CTM_CANOPY_SHADE = 'CTM_CANOPY_SHADE '! env var for in-line LOGICAL, SAVE :: CANOPY_SHADE ! flag in-lining canopy shading - ! Canopy arrays - REAL, ALLOCATABLE, SAVE :: RJ_CORR_C1R ( :, :) ! canopy shading correction to J-values (hc to 0.75*hc) - REAL, ALLOCATABLE, SAVE :: RJ_CORR_C2R ( :, :) ! canopy shading correction to J-values (hc to 0.50*hc) - REAL, ALLOCATABLE, SAVE :: RJ_CORR_C3R ( :, :) ! canopy shading correction to J-values (hc to 0.35*hc) - REAL, ALLOCATABLE, SAVE :: RJ_CORR_C4R ( :, :) ! canopy shading correction to J-values (hc to 0.20*hc) - REAL, ALLOCATABLE, SAVE :: RJ_CORR_BOT ( :, :) ! canopy shading correction to J-values (0.20*hc to bottom) + REAL, ALLOCATABLE, SAVE :: RJ_CORR_C1R ( :, :) ! canopyshading correction to J-values (hc to 0.75*hc) + REAL, ALLOCATABLE, SAVE :: RJ_CORR_C2R ( :, :) ! canopyshading correction to J-values (hc to 0.50*hc) + REAL, ALLOCATABLE, SAVE :: RJ_CORR_C3R ( :, :) ! canopyshading correction to J-values (hc to 0.35*hc) + REAL, ALLOCATABLE, SAVE :: RJ_CORR_C4R ( :, :) ! canopyshading correction to J-values (hc to 0.20*hc) + REAL, ALLOCATABLE, SAVE :: RJ_CORR_BOT ( :, :) ! canopyshading correction to J-values (0.20*hc to bottom) REAL, ALLOCATABLE, SAVE :: RJ_CORR ( :, :) ! total/integrated canopy shading correction to J-values - REAL, ALLOCATABLE, SAVE :: ZCANX ( : ) ! canopy heights[m] - REAL, ALLOCATABLE, SAVE :: RJ_CORRX ( : ) ! canopy height dependent photolysis attenuation factor - REAL :: XCAN ( 2 ) ! canopy height interpolation bounds + REAL, ALLOCATABLE, SAVE :: ZCANX ( : ) ! canopy heights[m] + REAL, ALLOCATABLE, SAVE :: RJ_CORRX ( : ) ! canopy height dependent photolysis attenuation factor + REAL :: XCAN ( 2 ) ! canopy height interpolation bounds REAL :: YCAN ( 2 ) ! photolysisattenuation interpolation bounds - REAL ZFL, ZCAN, COUNTCAN, XCANOUT ! local canopyvariables + REAL ZFL, ZCAN, COUNTCAN, XCANOUT ! local canopy variables INTEGER, PARAMETER :: MAXCAN = 1000 ! Declare local maximum canopy layers !...Variables for diagnostic outputs @@ -317,45 +308,56 @@ SUBROUTINE PHOT ( MDATE, MTIME, JDATE, JTIME, DTSTEP, RJ ) REAL, ALLOCATABLE, SAVE :: TOTAL_OC( :,: ) ! total ozone column [DU] REAL, ALLOCATABLE, SAVE :: TROPO_OC( :,: ) ! tropospheric ozone column [DU] + REAL, ALLOCATABLE, SAVE :: NO2_COLUMN ( :,: ) ! tropospheric NO2 column [] + REAL, ALLOCATABLE, SAVE :: CO_COLUMN ( :,: ) ! tropospheric CO column [] + REAL, ALLOCATABLE, SAVE :: HCHO_COLUMN( :,: ) ! tropospheric HCHO column [DU] + REAL, ALLOCATABLE, SAVE :: SO2_COLUMN ( :,: ) ! tropospheric SO2 column [DU] REAL, ALLOCATABLE, SAVE :: TROPO_O3_EXCEED( :,: ) ! Factor used to adjust tropospheric ozone optical depth REAL, ALLOCATABLE, SAVE :: TRANSMIS_DIFFUSE( :,: ) ! diffuse transmission coefficient at surface REAL, ALLOCATABLE, SAVE :: TRANSMIS_DIRECT( :,: ) ! direct transmission coefficient at surface REAL, ALLOCATABLE, SAVE :: REFLECT_COEFF( :,: ) ! reflection coefficient at top of atmosphere - REAL, ALLOCATABLE, SAVE :: ETOT_SFC_WL ( :,:,: ) ! total downward irradiance at sfc [ Watts / m**2 ] REAL, ALLOCATABLE, SAVE :: TAU_AERO_WL ( :,:,: ) ! total aerosol optical depth REAL, ALLOCATABLE, SAVE :: TAU_CLOUD_WL( :,:,: ) ! total cloud optical depth REAL, ALLOCATABLE, SAVE :: CLR_TRANSMISSION( :,: ) ! diffuse transmission coefficient of clouds REAL, ALLOCATABLE, SAVE :: CLR_REFLECTION ( :,: ) ! reflection coefficient of cloud REAL, ALLOCATABLE, SAVE :: CLR_TRANS_DIRECT( :,: ) ! direct transmission coefficient of clouds -#ifdef phot_debug +#ifdef phot_debug REAL, ALLOCATABLE, SAVE :: ASY_CLOUD_WL( :,:,: ) ! columm average of cloud asymmetry factor REAL, ALLOCATABLE, SAVE :: SSA_CLOUD_WL( :,:,: ) ! columm average of cloud single scattering albedo -#endif +#endif REAL, ALLOCATABLE, SAVE :: TAU_TOT_WL ( :,:,: ) ! total optical depth REAL, ALLOCATABLE, SAVE :: TAUO3_TOP_WL( :,:,: ) ! optical depth of ozone above model domain REAL, ALLOCATABLE, SAVE :: AERO_SSA ( :,:,:,: ) ! aerosol single scattering albedo REAL, ALLOCATABLE, SAVE :: AERO_ASYM ( :,:,:,: ) ! aerosol asymmetry factor - REAL, ALLOCATABLE, SAVE :: TAU ( :,:,:,: ) ! optical depth - REAL, ALLOCATABLE, SAVE :: TAU_AERO ( :,:,:,: ) ! aerosol optical depth + REAL, ALLOCATABLE, SAVE :: TOT_EXT ( :,:,:,: ) ! total extinction for layer [1/Km] + REAL, ALLOCATABLE, SAVE :: GAS_EXT ( :,:,:,: ) ! clear sky extinction for layer [1/Km] + REAL, ALLOCATABLE, SAVE :: AERO_EXT ( :,:,:,: ) ! aerosol extinction for layer [1/Km] REAL, ALLOCATABLE, SAVE :: ACTINIC_FX( :,:,:,: ) ! net actinic flux [watts/m**2] + REAL, ALLOCATABLE, SAVE :: OUTPUT_BUFF ( :,:,: ) ! output buffer for DIAG2 and DIAG3 files - INTEGER IOSX ! i/o and allocate memory status + INTEGER IOSX ! i/o and allocate memory status (Wei Li) INTERFACE - SUBROUTINE O3TOTCOL ( LATITUDE, LONGITUDE, JDATE, OZONE ) + SUBROUTINE O3TOTCOL ( LATITUDE, LONGITUDE, JDATE, JTIME, OZONE ) INTEGER, INTENT( IN ) :: JDATE ! Julian day of the year (yyyyddd) + INTEGER, INTENT( IN ) :: JTIME ! time (hhmmss) REAL, INTENT( IN ) :: LATITUDE ! latitude of point on earth's surface REAL, INTENT( IN ) :: LONGITUDE ! longitude of point on earth's surface REAL, INTENT( INOUT ) :: OZONE ! total column ozone [DU] END SUBROUTINE O3TOTCOL + SUBROUTINE CONVCLD_PROP_ACM( JDATE, JTIME, TSTEP ) + INTEGER, INTENT( IN ) :: JDATE + INTEGER, INTENT( IN ) :: JTIME + INTEGER, INTENT( IN ) :: TSTEP( 3 ) + END SUBROUTINE CONVCLD_PROP_ACM END INTERFACE ! ---------------------------------------------------------------------- IF ( FIRSTIME ) THEN -C In-line canopy shading option? (default = false) +C In-line canopy shading option? (default = false) (Wei Li) CANOPY_SHADE = ENVYN( 'CTM_CANOPY_SHADE', & 'Flag for in-line canopy shading', @@ -363,105 +365,82 @@ END SUBROUTINE O3TOTCOL IF ( CANOPY_SHADE ) THEN XMSG = 'Using in-line canopy shading option' - CALL M3MSG2( XMSG ) + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF + FIRSTIME = .FALSE. - LOGDEV = INIT3() TSTEP = TIME2SEC( DTSTEP( 1 ) ) ! output timestep for phot diagnostic files - CGRID => PCGRID( 1:MY_NCOLS,1:MY_NROWS,:,: ) - -!...Get photolysis rate diagnostic file flag - - PHOTDIAG = .FALSE. ! default - VARDESC= 'Flag for writing the photolysis rate diagnostic file' - PHOTDIAG = ENVYN( CTM_PHOTDIAG, VARDESC, PHOTDIAG, ESTAT ) - IF ( ESTAT .NE. 0 ) WRITE( LOGDEV, '(5X, A)' ) VARDESC - IF ( ESTAT .EQ. 1 ) THEN - XMSG = 'Environment variable improperly formatted' - CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT2 ) - ELSE IF ( ESTAT .EQ. -1 ) THEN - XMSG = - & 'Environment variable set, but empty ... Using default:' - WRITE( LOGDEV, '(5X, A, I9)' ) XMSG, JTIME - ELSE IF ( ESTAT .EQ. -2 ) THEN - XMSG = 'Environment variable not set ... Using default:' - WRITE( LOGDEV, '(5X, A, I9)' ) XMSG, JTIME - END IF - -!...Get met file offsets +!...Set flag to initialize calculating aerosol extinction at 550 nm via Angstrom Exponents + CALCULATE_EXT_550 = .TRUE. !PHOTDIAG - CALL SUBHFILE ( GRID_CRO_2D, GXOFF, GYOFF, - & STRTCOLGC2, ENDCOLGC2, STRTROWGC2, ENDROWGC2 ) - CALL SUBHFILE ( MET_CRO_2D, GXOFF, GYOFF, - & STRTCOLMC2, ENDCOLMC2, STRTROWMC2, ENDROWMC2 ) - CALL SUBHFILE ( MET_CRO_3D, GXOFF, GYOFF, - & STRTCOLMC3, ENDCOLMC3, STRTROWMC3, ENDROWMC3 ) - PECOL_OFFSET = COLSD_PE( 1, MYPE+1 ) - 1 PEROW_OFFSET = ROWSD_PE( 1, MYPE+1 ) - 1 - CALL LOAD_CSQY_DATA( ) + CALL INIT_PHOT_SHARED() - CALL LOAD_OPTICS_DATA( ) - !...Allocate array needed to calculation aerosol and cloud optical properties CALL INIT_AERO_DATA( ) - + CALL INIT_CLOUD_OPTICS( ) -!...Allocate and initialize new canopy arrays - IF ( CANOPY_SHADE ) THEN - ALLOCATE( RJ_CORRX ( MAXCAN ) ) - ALLOCATE( ZCANX ( MAXCAN ) ) +!...Allocate and initialize new canopy arrays (Wei Li) + IF ( CANOPY_SHADE ) THEN + ALLOCATE( RJ_CORRX ( MAXCAN ) ) + ALLOCATE( ZCANX ( MAXCAN ) ) - ALLOCATE( RJ_CORR_C1R ( NCOLS, NROWS ), + ALLOCATE( RJ_CORR_C1R ( NCOLS, NROWS ), & RJ_CORR_C2R ( NCOLS, NROWS ), & RJ_CORR_C3R ( NCOLS, NROWS ), & RJ_CORR_C4R ( NCOLS, NROWS ), & RJ_CORR_BOT ( NCOLS, NROWS ), & RJ_CORR ( NCOLS, NROWS ), STAT = ALLOCSTAT ) - IF ( ALLOCSTAT .NE. 0 ) THEN - XMSG = 'Failure allocating canopy photolysis rate correction arrays' - CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - END IF - - RJ_CORRX=0.0 - ZCANX=0.0 - RJ_CORR_C1R=0.0 - RJ_CORR_C2R=0.0 - RJ_CORR_C3R=0.0 - RJ_CORR_C4R=0.0 - RJ_CORR_BOT=0.0 - RJ_CORR=0.0 - END IF + IF ( ALLOCSTAT .NE. 0 ) THEN + XMSG = 'Failure allocating canopy photolysis rate correction arrays' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + RJ_CORRX=0.0 + ZCANX=0.0 + RJ_CORR_C1R=0.0 + RJ_CORR_C2R=0.0 + RJ_CORR_C3R=0.0 + RJ_CORR_C4R=0.0 + RJ_CORR_BOT=0.0 + RJ_CORR=0.0 + END IF + + +! set cosine values for sun effectively below horizon + COS85 = COS( 85.0 * PI180 ) !...Initialize Surface albedo method - IF ( .NOT. INITIALIZE_ALBEDO( JDATE, JTIME, LOGDEV ) ) THEN + IF ( .NOT. INITIALIZE_ALBEDO( JDATE, JTIME ) ) THEN XMSG = 'Failure initializing photolysis surface albedo algorithm' CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF ALLOCATE( ETOT_SFC ( NWL ) ) - ALLOCATE( LWC ( NLAYS ) ) - ALLOCATE( RWC ( NLAYS ) ) - ALLOCATE( IWC ( NLAYS ) ) - ALLOCATE( SWC ( NLAYS ) ) - ALLOCATE( GWC ( NLAYS ) ) - ALLOCATE( BLKPRS ( NLAYS ) ) - ALLOCATE( BLKTA ( NLAYS ) ) - ALLOCATE( BLKDENS( NLAYS ) ) - ALLOCATE( BLKZH ( NLAYS ) ) - ALLOCATE( BLKO3 ( NLAYS ) ) - ALLOCATE( BLKNO2 ( NLAYS ) ) + ALLOCATE( LWC ( NLAYS ) ) + ALLOCATE( RWC ( NLAYS ) ) + ALLOCATE( IWC ( NLAYS ) ) + ALLOCATE( SWC ( NLAYS ) ) + ALLOCATE( GWC ( NLAYS ) ) + ALLOCATE( BLKPRS ( NLAYS ) ) + ALLOCATE( BLKTA ( NLAYS ) ) + ALLOCATE( BLKDZ ( NLAYS ) ) + ALLOCATE( BLKDENS( NLAYS ) ) + ALLOCATE( BLKZH ( NLAYS ) ) + ALLOCATE( BLKO3 ( NLAYS ) ) + ALLOCATE( BLKNO2 ( NLAYS ) ) ALLOCATE( BLKZF ( NLAYS+1 ) ) - ALLOCATE( CLOUDS ( NLAYS ) ) - ALLOCATE( CLDFRAC( NLAYS ) ) + ALLOCATE( CLOUDS ( NLAYS ) ) + ALLOCATE( CLDFRAC( NLAYS ) ) ALLOCATE( BLKRJ_RES( NLAYS,NPHOTAB ) ) ALLOCATE( BLKRJ_ACM( NLAYS,NPHOTAB ) ) @@ -475,9 +454,16 @@ END SUBROUTINE O3TOTCOL ALLOCATE( TAU_TOT ( NLAYS,NWL ) ) ALLOCATE( TOTAL_OC ( NCOLS,NROWS ) ) + ALLOCATE( TAU_AERO_550 ( NCOLS,NROWS ) ) + TAU_AERO_550 = 0.0 IF ( PHOTDIAG ) THEN - ALLOCATE( TROPO_OC ( NCOLS,NROWS ) ) + + ALLOCATE( TROPO_OC ( NCOLS,NROWS ) ) + ALLOCATE( CO_COLUMN ( NCOLS,NROWS ) ) + ALLOCATE( SO2_COLUMN ( NCOLS,NROWS ) ) + ALLOCATE( NO2_COLUMN ( NCOLS,NROWS ) ) + ALLOCATE( HCHO_COLUMN( NCOLS,NROWS ) ) ALLOCATE( TROPO_O3_EXCEED( NCOLS,NROWS ) ) ALLOCATE( N_EXCEED_TROPO3( NCOLS,NROWS ) ) ALLOCATE( TRANSMIS_DIFFUSE( NCOLS,NROWS ) ) @@ -486,73 +472,205 @@ END SUBROUTINE O3TOTCOL ALLOCATE( CLR_TRANSMISSION( NCOLS,NROWS ) ) ALLOCATE( CLR_TRANS_DIRECT( NCOLS,NROWS ) ) ALLOCATE( CLR_REFLECTION ( NCOLS,NROWS ) ) - ALLOCATE( ETOT_SFC_WL ( NCOLS,NROWS,NWL ) ) ALLOCATE( TAU_AERO_WL ( NCOLS,NROWS,NWL ) ) ALLOCATE( TAU_CLOUD_WL ( NCOLS,NROWS,NWL ) ) -#ifdef phot_debug +#ifdef phot_debug ALLOCATE( SSA_CLOUD_WL( NCOLS,NROWS,NWL ) ) ALLOCATE( ASY_CLOUD_WL( NCOLS,NROWS,NWL ) ) -#endif +#endif ALLOCATE( TAU_TOT_WL ( NCOLS,NROWS,NWL ) ) ALLOCATE( TAUO3_TOP_WL( NCOLS,NROWS,NWL ) ) - + N_EXCEED_TROPO3 = 0.0 TROPO_O3_EXCEED = 0.0 TSTEP_COUNT = 0 + TROPO_OC = 0.0 + CO_COLUMN = 0.0 + SO2_COLUMN = 0.0 + NO2_COLUMN = 0.0 + HCHO_COLUMN = 0.0 + + +!...write wavelength data to a character array + + ALLOCATE ( WLTXT( NWL ) ) + + DO IWL = 1, NWL + WRITE( WLTXT( IWL ),'(I3.3)' ) INT( WAVELENGTH( IWL ) ) + END DO + +! get wanted number of layers for PHOTDIAG2 and PHOTDIAG3 files + IF ( NLAYS_DIAG .EQ. 0 ) NLAYS_DIAG = NLAYS + NLAYS_DIAG = MAX( 1, MIN( NLAYS_DIAG, NLAYS)) + +! get wanted wavelengths for PHOTDIAG2 and PHOTDIAG3 files + ALLOCATE( WAVE_LIST( NWL ) ) + WAVE_LIST( : ) = '' + IF ( NWAVE .GT. NWL ) + & CALL LOG_MESSAGE( LOGDEV, 'Error: the number of ' // + & 'wavelengths the user has requested for diagnostic ' // + & 'photolysis output exceeds the number of internal model ' // + & 'wavelengths.' ) + IF ( NWAVE .EQ. 0 ) THEN ! use all wavelenghts + N_DIAG_WVL = NWL + ALLOCATE ( DIAG_WVL( N_DIAG_WVL ) , STAT = ALLOCSTAT ) + IF ( ALLOCSTAT .NE. 0 ) THEN + XMSG = 'Failure allocating DIAG_WVL' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + DO IWL = 1, NWL + DIAG_WVL( IWL ) = IWL + END DO + WRITE(LOGDEV,'(5X,A,I3)')'Environment Variable NWAVE_PHOTDIAG not found ' + & // 'setting PHOTDIAG2 and PHOTDIAG3 to output all wavelengths. Integer ' + & // 'truncated values are below.' + DO IWL = 1, N_DIAG_WVL + SPC = DIAG_WVL( IWL ) + WRITE(LOGDEV,'(5X,I3,1X,A16)')IWL, WLTXT(SPC) + END DO + ELSE ! use the environment list + WAVE_LIST( 1:NWAVE ) = WAVE_ENV( 1:NWAVE ) + N_DIAG_WVL = 0 + ! first remove identical values + DO V = 1, NWAVE-1 + DO L = (V+1), NWAVE + IF( TRIM( WAVE_LIST( V ) ) .EQ. TRIM( WAVE_LIST( L ) ) )THEN + WAVE_LIST( L ) = " " + END IF + END DO + END DO + ! Now count number of unique values + DO V = 1, NWAVE + IF( LEN_TRIM( WAVE_LIST( V ) ) .GT. 0 )N_DIAG_WVL = N_DIAG_WVL + 1 + END DO + ALLOCATE ( DIAG_WVL( N_DIAG_WVL ) , STAT = ALLOCSTAT ) + IF ( ALLOCSTAT .NE. 0 ) THEN + XMSG = 'Failure allocating DIAG_WVL' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + ! Next find unique list value in wavelenght spectrum + IWL = 0 + DO V = 1, NWAVE + IF( LEN_TRIM( WAVE_LIST( V ) ) .LT. 1 )CYCLE + IWL = IWL + 1 + DIAG_WVL( IWL ) = INDEXR ( TRIM( WAVE_LIST( V ) ), NWL, WLTXT ) + IF ( DIAG_WVL( IWL ) .LT. 1 ) THEN + WRITE(LOGDEV,'(5X,A)')'PHOT: Cannot find requested wavelength, ' + & // TRIM( WAVE_LIST( IWL ) ) // ' for DIAG2 and DIAG3 files ' + & // ' in spectrum ' + END IF + END DO + IF( MINVAL( DIAG_WVL ) .LT. 1 )THEN + XMSG = 'FAILED TO find the above requested wavelenght spectrum ' + WRITE( LOGDEV,'(5X,A)')XMSG + XMSG = 'Permitted integer truncated values of wavelenght spectrum ' + DO IWL = 1, NWL + WRITE(LOGDEV,'(10X,I3,1X,A16)')IWL, WLTXT(IWL) + END DO + XMSG = 'ERROR using the environment variable, NWAVE_PHOTDIAG ' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + ELSE + WRITE(LOGDEV,'(5X,A,I3)')'Environment Variable NWAVE_PHOTDIAG found ' + & // 'setting PHOTDIAG2 and PHOTDIAG3 to output below wavelenghts' + DO IWL = 1, N_DIAG_WVL + SPC = DIAG_WVL( IWL ) + WRITE(LOGDEV,'(5X,I3,1X,A16)')IWL, WLTXT(SPC) + END DO + END IF + END IF + WRITE(LOGDEV,'(/)') - DIAG_WVL( 1 ) = 1 - DIAG_WVL( N_DIAG_WVL ) = NWL - ALLOCATE ( AERO_ASYM( NCOLS,NROWS,NLAYS,N_DIAG_WVL ), STAT = ALLOCSTAT ) + ALLOCATE ( AERO_ASYM( NCOLS,NROWS,NLAYS_DIAG,N_DIAG_WVL ), STAT = ALLOCSTAT ) IF ( ALLOCSTAT .NE. 0 ) THEN XMSG = 'Failure allocating 3D AERO_ASYM' CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF - ALLOCATE ( AERO_SSA( NCOLS,NROWS,NLAYS,N_DIAG_WVL ), STAT = ALLOCSTAT ) + ALLOCATE ( AERO_SSA( NCOLS,NROWS,NLAYS_DIAG,N_DIAG_WVL ), STAT = ALLOCSTAT ) IF ( ALLOCSTAT .NE. 0 ) THEN XMSG = 'Failure allocating 3D AERO_SSA' CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF - ALLOCATE ( TAU_AERO( NCOLS,NROWS,NLAYS,N_DIAG_WVL ), STAT = ALLOCSTAT ) + ALLOCATE ( AERO_EXT( NCOLS,NROWS,NLAYS_DIAG,N_DIAG_WVL ), STAT = ALLOCSTAT ) IF ( ALLOCSTAT .NE. 0 ) THEN - XMSG = 'Failure allocating 3D TAU_AERO' + XMSG = 'Failure allocating 3D AERO_EXT' CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF - ALLOCATE ( TAU( NCOLS,NROWS,NLAYS,N_DIAG_WVL ), STAT = ALLOCSTAT ) + ALLOCATE ( TOT_EXT( NCOLS,NROWS,NLAYS_DIAG,N_DIAG_WVL ), STAT = ALLOCSTAT ) IF ( ALLOCSTAT .NE. 0 ) THEN - XMSG = 'Failure allocating 3D TAU' + XMSG = 'Failure allocating 3D TOT_EXT' CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF - ALLOCATE ( ACTINIC_FX( NCOLS,NROWS,NLAYS,NWL ), STAT = ALLOCSTAT ) + ALLOCATE ( GAS_EXT( NCOLS,NROWS,NLAYS_DIAG,N_DIAG_WVL ), STAT = ALLOCSTAT ) IF ( ALLOCSTAT .NE. 0 ) THEN - XMSG = 'Failure allocating ACTINIC_FX' + XMSG = 'Failure allocating 3D GAS_EXT' CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF -!...write wavelength data to a character array - - ALLOCATE ( WLTXT( NWL ) ) - - DO IWL = 1, NWL - WRITE( WLTXT( IWL ),'(I3.3)' ) INT( WAVELENGTH( IWL ) ) - END DO + ALLOCATE ( ACTINIC_FX( NCOLS,NROWS,NLAYS_DIAG,N_DIAG_WVL ), STAT = ALLOCSTAT ) + IF ( ALLOCSTAT .NE. 0 ) THEN + XMSG = 'Failure allocating ACTINIC_FX' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF -!...open the photolysis rate diagnostic files + ALLOCATE ( OUTPUT_BUFF( NCOLS,NROWS,NLAYS_DIAG ), STAT = ALLOCSTAT ) + IF ( ALLOCSTAT .NE. 0 ) THEN + XMSG = 'Failure allocating OUTPUT_BUFF' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF - ODATE = JDATE; OTIME = JTIME -#ifndef phot_extra_tstep + VARNM = 'CO' + LGC_CO = INDEX1( VARNM, N_GC_SPC, GC_SPC ) + IF ( LGC_CO .LE. 0 ) THEN + XMSG = 'Could not find ' // VARNM // 'in species table' + CALL M3WARN ( PNAME, JDATE, JTIME, XMSG ) + WRITE(LOGDEV,95101) + END IF + + VARNM = 'SO2' + LGC_SO2 = INDEX1( VARNM, N_GC_SPC, GC_SPC ) + IF ( LGC_SO2 .LE. 0 ) THEN + XMSG = 'Could not find ' // VARNM // 'in species table' + CALL M3WARN ( PNAME, JDATE, JTIME, XMSG ) + WRITE(LOGDEV,95101) + END IF + + VARNM = 'HCHO' + LGC_HCHO = INDEX1( VARNM, N_GC_SPC, GC_SPC ) + IF ( LGC_HCHO .LE. 0 ) THEN + VARNM = 'FORM' + LGC_HCHO = INDEX1( VARNM, N_GC_SPC, GC_SPC ) + IF ( LGC_HCHO .LE. 0 ) THEN + XMSG = 'Could not find HCHO or FORM, i.e., formaldehyde, in species table' + CALL M3WARN ( PNAME, JDATE, JTIME, XMSG ) + WRITE(LOGDEV,95101) + END IF + END IF + +!...open the photolysis diagnostic files + ODATE = START_DATE; OTIME = START_TIME; OSTEP = 0 +#ifdef phot_write_start + IF ( IO_PE_INCLUSIVE ) CALL OPPHOT ( ODATE, OTIME, DTSTEP( 1 ) ) +#else CALL NEXTIME ( ODATE, OTIME, DTSTEP( 1 ) ) ! output timestamp ending time -#endif IF ( IO_PE_INCLUSIVE ) CALL OPPHOT ( ODATE, OTIME, DTSTEP( 1 ) ) - - CALL SUBST_BARRIER +! reset ODATE and OTIME for counting + ODATE = START_DATE; OTIME = START_TIME +#endif END IF ! photdiag + CALL SUBST_BARRIER + ALLOCATE ( AERO_EXT_550( NCOLS,NROWS,NLAYS ), STAT = ALLOCSTAT ) + IF ( ALLOCSTAT .NE. 0 ) THEN + XMSG = 'Failure allocating 3D AERO_EXT_550' + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + !...set pointers to species O3 and NO2 in CGRID VARNM = 'O3' @@ -569,23 +687,14 @@ END SUBROUTINE O3TOTCOL CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT3 ) END IF -#ifdef phot_extra_tstep - ELSE - IF ( PHOTDIAG ) THEN - ODATE = JDATE; OTIME = JTIME - CALL NEXTIME ( ODATE, OTIME, DTSTEP( 2 ) ) ! sync time step - END IF -#endif + END IF ! firstime - IF ( JD_STRAT_O3MIN .NE. JDATE ) THEN + IF ( INT ( JD_STRAT_O3MIN ) .NE. JDATE ) THEN !...set minimum fraction of ozone column above PTOP - CALL SEASONAL_STRAT_O3( JDATE, JTIME ) MIN_STRATO3_FRAC = MONTH_STRAT_03_FRAC MAX_TROPOO3_FRAC = MAX( 1.0 - MONTH_STRAT_03_FRAC, 0.0 ) - WRITE( LOGDEV,*)'PHOT: MIN_STRATO3_FRAC = ',MIN_STRATO3_FRAC - JD_STRAT_O3MIN = REAL( JDATE, 4) END IF !...initialize variables tracking whether stratosphere ozone column satisfies @@ -596,12 +705,18 @@ END SUBROUTINE O3TOTCOL N_TROPO_O3_TOGGLE = 0 TSTEP_COUNT = TSTEP_COUNT + 1 - CALL GET_PHOT_MET( JDATE, JTIME, MDATE, MTIME ) + MIDDATE = JDATE + MIDTIME = JTIME + ITMSTEP = TIME2SEC( DTSTEP( 2 ) ) / 2 + CALL NEXTIME( MIDDATE, MIDTIME, SEC2TIME( ITMSTEP ) ) + + CALL CONVCLD_PROP_ACM( JDATE, JTIME, DTSTEP ) + CALL GET_PHOT_MET( JDATE, JTIME, MIDDATE, MIDTIME ) !...Get cosine of solar parameters and set DARK - CALL UPDATE_SUN( JDATE, JTIME, MDATE, MTIME ) - + CALL UPDATE_SUN( JDATE, JTIME, MIDDATE, MIDTIME ) + RSQD = DIST_TO_SUN * DIST_TO_SUN IF ( MAXVAL( COSINE_ZENITH ) .LE. 0.0 ) THEN @@ -612,16 +727,22 @@ END SUBROUTINE O3TOTCOL !...set surface albedos - CALL GET_ALBEDO( MDATE, MTIME, LOGDEV, COSINE_ZENITH, LAT, LON ) + CALL GET_ALBEDO( MIDDATE, MIDTIME, COSINE_ZENITH, LAT, LON ) !...SA Write COSINE_ZENITH array at the end of each output tstep + JTIME_CHK = .FALSE. + OSTEP = OSTEP + TIME2SEC( DTSTEP( 2 ) ) + JTIME_CHK = ( OSTEP .GE. TIME2SEC( DTSTEP( 1 ) ) ) + IF ( JTIME_CHK ) THEN + OSTEP = 0 + CALL NEXTIME( ODATE, OTIME, DTSTEP( 1 ) ) + END IF +#ifdef phot_write_start + JTIME_CHK = ( ODATE .EQ. STDATE .AND. OTIME .EQ. STTIME ) +#endif + IF ( PHOTDIAG ) THEN -#ifndef phot_extra_tstep - ODATE = JDATE; OTIME = JTIME - CALL NEXTIME ( ODATE, OTIME, DTSTEP( 2 ) ) ! sync time step -#endif - JTIME_CHK = ( MOD( TIME2SEC( OTIME ), TSTEP ) .EQ. 0 ) #ifdef parallel_io IF ( .NOT. IO_PE_INCLUSIVE ) THEN IF ( .NOT. OPEN3( CTM_RJ_1, FSREAD3, PNAME ) ) THEN @@ -632,99 +753,144 @@ END SUBROUTINE O3TOTCOL XMSG = 'Could not open ' // TRIM(CTM_RJ_2) CALL M3EXIT( PNAME, ODATE, OTIME, XMSG, XSTAT1 ) END IF + IF ( .NOT. OPEN3( CTM_RJ_3, FSREAD3, PNAME ) ) THEN + XMSG = 'Could not open ' // TRIM(CTM_RJ_3) + CALL M3EXIT( PNAME, ODATE, OTIME, XMSG, XSTAT1 ) + END IF END IF #endif - ELSE - JTIME_CHK = .FALSE. - END IF + END IF + + CALCULATE_EXT_550 = .TRUE. !JTIME_CHK - !...If sun below horizon at all cells, zero photolysis rates & exit !... (assumes sun below horizon at *all* levels!) IF ( DARK ) THEN RJ = 0.0 - -!...write to the log file, CTM_RJ_1 file and return - - WRITE( LOGDEV, 1003 ) MYPE, JDATE, JTIME + RJ_SUB = 0.0 + RJ_RES = 0.0 + ETOT_SFC_WL = 0.0 + AERO_EXT_550 = 0.0 + TAU_AERO_550 = 0.0 !...Initialize ETOT_SFC, TAU_AERO, TAU_TOT, TAUO3_TOP to 0.0 !...Write data to output diagnostic file - TOTAL_OC = 0.0 + IF ( JTIME_CHK .AND. PHOTDIAG ) THEN - IF ( JTIME_CHK ) THEN - - TROPO_OC = 0.0 - ETOT_SFC_WL = 0.0 TAUO3_TOP_WL = 0.0 TAU_AERO_WL = 0.0 TAU_CLOUD_WL = 0.0 -#ifdef phot_debug +#ifdef phot_debug SSA_CLOUD_WL = 0.0 ASY_CLOUD_WL = 0.0 -#endif +#endif TAU_TOT_WL = 0.0 - TAU = 0.0 - TAU_AERO = 0.0 + TOT_EXT = 0.0 + GAS_EXT = 0.0 + AERO_EXT = 0.0 AERO_SSA = 0.0 AERO_ASYM = 0.0 ACTINIC_FX = 0.0 -! TROPO_O3_EXCEED = 0.0 TRANSMIS_DIFFUSE = 0.0 TRANSMIS_DIRECT = 0.0 REFLECT_COEFF = 0.0 CLR_TRANSMISSION = 0.0 CLR_TRANS_DIRECT = 0.0 - CLR_REFLECTION = 0.0 - - END IF ! if JTIME_CHK + CLR_REFLECTION = 0.0 + + DO ROW = 1, NROWS + DO COL = 1, NCOLS + BLKDENS( 1 ) = DENS ( COL,ROW,1 ) * DENS_CONV ! [molecules / cm**3] + BLKDZ ( 1 ) = ZFULL( COL,ROW,1 ) + DO L = 2, NLAYS + BLKDENS( L ) = DENS( COL,ROW,L ) * DENS_CONV ! [molecules / cm**3] + BLKDZ ( L ) = ZFULL( COL,ROW,L ) - ZFULL( COL,ROW,L-1 ) + END DO + MSCALE = 1.0E-19 ! 100.0*10E-15*PPM_MCM3, so units are petamolecules/cm2 + CALL COLUMN_GAS( IGAS=LGC_CO, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=CO_COLUMN ) + CALL COLUMN_GAS( IGAS=LGC_SO2, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=SO2_COLUMN ) + CALL COLUMN_GAS( IGAS=LGC_NO2, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=NO2_COLUMN ) + CALL COLUMN_GAS( IGAS=LGC_HCHO, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=HCHO_COLUMN ) + MSCALE = 1.0E-4 * CONC_TO_DU ! so units are Dobsons + CALL COLUMN_GAS( IGAS=LGC_O3, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=TROPO_OC ) +!...get total ozone column based on OMI observations + CALL O3TOTCOL ( LAT( COL,ROW ), LON( COL,ROW ), MIDDATE, MIDTIME, TOTAL_OC( COL,ROW ) ) + END DO + END DO + ELSE + DO ROW = 1, NROWS + DO COL = 1, NCOLS +!...get total ozone column based on OMI observations + CALL O3TOTCOL ( LAT( COL,ROW ), LON( COL,ROW ), MIDDATE,MIDTIME, TOTAL_OC( COL,ROW ) ) + END DO + END DO + END IF ! if JTIME_CHK and PHOTDIAG ELSE ! all cells not dark - + !...MAIN loop over all rows and columns - LOOP_ROWS: DO ROW = 1, MY_NROWS - LOOP_COLS: DO COL = 1, MY_NCOLS - + LOOP_ROWS: DO ROW = 1, NROWS + LOOP_COLS: DO COL = 1, NCOLS + PHOT_COL = COL + PECOL_OFFSET PHOT_ROW = ROW + PEROW_OFFSET COSZEN = COSINE_ZENITH( COL,ROW ) ! local cosine of solar zenith angle + TAU_AERO_550( COL,ROW ) = 0.0 + AERO_EXT_550( COL,ROW,: ) = 0.0 IF ( COSZEN .LE. 0.0 ) THEN !...the cell is dark: set variables to zero and cycle RJ( COL,ROW, :,: ) = 0.0 - - IF ( JTIME_CHK ) THEN - TOTAL_OC( COL,ROW ) = 0.0 - TROPO_OC( COL,ROW ) = 0.0 - ETOT_SFC_WL ( COL,ROW, : ) = 0.0 + RJ_RES( COL,ROW, :,: ) = 0.0 + RJ_SUB( COL,ROW, :,: ) = 0.0 + ETOT_SFC_WL ( COL,ROW, : ) = 0.0 + + IF ( JTIME_CHK .AND. PHOTDIAG ) THEN TAUO3_TOP_WL( COL,ROW, : ) = 0.0 TAU_AERO_WL ( COL,ROW, : ) = 0.0 TAU_CLOUD_WL( COL,ROW, : ) = 0.0 -#ifdef phot_debug +#ifdef phot_debug SSA_CLOUD_WL( COL,ROW, : ) = 0.0 ASY_CLOUD_WL( COL,ROW, : ) = 0.0 -#endif - TAU_TOT_WL( COL,ROW, : ) = 0.0 - TAU ( COL,ROW, :,: ) = 0.0 - TAU_AERO ( COL,ROW, :,: ) = 0.0 - AERO_SSA ( COL,ROW, :,: ) = 0.0 - AERO_ASYM ( COL,ROW, :,: ) = 0.0 - ACTINIC_FX( COL,ROW, :,: ) = 0.0 - +#endif + TAU_TOT_WL ( COL,ROW, : ) = 0.0 + TOT_EXT ( COL,ROW, :,: ) = 0.0 + GAS_EXT ( COL,ROW, :,: ) = 0.0 + AERO_EXT ( COL,ROW, :,: ) = 0.0 + AERO_SSA ( COL,ROW, :,: ) = 0.0 + AERO_ASYM ( COL,ROW, :,: ) = 0.0 + ACTINIC_FX ( COL,ROW, :,: ) = 0.0 + ! TROPO_O3_EXCEED( COL,ROW ) = 0.0 TRANSMIS_DIFFUSE( COL,ROW ) = 0.0 TRANSMIS_DIRECT ( COL,ROW ) = 0.0 REFLECT_COEFF ( COL,ROW ) = 0.0 CLR_TRANSMISSION( COL,ROW ) = 0.0 CLR_TRANS_DIRECT( COL,ROW ) = 0.0 - CLR_REFLECTION ( COL,ROW ) = 0.0 - END IF + CLR_REFLECTION ( COL,ROW ) = 0.0 + + BLKDENS( 1 ) = DENS ( COL,ROW,1 ) * DENS_CONV ! [molecules / cm**3] + BLKDZ ( 1 ) = ZFULL( COL,ROW,1 ) + DO L = 2, NLAYS + BLKDENS( L ) = DENS( COL,ROW,L ) * DENS_CONV ! [molecules / cm**3] + BLKDZ ( L ) = ZFULL( COL,ROW,L ) - ZFULL( COL,ROW,L-1 ) + END DO + MSCALE = 1.0E-19 ! 100.0*10E-15*PPM_MCM3, so units are petamolecules/cm2 + CALL COLUMN_GAS( IGAS=LGC_CO, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=CO_COLUMN ) + CALL COLUMN_GAS( IGAS=LGC_SO2, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=SO2_COLUMN ) + CALL COLUMN_GAS( IGAS=LGC_NO2, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=NO2_COLUMN ) + CALL COLUMN_GAS( IGAS=LGC_HCHO, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=HCHO_COLUMN ) + MSCALE = 1.0E-4 * CONC_TO_DU ! so units are Dobsons + CALL COLUMN_GAS( IGAS=LGC_O3, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=TROPO_OC ) +!...get total ozone column based on OMI observations + CALL O3TOTCOL ( LAT( COL,ROW ), LON( COL,ROW ), MIDDATE, MIDTIME, TOTAL_OC( COL,ROW ) ) + END IF CYCLE LOOP_COLS @@ -742,20 +908,15 @@ END SUBROUTINE O3TOTCOL ZSFC = HT( COL,ROW ) ! surface height [m] SINZEN = SQRT( 1.0 - COSZEN * COSZEN ) ! sine of zenith angle -!...local latitude and longitude - -! LATCR = LAT( COL,ROW ) -! LONCR = LON( COL,ROW ) - !...get total ozone column based on OMI observations - CALL O3TOTCOL ( LAT( COL,ROW ), LON( COL,ROW ), JDATE, TOTAL_O3_COLUMN ) - + CALL O3TOTCOL ( LAT( COL,ROW ), LON( COL,ROW ), MIDDATE, MIDTIME, TOTAL_O3_COLUMN ) + IF ( USE_ACM_CLOUD .OR. CLDATT ) THEN OWATER_FRAC = MAX( ( 1.0 - SEAICE( COL,ROW ) ), 0.0 ) & * WATER_FRACTION( COL,ROW ) SEAICE_FRAC = SEAICE( COL,ROW ) * WATER_FRACTION( COL,ROW ) SNOW_FRAC = SNOCOV( COL,ROW ) - COL_CLOUD = PHOT_COL + COL_CLOUD = PHOT_COL ROW_CLOUD = PHOT_ROW END IF @@ -785,7 +946,7 @@ END SUBROUTINE O3TOTCOL IF ( CLDATT .AND. CFRAC_2D( COL,ROW ) .GT. 0.0 ) THEN DO L = 1, NLAYS - + IF ( CFRAC_3D( COL,ROW,L ) .GT. 0.0 ) THEN CLOUDS ( L ) = .TRUE. CLOUD_LAYERING( L ) = .TRUE. @@ -794,7 +955,7 @@ END SUBROUTINE O3TOTCOL MSCALE = 1.0E+3 * DENS ( COL,ROW,L ) IWC( L ) = MSCALE * QI( COL,ROW,L ) GWC( L ) = MSCALE * QG( COL,ROW,L ) - SWC( L ) = MSCALE * QS( COL,ROW,L ) + SWC( L ) = MSCALE * QS( COL,ROW,L ) LWC( L ) = MSCALE * QC( COL,ROW,L ) RWC( L ) = MSCALE * QR( COL,ROW,L ) ELSE @@ -803,15 +964,15 @@ END SUBROUTINE O3TOTCOL CLDFRAC( L ) = 0.0 IWC( L ) = 0.0 GWC( L ) = 0.0 - SWC( L ) = 0.0 + SWC( L ) = 0.0 LWC( L ) = 0.0 RWC( L ) = 0.0 END IF END DO ! loop on layers clouds ! get optical properties of resolved cloud hydrometeors - CALL GET_DROPLET_OPTICS( NLAYS, BLKTA, OWATER_FRAC, SEAICE_FRAC, SNOW_FRAC, LWC ) + CALL GET_DROPLET_OPTICS( NLAYS, BLKTA, OWATER_FRAC, SEAICE_FRAC, SNOW_FRAC, LWC ) CALL GET_ICE_OPTICS( NLAYS, BLKTA, IWC ) - CALL GET_AGGREGATE_OPTICS( NLAYS, RWC, SWC, GWC ) + CALL GET_AGGREGATE_OPTICS( NLAYS, RWC, SWC, GWC ) ELSE CLOUDS = .FALSE. CLOUD_LAYERING = .FALSE. @@ -824,31 +985,26 @@ END SUBROUTINE O3TOTCOL RWC = 0.0 CALL CLEAR_HYDROMETEOR_OPTICS() END IF - + !..calculate needed aerosol properties in column ! IF ( CORE_SHELL ) THEN - CALL GET_AERO_DATA ( COL,ROW, NLAYS, CGRID ) + CALL GET_AERO_DATA ( COL,ROW, NLAYS, DENS, CGRID ) ! ELSE ! CALL AERO_OPTICS_INTERNAL( COL,ROW, NLAYS, CGRID ) ! END IF ! set surface albedo - FORALL ( IWL = 1:NWL ) + DO IWL = 1, NWL ALB( IWL ) = SURFACE_ALBEDO( IWL, COL,ROW ) - END FORALL -!set min/max fractions of ozone column in stratosphere and troposphere -! MIN_STRATO3_FRAC = MIN_STRAT_03_FRAC( COL, ROW ) -! MAX_TROPOO3_FRAC = MAX( 1.0 - MIN_STRAT_03_FRAC( COL, ROW ), 0.0 ) -! MIN_STRATO3_FRAC = MONTH_STRAT_03_FRAC( COL, ROW ) -! MAX_TROPOO3_FRAC = MAX( 1.0 - MONTH_STRAT_03_FRAC( COL, ROW ), 0.0 ) + END DO !...calculate resolved-sky photolysis rates at all layers: - NEW_PROFILE = .TRUE. - ONLY_SOLVE_RAD = .FALSE. - - CALL NEW_OPTICS ( JDATE, JTIME, NLAYS, + NEW_PROFILE = .TRUE. + ONLY_SOLVE_RAD = .FALSE. + + CALL NEW_OPTICS ( JDATE, JTIME, NLAYS, & BLKTA, BLKPRS, BLKDENS, BLKZH, BLKZF, & BLKO3, BLKNO2, & ZSFC, COSZEN, SINZEN, RSQD, @@ -857,59 +1013,87 @@ END SUBROUTINE O3TOTCOL & TAU_RAY, SSA, TAU_CLOUD, TOTAL_O3_COLUMN ) !...load diagnostic file arrays + ! Aerosol extinction and optical depth are saved every + ! time step + FORALL ( L = 1:NLAYS ) + AERO_EXT_550( COL,ROW,L ) = 1000.0 * AERO_EXTI_550( L ) + END FORALL + DO LEV = 1, NLAYS + TAU_AERO_550 ( COL,ROW ) = TAU_AERO_550 ( COL,ROW ) + & + AERO_EXTI_550( LEV ) * BLKDZ( LEV ) + END DO + IF ( PHOTDIAG .AND. .NOT. STRATO3_MINS_MET ) THEN N_EXCEED_TROPO3( COL,ROW ) = N_EXCEED_TROPO3( COL,ROW ) + 1.0 TROPO_O3_EXCEED( COL,ROW ) = TROPO_O3_COLUMN/(MAX_TROPOO3_FRAC*TOTAL_O3_COLUMN) - 1.0 -! & + 1.0 / TROPO_O3_TOGGLE - 1.0 & + TROPO_O3_EXCEED( COL,ROW ) -! ELSE IF( PHOTDIAG ) THEN -! TROPO_O3_EXCEED( COL,ROW ) = 0.0 - END IF + END IF - IF ( JTIME_CHK ) THEN - TOTAL_OC( COL,ROW ) = REAL( TOTAL_O3_COLUMN ) - TROPO_OC( COL,ROW ) = REAL( TROPO_O3_COLUMN ) + FORALL ( IWL = 1:NWL ) + ETOT_SFC_WL ( COL,ROW,IWL ) = IRRADIANCE( 1,IWL ) + END FORALL + + IF ( JTIME_CHK .AND. PHOTDIAG ) THEN + TOTAL_OC( COL,ROW ) = TOTAL_O3_COLUMN TRANSMIS_DIFFUSE( COL,ROW ) = TRANSMISSION TRANSMIS_DIRECT( COL,ROW ) = TRANS_DIRECT REFLECT_COEFF( COL,ROW ) = REFLECTION - FORALL( IWL = 1:NWL ) - ETOT_SFC_WL ( COL,ROW,IWL ) = IRRADIANCE( 1,IWL ) - TAUO3_TOP_WL( COL,ROW,IWL ) = TAUO3_TOP( IWL ) - TAU_AERO_WL ( COL,ROW,IWL ) = TAUC_AERO( 1,IWL ) - TAU_TOT_WL ( COL,ROW,IWL ) = TAU_TOT ( 1,IWL ) - TAU_CLOUD_WL( COL,ROW,IWL ) = TAU_CLOUD( 1,IWL ) -#ifdef phot_debug + DO IWL = 1, NWL + TAUO3_TOP_WL( COL,ROW,IWL ) = TAUO3_TOP( IWL ) + TAU_AERO_WL ( COL,ROW,IWL ) = TAUC_AERO( 1,IWL ) + TAU_TOT_WL ( COL,ROW,IWL ) = TAU_TOT ( 1,IWL ) + TAU_CLOUD_WL( COL,ROW,IWL ) = TAU_CLOUD( 1,IWL ) +#ifdef phot_debug SSA_CLOUD_WL( COL,ROW,IWL ) = AVE_SSA_CLD ( IWL ) ASY_CLOUD_WL( COL,ROW,IWL ) = AVE_ASYMM_CLD( IWL ) -#endif - END FORALL - FORALL ( LEV = 1:NLAYS, IWL = 1:NWL ) - ACTINIC_FX( COL,ROW,LEV,IWL ) = ACTINIC_FLUX( LEV,IWL ) - END FORALL - +#endif + END DO + + DO L = 1, N_DIAG_WVL IWL = DIAG_WVL( L ) - FORALL ( LEV = 1:NLAYS ) - TAU ( COL,ROW,LEV,L ) = TAU_TOT ( LEV,IWL ) - TAU_AERO( COL,ROW,LEV,L ) = TAUC_AERO( LEV,IWL ) + FORALL ( LEV = 1:NLAYS_DIAG ) + ACTINIC_FX( COL,ROW,LEV,L ) = ACTINIC_FLUX( LEV,IWL ) + TOT_EXT ( COL,ROW,LEV,L ) = 1000.0 * EXTINCTION( LEV,IWL ) + GAS_EXT ( COL,ROW,LEV,L ) = 1000.0 * GAS_EXTINCTION( LEV,IWL ) + AERO_EXT( COL,ROW,LEV,L ) = 1000.0 * AERO_EXTI_COEF( LEV,IWL ) END FORALL - FORALL ( LEV = 1:NLAYS, AERO_EXTI_COEF( LEV,IWL ) .GT. EPSLON ) + FORALL ( LEV = 1:NLAYS_DIAG, AERO_EXTI_COEF( LEV,IWL ) .GT. EPSLON ) AERO_SSA ( COL,ROW,LEV,L ) = AERO_SCAT_COEF( LEV,IWL ) & / AERO_EXTI_COEF( LEV,IWL ) AERO_ASYM( COL,ROW,LEV,L ) = AERO_ASYM_FAC( LEV,IWL ) END FORALL - FORALL ( LEV = 1:NLAYS, AERO_EXTI_COEF( LEV,IWL ) .LE. EPSLON ) + FORALL ( LEV = 1:NLAYS_DIAG, AERO_EXTI_COEF( LEV,IWL ) .LE. EPSLON ) AERO_SSA ( COL,ROW,LEV,L ) = 1.0 AERO_ASYM( COL,ROW,LEV,L ) = 0.0 END FORALL END DO + IF ( COSZEN .LE. COS85 ) THEN + ! calculate because NEW_OPTICS sets BLKDZ and TROPO_O3_COLUMN to zero + BLKDZ( 1 ) = BLKZF( 2 ) + DO L = 2, NLAYS + BLKDZ( L ) = BLKZF( L+1 ) - BLKZF( L ) + END DO + MSCALE = 1.0E-4 * CONC_TO_DU ! so units are Dobsons + CALL COLUMN_GAS( IGAS=LGC_O3, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=TROPO_OC ) + ELSE + TROPO_OC( COL,ROW ) = TROPO_O3_COLUMN + END IF + MSCALE = 1.0E-19 ! 100.0*10E-15*PPM_MCM3, so units are petamolecules/cm2 + CALL COLUMN_GAS( IGAS=LGC_CO, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=CO_COLUMN ) + CALL COLUMN_GAS( IGAS=LGC_SO2, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=SO2_COLUMN ) + CALL COLUMN_GAS( IGAS=LGC_NO2, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=NO2_COLUMN ) + CALL COLUMN_GAS( IGAS=LGC_HCHO, UNIT_FACTOR=MSCALE, COLUMN_DENSITY=HCHO_COLUMN ) END IF !Set Photolysis rates to resolved sky values FORALL ( L = 1:NLAYS, IPHOT = 1:NPHOTAB ) - RJ( COL,ROW, L,IPHOT ) = 60.0 * BLKRJ_RES( L,IPHOT ) + RJ( COL,ROW, L,IPHOT ) = 60.0 * BLKRJ_RES( L,IPHOT ) + END FORALL ! Loop on layers and NPHOTAB + FORALL ( L = 1:NLAYS, IPHOT = 1:NPHOTAB ) + RJ_RES( COL,ROW, L,IPHOT ) = 60.0 * BLKRJ_RES( L,IPHOT ) END FORALL ! Loop on layers and NPHOTAB IF ( USE_ACM_CLOUD ) THEN @@ -943,16 +1127,14 @@ END SUBROUTINE O3TOTCOL END IF CLOUD_LAYERING( L ) = .FALSE. END DO -! write(logdev,*)'ACM cloud present fraction, cloud lwc(lev),iwc(lev),rwc(1),gwc(1) = ', -! & ACM_CLOUDS( COL,ROW ),lwc(lev),iwc(lev),rwc(1),gwc(1) - + ! get optical properties of of subgrid cloud hydrometeors - CALL GET_DROPLET_OPTICS( LEV, BLKTA, OWATER_FRAC, SEAICE_FRAC, SNOW_FRAC, LWC ) - CALL GET_ICE_OPTICS( LEV, BLKTA, IWC ) - CALL GET_AGGREGATE_OPTICS( LEV, RWC, SWC, GWC ) + CALL GET_DROPLET_OPTICS( LEV, BLKTA, OWATER_FRAC, SEAICE_FRAC, SNOW_FRAC, LWC ) + CALL GET_ICE_OPTICS( LEV, BLKTA, IWC ) + CALL GET_AGGREGATE_OPTICS( LEV, RWC, SWC, GWC ) !...calculate the acm-cloud photolysis rates for all layers: - NEW_PROFILE = .FALSE. + NEW_PROFILE = .FALSE. CALL NEW_OPTICS ( JDATE, JTIME, NLAYS, & BLKTA, BLKPRS, BLKDENS, BLKZH, BLKZF, & BLKO3, BLKNO2, @@ -966,8 +1148,12 @@ END SUBROUTINE O3TOTCOL !... note that both TAUC_AERO and TAUO3_TOP are the same for clear and !... cloudy regions MSCALE = MAX( 1.0 - ACM_CLOUDS( COL,ROW ), 0.0 ) + DO IWL = 1, NWL + ETOT_SFC_WL ( COL,ROW,IWL ) = MSCALE * ETOT_SFC_WL( COL,ROW,IWL ) + & + ACM_CLOUDS( COL,ROW ) * IRRADIANCE( 1,IWL ) + END DO - IF ( JTIME_CHK ) THEN + IF ( JTIME_CHK .AND. PHOTDIAG ) THEN TRANSMIS_DIRECT( COL,ROW ) = MSCALE * TRANSMIS_DIRECT( COL,ROW ) & + ACM_CLOUDS( COL,ROW ) * TRANS_DIRECT @@ -975,9 +1161,7 @@ END SUBROUTINE O3TOTCOL & + ACM_CLOUDS( COL,ROW ) * TRANSMISSION REFLECT_COEFF( COL,ROW ) = MSCALE * REFLECT_COEFF( COL,ROW ) & + ACM_CLOUDS( COL,ROW ) * REFLECTION - FORALL ( IWL = 1:NWL ) - ETOT_SFC_WL ( COL,ROW,IWL ) = MSCALE * ETOT_SFC_WL( COL,ROW,IWL ) - & + ACM_CLOUDS( COL,ROW ) * IRRADIANCE( 1,IWL ) + DO IWL = 1, NWL TAU_TOT_WL ( COL,ROW,IWL ) = MSCALE * TAU_TOT_WL( COL,ROW,IWL ) & + ACM_CLOUDS( COL,ROW ) * TAU_TOT( 1,IWL ) TAU_CLOUD_WL( COL,ROW,IWL ) = MSCALE * TAU_CLOUD_WL( COL,ROW,IWL ) @@ -988,28 +1172,28 @@ END SUBROUTINE O3TOTCOL ASY_CLOUD_WL( COL,ROW,IWL ) = MSCALE * ASY_CLOUD_WL( COL,ROW,IWL ) & + ACM_CLOUDS( COL,ROW ) * AVE_ASYMM_CLD( IWL ) #endif - END FORALL ! iwl - FORALL ( LEV = 1:NLAYS, IWL = 1:NWL ) - ACTINIC_FX( COL,ROW,LEV,IWL ) = MSCALE * ACTINIC_FX( COL,ROW,LEV,IWL ) - & + ACM_CLOUDS( COL,ROW ) * ACTINIC_FLUX( LEV,IWL ) - END FORALL ! lev and iwl - - DO L = 1, N_DIAG_WVL - IWL = DIAG_WVL( L ) - FORALL ( LEV = 1:NLAYS) - TAU( COL,ROW,LEV,L ) = MSCALE * TAU( COL,ROW,LEV,L ) - & + ACM_CLOUDS( COL,ROW ) * TAU_TOT( LEV,IWL ) - END FORALL + END DO ! iwl + + DO LEV = 1, NLAYS_DIAG + DO L = 1, N_DIAG_WVL + IWL = DIAG_WVL( L ) + TOT_EXT( COL,ROW,LEV,L ) = MSCALE * TOT_EXT( COL,ROW,LEV,L ) + & + ACM_CLOUDS( COL,ROW ) * EXTINCTION( LEV,IWL ) + ACTINIC_FX( COL,ROW,LEV,L ) = MSCALE * ACTINIC_FX( COL,ROW,LEV,L ) + & + ACM_CLOUDS( COL,ROW ) * ACTINIC_FLUX( LEV,IWL ) + END DO END DO END IF ! photdiag !Photolysis rates become a weighted average of the values from resolved and ACM skies FORALL ( L = 1:NLAYS, IPHOT = 1:NPHOTAB ) - RJ( COL,ROW, L, IPHOT ) = 60.0 * ACM_CLOUDS( COL,ROW ) * BLKRJ_ACM( L,IPHOT ) - & + MSCALE * RJ( COL,ROW,L,IPHOT ) - END FORALL ! Loop on layers and PHOT + RJ_SUB( COL,ROW, L, IPHOT ) = 60.0 * BLKRJ_ACM( L,IPHOT ) + RJ( COL,ROW, L, IPHOT ) = ACM_CLOUDS( COL,ROW ) * RJ_SUB( COL,ROW, L, IPHOT ) + & + MSCALE * RJ( COL,ROW,L,IPHOT ) + END FORALL ! Loop on layers and PHOT END IF END IF ! not USE_ACM_CLOUD and ACM_CLOUDS > 0 +!(Wei Li) !------------------------CANOPY PHOTOLYSIS CORRECTION/REDUCTION Section NOAA-ARL------------------------------------------- !Conditions to reduce weighted average of photolysis rates (RJ) due to canopy shading (if user-defined=true); P. C. Campbell !Following is based on work of ECCC in GEM-MACHv2.1: Makar et al. (2017) @@ -1128,15 +1312,16 @@ END SUBROUTINE O3TOTCOL ! RJ( COL,ROW, 1, : ) = ( RJ( COL,ROW, 1, : ) ! & + (RJ( COL,ROW, 1, : )*RJ_CORR( COL,ROW )) )/2.0 END IF !contigous canopy conditions - END IF !canopy shade + END IF !canopy shade + - IF ( JTIME_CHK ) THEN ! compute clear sky reflection and transmission coefficients + IF ( JTIME_CHK .AND. PHOTDIAG ) THEN ! compute clear sky reflection and transmission coefficients IF ( ANY( CLOUDS ) ) THEN IF ( CFRAC_2D( COL,ROW ) .GT. 0.0 ) THEN ! resolved and subgrid clouds exist CLOUDS = .FALSE. NEW_PROFILE = .FALSE. ONLY_SOLVE_RAD = .TRUE. - CALL NEW_OPTICS ( JDATE, JTIME, NLAYS, + CALL NEW_OPTICS ( JDATE, JTIME, NLAYS, & BLKTA, BLKPRS, BLKDENS, BLKZH, BLKZF, & BLKO3, BLKNO2, & ZSFC, COSZEN, SINZEN, RSQD, @@ -1162,6 +1347,10 @@ END SUBROUTINE O3TOTCOL END DO LOOP_ROWS END IF + + ! Store PM Diagnostic AOD and extinction + ELMO_AOD_550 = TAU_AERO_550 + ELMO_EXT_550 = AERO_EXT_550 !...report on whether stratospheric ozone column satisfies climatological minimums IF( N_TROPO_O3_TOGGLE .GT. 0 )THEN @@ -1175,6 +1364,7 @@ END SUBROUTINE O3TOTCOL !...write diagnostic data to output file at the end of every output tstep IF ( JTIME_CHK ) THEN + IF ( PHOTDIAG ) THEN VARNM = 'COSZENS' IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, @@ -1189,26 +1379,32 @@ END SUBROUTINE O3TOTCOL CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF - VARNM = 'TROPO_O3_COLUMN' - IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, TROPO_OC ) ) THEN + VARNM = 'CO_COLUMN' + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, CO_COLUMN ) ) THEN XMSG = 'Error writing variable ' // VARNM CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF - - IMONTH = IMONTH + 1 - IF( IMONTH .GT. 12 )THEN - IMONTH = 1 - TDATE = 2011001 + VARNM = 'SO2_COLUMN' + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, SO2_COLUMN ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + VARNM = 'NO2_COLUMN' + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, NO2_COLUMN ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + VARNM = 'HCHO_COLUMN' + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, HCHO_COLUMN ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF - TDATE = TDATE + DAYS( IMONTH ) -! CALL SEASONAL_STRAT_O3(TDATE, JTIME ) - -! VARNM = 'MIN_FRAC_STRATO3' -! IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, MONTH_STRAT_03_FRAC ) ) THEN -! XMSG = 'Error writing variable ' // VARNM -! CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) -! END IF + VARNM = 'TROPO_O3_COLUMN' + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, TROPO_OC ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF VARNM = 'TRANS_DIFFUSE' @@ -1309,7 +1505,7 @@ END SUBROUTINE O3TOTCOL CALL M3EXIT ( PNAME, ODATE, OTIME, XMSG, XSTAT1 ) END IF - VARNM = 'TAU_AERO_W' // WLTXT( IWL ) + VARNM = 'AOD_W' // WLTXT( IWL ) IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, & OTIME, TAU_AERO_WL( :,:,IWL ) ) ) THEN XMSG = 'Error writing variable ' // VARNM @@ -1362,70 +1558,117 @@ END SUBROUTINE O3TOTCOL END DO ! iwl + VARNM = 'AOD_W550_ANGST' + IF ( .NOT. WRITE3( CTM_RJ_1, VARNM, ODATE, OTIME, TAU_AERO_550 ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + WRITE( LOGDEV, '( /5X, 3( A, :, 1X ), I8, ":", I6.6 )' ) - & 'RJ Values written to', CTM_RJ_1, + & 'Photolysis Surface Summary written to', CTM_RJ_1, & 'for date and time', ODATE, OTIME DO IPHOT = 1, NPHOTAB + OUTPUT_BUFF( 1:NCOLS,1:NROWS,1:NLAYS_DIAG ) = RJ( 1:NCOLS,1:NROWS,1:NLAYS_DIAG,IPHOT ) IF ( .NOT. WRITE3( CTM_RJ_2, PHOTAB( IPHOT ), ODATE, - & OTIME, RJ( :,:,:,IPHOT ) ) ) THEN + & OTIME, OUTPUT_BUFF ) ) THEN XMSG = 'Could not write ' // CTM_RJ_2 // ' file' CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF END DO + WRITE( LOGDEV, '( /5X, 3( A, :, 1X ), I8, ":", I6.6 )' ) + & 'Photolysis Rates written to', CTM_RJ_2, + & 'for date and time', ODATE, OTIME + VARNM = 'CFRAC_3D' - IF ( .NOT. WRITE3( CTM_RJ_2, VARNM, ODATE, OTIME, CFRAC_3D ) ) THEN - XMSG = 'Could not write ' // TRIM( VARNM ) // ' to ' // CTM_RJ_2 // ' file' + OUTPUT_BUFF( 1:NCOLS,1:NROWS,1:NLAYS_DIAG ) = CFRAC_3D( 1:NCOLS,1:NROWS,1:NLAYS_DIAG ) + IF ( .NOT. WRITE3( CTM_RJ_3, VARNM, ODATE, OTIME, OUTPUT_BUFF ) ) THEN + XMSG = 'Could not write ' // TRIM( VARNM ) // ' to ' // CTM_RJ_3 // ' file' CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF - - DO IWL = 1, NWL + + DO L = 1, N_DIAG_WVL + IWL = DIAG_WVL( L ) + VARNM = 'ACTINIC_FX_W' // WLTXT( IWL ) - IF ( .NOT. WRITE3( CTM_RJ_2, VARNM, ODATE, OTIME, ACTINIC_FX( :,:,:,IWL ) ) ) THEN + IF ( .NOT. WRITE3( CTM_RJ_3, VARNM, ODATE, OTIME, ACTINIC_FX( :,:,:,L ) ) ) THEN XMSG = 'Error writing variable ' // VARNM CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF - END DO - - DO L = 1, N_DIAG_WVL - IWL = DIAG_WVL( L ) VARNM = 'AERO_SSA_W' // WLTXT( IWL ) - IF ( .NOT. WRITE3( CTM_RJ_2, VARNM, ODATE, OTIME, AERO_SSA( :,:,:,L ) ) ) THEN + IF ( .NOT. WRITE3( CTM_RJ_3, VARNM, ODATE, OTIME, AERO_SSA( :,:,:,L ) ) ) THEN XMSG = 'Error writing variable ' // VARNM CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF VARNM = 'AERO_ASYM_W' // WLTXT( IWL ) - IF ( .NOT. WRITE3( CTM_RJ_2, VARNM, ODATE, OTIME, AERO_ASYM( :,:,:,L ) ) ) THEN + IF ( .NOT. WRITE3( CTM_RJ_3, VARNM, ODATE, OTIME, AERO_ASYM( :,:,:,L ) ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + + VARNM = 'EXT_AERO_W' // WLTXT( IWL ) + IF ( .NOT. WRITE3( CTM_RJ_3, VARNM, ODATE, OTIME, AERO_EXT( :,:,:,L ) ) ) THEN XMSG = 'Error writing variable ' // VARNM CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF - VARNM = 'TAU_AERO_W' // WLTXT( IWL ) - IF ( .NOT. WRITE3( CTM_RJ_2, VARNM, ODATE, OTIME, TAU_AERO( :,:,:,L ) ) ) THEN + VARNM = 'EXT_W' // WLTXT( IWL ) + IF ( .NOT. WRITE3( CTM_RJ_3, VARNM, ODATE, OTIME, TOT_EXT( :,:,:,L ) ) ) THEN XMSG = 'Error writing variable ' // VARNM CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF - VARNM = 'TAU_W' // WLTXT( IWL ) - IF ( .NOT. WRITE3( CTM_RJ_2, VARNM, ODATE, OTIME, TAU( :,:,:,L ) ) ) THEN + VARNM = 'GAS_EXT_W' // WLTXT( IWL ) + IF ( .NOT. WRITE3( CTM_RJ_3, VARNM, ODATE, OTIME, GAS_EXT( :,:,:,L ) ) ) THEN XMSG = 'Error writing variable ' // VARNM CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) END IF END DO + VARNM = 'EXT_AERO_W550' + IF ( .NOT. WRITE3( CTM_RJ_3, VARNM, ODATE, OTIME, AERO_EXT_550( :,:,: ) ) ) THEN + XMSG = 'Error writing variable ' // VARNM + CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + END IF + WRITE( LOGDEV, '( /5X, 3( A, :, 1X ), I8, ":", I6.6 )' ) - & 'RJ and Optical Data written to', CTM_RJ_2, + & 'Radiative and Optical Data written to', CTM_RJ_3, & 'for date and time', ODATE, OTIME - END IF ! if JTIME_CHK + END IF ! PHOTDIAG + END IF ! if JTIME_CHK + TAU_AERO_550 = 0.0 1003 FORMAT( 8X, 'Processor ',I4.4,' is in darkness at ', I8.7, ':', I6.6, & 1X, 'GMT - no photolysis') 9500 FORMAT(3(/ A), I7, 1X, I6.6, 1X, / "Total Number: ", I9, ";Mean Value: ", F9.6, & "; Max Value: ",F9.6 /) - RETURN +95101 FORMAT('Diagnostic Output will have zero values for the column density.', + & / 'The lack of information does not affect model predictions.' ) + + CONTAINS + SUBROUTINE COLUMN_GAS( IGAS, UNIT_FACTOR, COLUMN_DENSITY ) +! Purpose: calculates column density in unit based on the value of UNIT_FACTOR + IMPLICIT NONE +! argument: + INTEGER, INTENT( IN ) :: IGAS ! species index in CGRID + REAL, INTENT( OUT ) :: COLUMN_DENSITY( :,: ) ! units determined by inputs + REAL, INTENT( IN ) :: UNIT_FACTOR ! converts from 10E6*molecules*cm-2 +! local parameter: +! REAL, PARAMETER :: UNIT_FACTOR = 1.0E-6 * CONC_TO_DU ! unit conversion factor + + IF( IGAS .LE. 0 )RETURN ! assumes column_density set to zero at allocation + + COLUMN_DENSITY( COL,ROW ) = 0.0 + DO LEV = 1, NLAYS + COLUMN_DENSITY( COL,ROW ) = ( UNIT_FACTOR * BLKDENS( LEV ) ) + & * CGRID( COL,ROW,LEV,IGAS ) * BLKDZ ( LEV ) + & + COLUMN_DENSITY( COL,ROW ) + END DO + + END SUBROUTINE COLUMN_GAS END SUBROUTINE PHOT diff --git a/src/shr/aqm_methods.F90 b/src/shr/aqm_methods.F90 index a3c8787..7412e7d 100644 --- a/src/shr/aqm_methods.F90 +++ b/src/shr/aqm_methods.F90 @@ -86,6 +86,7 @@ LOGICAL FUNCTION DESC3( FNAME ) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: FNAME + CHARACTER(LEN=len(FNAME)) :: FNAME_TRIM !(Wei Li) INCLUDE SUBST_FILES_ID @@ -106,10 +107,9 @@ LOGICAL FUNCTION DESC3( FNAME ) STIME3D = 0 TSTEP3D = 0 - IF ( (TRIM(FNAME) .EQ. TRIM(INIT_GASC_1)) .OR. & - (TRIM(FNAME) .EQ. TRIM(INIT_AERO_1)) .OR. & - (TRIM(FNAME) .EQ. TRIM(INIT_NONR_1)) .OR. & - (TRIM(FNAME) .EQ. TRIM(INIT_TRAC_1)) ) THEN + FNAME_TRIM = TRIM(FNAME_TRIM) + !!Replace INIT_GASC,AERO,NONR,TRAC to INIT_CONC_1 (Wei Li) + IF ( (TRIM(FNAME) .EQ. TRIM(INIT_CONC_1)) ) THEN ! -- Input initial background values for the following species NVARS3D = 3 @@ -126,7 +126,9 @@ LOGICAL FUNCTION DESC3( FNAME ) call aqm_emis_desc("biogenic", NLAYS3D, NVARS3D, VNAME3D, UNITS3D) - ELSE IF ( TRIM( FNAME ) .EQ. TRIM( EMIS_1 ) ) THEN +! EMIS_1 is not used anymore. Change to other env variables. (Wei Li) + ELSE IF ( ( (FNAME_TRIM(1:8) .EQ. 'GR_EMIS_') .AND. (len(FNAME_TRIM) .EQ. 11 )) .OR. & + ( (FNAME_TRIM(1:9) .EQ. 'STK_EMIS_').AND. (len(FNAME_TRIM) .EQ. 12 )) ) THEN NLAYS3D = 0 @@ -364,14 +366,14 @@ logical function envyn(name, description, defaultval, status) envyn = .false. em => aqm_emis_get("biogenic") if (associated(em)) envyn = (trim(em % period) == "summer") - case ('CTM_AOD') - envyn = config % ctm_aod + ! case ('CTM_AOD') + ! envyn = config % ctm_aod case ('CTM_BIOGEMIS') envyn = aqm_emis_ispresent("biogenic") case ('CTM_DEPVFILE') envyn = config % ctm_depvfile - case ('CTM_PMDIAG') - envyn = config % ctm_pmdiag + ! case ('CTM_PMDIAG') + ! envyn = config % ctm_pmdiag case ('CTM_PHOTODIAG') envyn = config % ctm_photodiag case ('CTM_PT3DEMIS') @@ -619,6 +621,7 @@ logical function interpx( fname, vname, pname, & implicit none character(len=*), intent(in) :: fname, vname, pname + CHARACTER(LEN=len(fname)) :: FNAME_TRIM !(Wei Li) integer, intent(in) :: col0, col1, row0, row1, lay0, lay1 integer, intent(in) :: jdate, jtime real, intent(out) :: buffer(*) @@ -643,6 +646,7 @@ logical function interpx( fname, vname, pname, & ! -- begin interpx = .false. + FNAME_TRIM = TRIM(fname) !(Wei Li) lbuf = (col1-col0+1) * (row1-row0+1) * (lay1-lay0+1) buffer(1:lbuf) = 0. @@ -857,8 +861,8 @@ logical function interpx( fname, vname, pname, & return end select - else if (trim(fname) == trim(EMIS_1)) then - +! EMIS_1 is not used anymore. Change to other env variables. (Wei Li) + else if ( ( (FNAME_TRIM(1:8) .EQ. 'GR_EMIS_') .AND. (len(FNAME_TRIM) .EQ. 11 )) ) then ! -- read in emissions call aqm_emis_read("anthropogenic", vname, buffer, rc=localrc) if (aqm_rc_test((localrc /= 0), & @@ -1129,8 +1133,8 @@ LOGICAL FUNCTION XTRACT3 ( FNAME, VNAME, & end do END IF - - ELSE IF ( TRIM(FNAME) .EQ. TRIM(INIT_GASC_1) ) THEN + !!Replace INIT_GASC,AERO,NONR,TRAC to INIT_CONC_1 (Wei Li) + ELSE IF ( TRIM(FNAME) .EQ. TRIM(INIT_CONC_1) ) THEN ! -- initialize gas-phase species (ppmV) SELECT CASE (TRIM(VNAME)) @@ -1227,25 +1231,25 @@ LOGICAL FUNCTION WRITE3_REAL2D( FNAME, VNAME, JDATE, JTIME, BUFFER ) type(aqm_state_type), pointer :: stateOut WRITE3_REAL2D = .TRUE. - - IF ( TRIM( FNAME ) .EQ. TRIM( CTM_AOD_1 ) ) THEN - - WRITE3_REAL2D = .FALSE. - - IF ( TRIM( VNAME ) .EQ. TRIM( ALLVAR3 ) ) THEN - - nullify(stateOut) - call aqm_model_get(stateOut=stateOut, rc=localrc) - if (aqm_rc_check(localrc, msg="Failure to retrieve model output state", & - file=__FILE__, line=__LINE__)) return - - stateOut % aod = BUFFER - - END IF - - WRITE3_REAL2D = .TRUE. - - END IF +!CTM_AOD_1 seems to be removed. (Wei Li) +! IF ( TRIM( FNAME ) .EQ. TRIM( CTM_AOD_1 ) ) THEN +! +! WRITE3_REAL2D = .FALSE. +! +! IF ( TRIM( VNAME ) .EQ. TRIM( ALLVAR3 ) ) THEN +! +! nullify(stateOut) +! call aqm_model_get(stateOut=stateOut, rc=localrc) +! if (aqm_rc_check(localrc, msg="Failure to retrieve model output state", & +! file=__FILE__, line=__LINE__)) return +! +! stateOut % aod = BUFFER +! +! END IF +! +! WRITE3_REAL2D = .TRUE. +! +! END IF END FUNCTION WRITE3_REAL2D @@ -1273,29 +1277,29 @@ LOGICAL FUNCTION WRITE3_REAL4D( FNAME, VNAME, JDATE, JTIME, BUFFER ) integer, parameter :: p_pm25at = 23 WRITE3_REAL4D = .TRUE. - - IF ( TRIM( FNAME ) .EQ. TRIM( CTM_PMDIAG_1 ) ) THEN - - WRITE3_REAL4D = .FALSE. - - IF ( TRIM( VNAME ) .EQ. TRIM( ALLVAR3 ) ) THEN - - nullify(config) - nullify(stateOut) - call aqm_model_get(config=config, stateOut=stateOut, rc=localrc) - if (aqm_rc_check(localrc, msg="Failure to retrieve model output state", & - file=__FILE__, line=__LINE__)) return - - do s = 0, config % species % ndiag - 2 - stateOut % tr(:,:,:,config % species % p_diag_beg + s) = & - buffer(:,:,:,p_pm25at + s) - end do - - END IF - - WRITE3_REAL4D = .TRUE. - - END IF +!CTM_PMDIAG_1 seems to be removed. (Wei Li) +! IF ( TRIM( FNAME ) .EQ. TRIM( CTM_PMDIAG_1 ) ) THEN +! +! WRITE3_REAL4D = .FALSE. +! +! IF ( TRIM( VNAME ) .EQ. TRIM( ALLVAR3 ) ) THEN +! +! nullify(config) +! nullify(stateOut) +! call aqm_model_get(config=config, stateOut=stateOut, rc=localrc) +! if (aqm_rc_check(localrc, msg="Failure to retrieve model output state", & +! file=__FILE__, line=__LINE__)) return +! +! do s = 0, config % species % ndiag - 2 +! stateOut % tr(:,:,:,config % species % p_diag_beg + s) = & +! buffer(:,:,:,p_pm25at + s) +! end do +! +! END IF +! +! WRITE3_REAL4D = .TRUE. +! +! END IF END FUNCTION WRITE3_REAL4D From 157551869de004993877ca8afed46b2bde5fa5a9 Mon Sep 17 00:00:00 2001 From: Beiming Tang <51177339+btang1@users.noreply.github.com> Date: Wed, 26 Jul 2023 23:16:36 -0400 Subject: [PATCH 65/90] Add files via upload Beiming new DUST_EMIS for ufs-cmaq54 --- src/model/src/DUST_EMIS.F | 143 ++++++++++++++++++-------------------- 1 file changed, 68 insertions(+), 75 deletions(-) diff --git a/src/model/src/DUST_EMIS.F b/src/model/src/DUST_EMIS.F index 2ba5a5c..59605dd 100644 --- a/src/model/src/DUST_EMIS.F +++ b/src/model/src/DUST_EMIS.F @@ -17,7 +17,7 @@ ! subject to their copyright restrictions. ! !------------------------------------------------------------------------! -C::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: +!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: module dust_emis C----------------------------------------------------------------------- @@ -112,7 +112,7 @@ module dust_emis C Number of soil types: For WRF there are 16 types; integer, parameter :: nsltyp = 16 -C Variables for FENGSHA dust scheme (Wei Li) +C Variables for FENGSHA dust scheme (beiming tang) real, save :: dust_alpha ! tuning parameter for FENGSHA dust emission flux C Variables for the windblown dust diagnostic file: @@ -217,7 +217,7 @@ function dust_emis_init( jdate, jtime, tstep ) result( success ) success = .true. - CALL LOG_MESSAGE( LOGDEV, 'Initialize Wind-Blown Dust Emissions' ) + 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 @@ -260,9 +260,9 @@ function dust_emis_init( jdate, jtime, tstep ) result( success ) & 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 ) - success = .false.; return + xmsg='*** Failure allocating DUSTOUTM, DUSTOUTN, or DUSTOUTS' + call m3warn ( pname, jdate, jtime, xmsg ) + success = .false.; return end if C Allocate emissions array @@ -273,28 +273,26 @@ function dust_emis_init( jdate, jtime, tstep ) result( success ) success = .false.; return end if - !add fengsha scheme (Wei Li) - if ( fengsha ) then - + if ( fengsha ) then !(beiming tang) + C Disable diagnostic output if FENGSHA is used dustem_diag = .false. - -C Allocate private arrays ! not used for now (Wei Li) - !allocate( tfb( ncols,nrows ), stat = status ) - + +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 - + 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 !else fengsha is off & default is on + + else C Allocate private arrays allocate( wmax ( ncols,nrows ), @@ -450,7 +448,7 @@ function dust_emis_init( jdate, jtime, tstep ) result( success ) allocate( diagnm_swap( ndust_diag ), stat = status ) if ( status .ne. 0 ) then xmsg = '*** Failure allocating DIAGNM_SWAP' - call m3warn( pname, jdate, jtime, xmsg ) + call m3warn( pname, jdate, jtime, xmsg ) success = .false.; return end if diagnm_swap = diagnm @@ -471,8 +469,8 @@ function dust_emis_init( jdate, jtime, tstep ) result( success ) & call opdust_emis ( stdate, sttime, tstep, ndust_diag, diagnm ) end if ! dustem_diag - - end if ! end dust scheme (Wei Li) + + end if !dust scheme (beiming tang) l2sgj = log( sigj ) * log( sigj ) l2sgk = log( sigk ) * log( sigk ) @@ -569,7 +567,7 @@ subroutine opdust_emis ( jdate, jtime, tstep, ndust_var, dust_var ) end do fdesc3d( 1 ) = 'windblown dust parameters, variables, and' - fdesc3d( 2 ) = 'hourly layer-1 windblown dust emission rates' + fdesc3d( 2 ) ='hourly layer-1 windblown dust emission rates' do l = 3, mxdesc3 fdesc3d( l ) = ' ' end do @@ -636,9 +634,8 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt, real, parameter :: sigb_mb = sigb * mb ! = 0.5 real, parameter :: betab_mb = betab * mb ! = 45.0 - !(Wei Li) - character( 24 ) :: ctm_wbdust_fengsha_alpha = 'CTM_WBDUST_FENGSHA_ALPHA' ! env var to - ! retrieve FENGSHA scaling factor + character( 24 ) :: ctm_wbdust_fengsha_alpha = 'CTM_WBDUST_FENGSHA_ALPHA' ! env var to (beiming tang) + ! retrieve FENGSHA scaling factor character( 16 ) :: pname = 'GET_DUST_EMIS' character( 16 ) :: vname @@ -677,8 +674,8 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt, real :: lambdav ! vegetation roughness density - Shao et. al [Aus. J. Soil Res., 1996] real :: flxfac1, flxfac2 ! combined soli type mapping factors real :: hflux, vflux ! horizontal and vertical dust flux - real :: v2h ! vertical/horizontal dust flux ratio !(Wei Li) - real :: wm ! max adsorb water [%] !(Wei Li) + real :: v2h ! vertical/horizontal dust flux ratio (beiming tang) + real :: wm ! max adsorb water [%] real :: jday integer :: emap( n_dlcat+1 ) @@ -763,39 +760,35 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt, if ( firstime ) then firstime = .false. - !call dust_alpha from env variable (Wei Li) - if ( fengsha ) then - dust_alpha = 0.05 ! default + if ( fengsha ) then + dust_alpha = 0.05 ! default (beiming tang) dust_alpha = envreal( ctm_wbdust_fengsha_alpha, - & 'Emission global scaling factor for FENGSHA dust scheme', - & dust_alpha, status ) + & 'Emission global scaling factor for FENGSHA dust scheme', + & dust_alpha, status ) if ( status .ne. 0 ) then xmsg = '*** Failure retrieving FENGSHA scaling factor' call m3exit( pname, jdate, jtime, xmsg, xstat1 ) end if write(xmsg,'("Using FENGSHA alpha = ",g12.5)') dust_alpha - call m3msg2 ( xmsg ) !from AQM/src/io/ioapi/m3msg2.F90 - !if envreal is not found (from IOAPI app); try below from 'get_env_module' - !The ctm_wbdust_fengsha_alpha = 'CTM_WBDUST_FENGSHA_ALPHA' can be deleted - !call GET_ENV(dust_alpha, 'CTM_WBDUST_FENGSHA_ALPHA', dust_alpha, VARDEV) - else !else is default scheme - allocate ( ustr( ncols,nrows,n_dlcat+1 ), - & qam( ncols,nrows,n_dlcat+1 ), - & fruf( ncols,nrows,n_dlcat+1 ), - & kvh( ncols,nrows,n_dlcat+1 ), - & elus( ncols,nrows,n_dlcat+1 ), stat = status ) - 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 + 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 end if -C---Select dust scheme - if ( fengsha ) then +C---Select dust scheme (beiming tang) + if ( fengsha ) then - do r = 1, nrows - do c = 1, ncols + do r = 1, my_nrows + do c = 1, my_ncols dust_em( c,r ) = 0.0 soimt( c,r ) = 0.0 @@ -813,22 +806,22 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt, & * 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 @@ -838,20 +831,20 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt, & 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 - !tfb and tfa not used for now (Wei Li) - dust_em( c,r ) = dust_alpha * vflux * rlay1hgt !* tfa(c,r) * tfb(c,r) - - end if ! if rain & land & snow & drag - - end do ! c - end do ! r - - else ! default dust scheme - + + 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 ) ) @@ -1134,7 +1127,7 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt, & out of total cells:', & dryhit, (c-1)*(r-1) #endif - end if ! dust scheme (Wei Li) + end if !dust scheme (beiming tang) do r = 1, nrows do c = 1, ncols @@ -1380,15 +1373,14 @@ function dust_hflux( ndp, dp, soiltxt, fmoit, fruf, ustr, sd_ep, dens ) end function dust_hflux - ! add a new function for fengsha (Wei Li) - function dust_hflux_fengsha( ustar, fmoit, drag, uthr, ssm, dens ) + function dust_hflux_fengsha( ustar, fmoit, drag, uthr,ssm, dens ) !beiming tang & 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 @@ -1405,8 +1397,9 @@ function dust_hflux_fengsha( ustar, fmoit, drag, uthr, ssm, dens ) 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 From 91705eea22436f2fa12016a5d4e4412c6f538ce1 Mon Sep 17 00:00:00 2001 From: Beiming Tang <51177339+btang1@users.noreply.github.com> Date: Thu, 27 Jul 2023 21:18:03 -0400 Subject: [PATCH 66/90] Add files via upload --- src/model/src/RUNTIME_VARS.F | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/model/src/RUNTIME_VARS.F b/src/model/src/RUNTIME_VARS.F index 64e76e0..eee3d62 100644 --- a/src/model/src/RUNTIME_VARS.F +++ b/src/model/src/RUNTIME_VARS.F @@ -97,7 +97,7 @@ MODULE RUNTIME_VARS ! this is for MPAS LOGICAL :: ncd_64bit_offset = .FALSE. - INTEGER :: cell_num = 1 !(Wei Li; tested ) + INTEGER :: cell_num !beiming tang !----------------------------------------------------------------------------------- !>> Define Environment Variables for Controlling CMAQ Processes !----------------------------------------------------------------------------------- @@ -609,7 +609,7 @@ SUBROUTINE INIT_ENV_VARS( JDATE, JTIME ) 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 ) + CALL GET_ENV( 'NWAVE_PHOTDIAG', NWAVE, WAVE_ENV, VARDEV ) !this could be wrong, why char before NWAVE, beiming??? END IF ! Get flag to use core-shell mixing model for aerosol optical properties @@ -934,8 +934,8 @@ SUBROUTINE INIT_ENV_VARS( JDATE, JTIME ) ! for MPAS #ifdef mpas - call get_env (ncd_64bit_offset, 'ncd_64bit_offset', .false., vardev) - call get_env( cell_num, 'cell_num', 1, vardev) + call get_env(ncd_64bit_offset, 'ncd_64bit_offset', .false., vardev) + call get_env(cell_num, 'cell_num', 1, vardev) #endif #ifdef twoway From 6ee0c41290cd32a0618231bd14dd71b6e0a0b315 Mon Sep 17 00:00:00 2001 From: Beiming Tang <51177339+btang1@users.noreply.github.com> Date: Tue, 1 Aug 2023 00:11:45 -0400 Subject: [PATCH 67/90] Add files via upload --- src/model/src/DUST_EMIS.F | 19 +- src/model/src/centralized_io_module.F | 616 +++++++++++++------------- 2 files changed, 319 insertions(+), 316 deletions(-) diff --git a/src/model/src/DUST_EMIS.F b/src/model/src/DUST_EMIS.F index 59605dd..fe3352e 100644 --- a/src/model/src/DUST_EMIS.F +++ b/src/model/src/DUST_EMIS.F @@ -217,7 +217,7 @@ function dust_emis_init( jdate, jtime, tstep ) result( success ) success = .true. - CALL LOG_MESSAGE(LOGDEV, 'Initialize Wind-Blown Dust Emissions' ) + 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 @@ -260,9 +260,9 @@ function dust_emis_init( jdate, jtime, tstep ) result( success ) & 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 ) - success = .false.; return + xmsg = '*** Failure allocating DUSTOUTM, DUSTOUTN, or DUSTOUTS' + call m3warn ( pname, jdate, jtime, xmsg ) + success = .false.; return end if C Allocate emissions array @@ -448,7 +448,8 @@ function dust_emis_init( jdate, jtime, tstep ) result( success ) allocate( diagnm_swap( ndust_diag ), stat = status ) if ( status .ne. 0 ) then xmsg = '*** Failure allocating DIAGNM_SWAP' - call m3warn( pname, jdate, jtime, xmsg ) + call m3warn( pname, jdate, jtime, xmsg ) + success = .false.; return end if diagnm_swap = diagnm @@ -567,7 +568,7 @@ subroutine opdust_emis ( jdate, jtime, tstep, ndust_var, dust_var ) end do fdesc3d( 1 ) = 'windblown dust parameters, variables, and' - fdesc3d( 2 ) ='hourly layer-1 windblown dust emission rates' + fdesc3d( 2 ) = 'hourly layer-1 windblown dust emission rates' do l = 3, mxdesc3 fdesc3d( l ) = ' ' end do @@ -635,7 +636,7 @@ 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 (beiming tang) - ! retrieve FENGSHA scaling factor + ! retrieve FENGSHA scaling factor character( 16 ) :: pname = 'GET_DUST_EMIS' character( 16 ) :: vname @@ -787,8 +788,8 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt, C---Select dust scheme (beiming tang) 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 diff --git a/src/model/src/centralized_io_module.F b/src/model/src/centralized_io_module.F index e2f0ebd..145a050 100644 --- a/src/model/src/centralized_io_module.F +++ b/src/model/src/centralized_io_module.F @@ -112,8 +112,8 @@ MODULE CENTRALIZED_IO_MODULE use get_env_module USE UTILIO_DEFN #ifdef mpas -! use coupler_module !(Wei Li) -! use mio_module !(Wei Li) + ! use coupler_module (beiming tang) + ! use mio_module (beiming tang) #endif implicit none @@ -236,11 +236,11 @@ MODULE CENTRALIZED_IO_MODULE 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 +!! 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(:) @@ -356,18 +356,18 @@ MODULE CENTRALIZED_IO_MODULE CHARACTER( 16 ) :: LT_NAME ! LNT name: old Cis NLDNstrk and new is LNT interface interpolate_var -!#ifdef mpas +#ifdef mpas ! module procedure r_interpolate_var_1ds, ! & r_interpolate_var_2d, ! & i_interpolate_var_2d, ! & r_interpolate_var_3d -!#else +#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 +#endif end interface ! MPAS only routines: @@ -428,12 +428,12 @@ subroutine gridded_files_setup & local_tstep, met_tstep, NLDNSTRIKE use LSM_Mod, only : LAND_SCHEME use cgrid_spcs, only : n_gc_spcd, n_ae_spc -!#ifdef mpas (Wei Li) +#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 +#endif INCLUDE SUBST_FILES_ID ! file name parameters @@ -462,17 +462,17 @@ subroutine gridded_files_setup ! 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 @@ -819,18 +819,18 @@ subroutine gridded_files_setup #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 @@ -842,7 +842,7 @@ subroutine gridded_files_setup ! & 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), @@ -855,14 +855,14 @@ subroutine gridded_files_setup ! 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 @@ -912,7 +912,7 @@ subroutine gridded_files_setup #ifdef mpas ! deallocate (bottom, top) -! + ! n_dust_vars = 0 #else @@ -929,7 +929,7 @@ subroutine gridded_files_setup end if #ifndef mpas -! setup initial condition file +!! setup initial condition file ! n_i3d = 0 ! IF ( .NOT. OPEN3( ICFILE, FSREAD3, PNAME ) ) THEN ! XMSG = 'Open failure for ' // ICFILE @@ -943,8 +943,8 @@ subroutine gridded_files_setup ! END IF ! call subhfile ( ICFILE, gxoff, gyoff, ! & STRTCOLIC, ENDCOLIC, STRTROWIC, ENDROWIC ) -! -!! remove duplicate name from MET_CRO_3D file + +! remove duplicate name from MET_CRO_3D file ! adj = nvars3d ! do v = nvars3d, 1, -1 ! n = index1 (vname3d(v), n_c3d, c3d_name) @@ -956,7 +956,7 @@ subroutine gridded_files_setup ! 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 ' @@ -965,8 +965,8 @@ subroutine gridded_files_setup ! 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 + +! setup initial condition file for ISAM ! n_is3d = 0 ! ! if (ISAM_NEW_START == 'N') then @@ -992,13 +992,13 @@ subroutine gridded_files_setup ! 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 @@ -1026,7 +1026,7 @@ subroutine gridded_files_setup ! 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 @@ -1077,7 +1077,7 @@ subroutine gridded_files_setup ! 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) @@ -1095,7 +1095,7 @@ subroutine gridded_files_setup ! else ! lt_name = 'LNT' ! end if -! + ! end if #endif @@ -1107,7 +1107,7 @@ subroutine gridded_files_setup ! cro_nrows = 1 ! size_c2dx = 1 -!! for standard domain +! for standard domain ! s_cro_ncols = ncols ! s_cro_nrows = 1 #else @@ -1196,20 +1196,20 @@ subroutine gridded_files_setup ! 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) @@ -1273,11 +1273,11 @@ subroutine retrieve_time_dep_gridded_data (jdate, jtime, vname) USE VGRD_DEFN, ONLY : NLAYS USE CGRID_SPCS use get_env_module -#ifdef mpas !(Wei Li) +#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 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 @@ -1319,16 +1319,16 @@ subroutine retrieve_time_dep_gridded_data (jdate, jtime, vname) #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', ' ') @@ -1388,7 +1388,7 @@ subroutine retrieve_time_dep_gridded_data (jdate, jtime, vname) #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, @@ -1492,7 +1492,7 @@ subroutine retrieve_time_dep_gridded_data (jdate, jtime, vname) ! 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 +! end do ! else ! do i = 1, ncols ! do k = 1, num_dist_layers(i,fnum) @@ -1500,11 +1500,11 @@ subroutine retrieve_time_dep_gridded_data (jdate, jtime, vname) ! end do ! end do ! end if -! -!! do i = 1, ncols -!! mpas_tdata(i,:) = mpas_tdata(i,:) * cell_area(i,1) -!! end do -! + +! 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 @@ -1512,7 +1512,9 @@ subroutine retrieve_time_dep_gridded_data (jdate, jtime, vname) ! 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)) + if (file_sym_date(f_emis(fnum))) then + loc_jdate(f_emis(fnum)) = file_sdate(f_emis(fnum)) + end if end if data_jdate = loc_jdate(f_emis(fnum)) data_jtime = loc_jtime(f_emis(fnum)) @@ -1540,9 +1542,9 @@ subroutine retrieve_time_dep_gridded_data (jdate, jtime, vname) ! & 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 @@ -1550,18 +1552,18 @@ subroutine retrieve_time_dep_gridded_data (jdate, jtime, vname) ! 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 @@ -1569,7 +1571,7 @@ subroutine retrieve_time_dep_gridded_data (jdate, jtime, vname) ! 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 @@ -1603,9 +1605,9 @@ subroutine retrieve_time_dep_gridded_data (jdate, jtime, vname) #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 @@ -1620,9 +1622,9 @@ subroutine retrieve_time_dep_gridded_data (jdate, jtime, vname) #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 @@ -1637,7 +1639,7 @@ subroutine retrieve_time_dep_gridded_data (jdate, jtime, vname) #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 @@ -1661,7 +1663,7 @@ subroutine retrieve_time_dep_gridded_data (jdate, jtime, vname) ! 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) ) @@ -1740,24 +1742,24 @@ end subroutine retrieve_lufrac_cro_data #ifdef mpas ! ------------------------------------------------------------------------- ! subroutine stack_files_setup_mpas -! -!! USE UTILIO_DEFN + +! USE UTILIO_DEFN ! use stk_prms ! use stack_group_data_module ! use get_env_module ! use hgrd_defn, only : ncols, mype ! use vgrd_defn, only : nlays -! !use coupler_module, only : pres_ind, g3ddata !(Wei Li) + ! use coupler_module, only : pres_ind, g3ddata (beiming tang) ! use centralized_io_util_module, only : quicksort -! !use util_module, only : index1 !(Wei Li) +! use util_module, only : index1 ! use RUNTIME_VARS, only : emis_sym_date -! -! !use mydata_module !(Wei Li) -! + +! 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, @@ -1767,10 +1769,10 @@ end subroutine retrieve_lufrac_cro_data ! & 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), @@ -1795,7 +1797,7 @@ end subroutine retrieve_lufrac_cro_data ! 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') @@ -1815,150 +1817,150 @@ end subroutine retrieve_lufrac_cro_data ! 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 @@ -1966,9 +1968,9 @@ end subroutine retrieve_lufrac_cro_data ! 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), @@ -1981,32 +1983,32 @@ end subroutine retrieve_lufrac_cro_data ! 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 +! 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 @@ -2018,27 +2020,27 @@ end subroutine retrieve_lufrac_cro_data ! 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 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, @@ -2046,26 +2048,26 @@ end subroutine retrieve_lufrac_cro_data ! 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 @@ -2075,11 +2077,11 @@ end subroutine retrieve_lufrac_cro_data ! 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 @@ -2088,48 +2090,48 @@ end subroutine retrieve_lufrac_cro_data ! 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 -! + +! 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 @@ -2142,30 +2144,30 @@ end subroutine retrieve_lufrac_cro_data ! 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 @@ -2173,12 +2175,12 @@ end subroutine retrieve_lufrac_cro_data ! & '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), @@ -2193,9 +2195,9 @@ end subroutine retrieve_lufrac_cro_data ! end if ! end if ! end if -! + ! end subroutine retrieve_ocean_data_mpas -! + #else ! ------------------------------------------------------------------------- @@ -4091,17 +4093,17 @@ subroutine lus_setup ! 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 +! determine land_scheme from GRID_CRO_2D #ifdef twoway @@ -4151,11 +4153,11 @@ subroutine lus_setup end select #else -#ifdef mpas +!#ifdef mpas ! dust_land_scheme = mminlu_mpas -#else +!#else dust_land_scheme = cio_dust_land_scheme ! land scheme found from grid_cro_2D 'DLUSE' var-desc -#endif +!#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 @@ -4270,14 +4272,14 @@ subroutine lus_setup if ( .not. lucro_avail ) then ! TRUE if LUFRAC file isn't there or the land scheme is beld -#ifdef mpas +!#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 +!#else ! Get desert land (fraction) data (assume if BELD, all desert types are in file 1) do i = 1, n_dlcat #ifdef twoway @@ -4296,7 +4298,7 @@ subroutine lus_setup & // ' from ' // trim( lufile( 1 ) ) call m3exit( pname, cio_model_sdate, cio_model_stime, xmsg, xstat1 ) end if -#endif +!#endif end do ! Get land use (fraction) data @@ -4693,7 +4695,7 @@ end subroutine megan_setup subroutine centralized_io_init (in_ncols) use lsm_mod, only: n_lufrac, init_lsm - USE UTILIO_DEFN ! (Wei Li) , only : m3exit + USE UTILIO_DEFN !, only : M3EXIT (this is interesting,beiming) USE RUNTIME_VARS, only: log_heading, logdev #ifdef mpas @@ -4725,20 +4727,20 @@ subroutine centralized_io_init (in_ncols) ! call gridded_files_setup ! ! call retrieve_lufrac_cro_data -! + ! if (wb_dust) then ! call lus_setup ! end if -! -!! cio_logdev = 6 -! + +! 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), @@ -4746,26 +4748,26 @@ subroutine centralized_io_init (in_ncols) ! & 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() @@ -4857,13 +4859,13 @@ subroutine centralized_io_init (in_ncols) call retrieve_time_dep_gridded_data (cio_model_sdate, cio_model_stime) -#ifdef mpas +!#ifdef mpas ! call retrieve_stack_data_mpas (cio_model_sdate, cio_model_stime) -#else +!#else call retrieve_boundary_data (cio_model_sdate, cio_model_stime) call retrieve_stack_data (cio_model_sdate, cio_model_stime) -#endif +!#endif end subroutine centralized_io_init @@ -4881,10 +4883,10 @@ SUBROUTINE DESID_INIT_REGIONS( ) USE UTILIO_DEFN USE desid_param_module USE UTIL_FAMILY_MODULE -#ifdef mpas +!#ifdef mpas ! USE util_module, only : index1, upcase -#endif +!#endif #ifdef parallel USE SE_MODULES ! stenex (using SE_UTIL_MODULE,SE_DATA_COPY_MODULE) @@ -4963,12 +4965,12 @@ SUBROUTINE DESID_INIT_REGIONS( ) DO IFILE = 1,NFILE IF ( FILENAMES( IFILE ) .EQ. 'N/A' ) CYCLE -#ifdef mpas +!#ifdef mpas ! floc = search_fname (filenames( ifile )) ! ldate = 0 ! ltime = 0 -#else +!#else ! Get domain decomp info from the emissions file CALL SUBHFILE ( FILENAMES( IFILE ), GXOFF, GYOFF, & STARTCOL, ENDCOL, STARTROW, ENDROW ) @@ -4986,7 +4988,7 @@ SUBROUTINE DESID_INIT_REGIONS( ) CALL M3EXIT( PNAME, STDATE, STTIME, XMSG, XSTAT1 ) END IF -#endif +!#endif ! Read data from regions file into region array DO IREAD = 1,N_REG_RULE @@ -5001,7 +5003,7 @@ SUBROUTINE DESID_INIT_REGIONS( ) CALL M3EXIT( PNAME, STDATE, STTIME, XMSG, XSTAT1 ) ELSE !#ifdef mpas -! DO IVAR = 1, cio_emis_nvars(ifile) +! DO IVAR = 1, cio_emis_nvars(ifile) ! lvname = mio_file_data(floc)%var_name(ivar) !#else DO IVAR = 1,NVARS3D @@ -5062,13 +5064,13 @@ SUBROUTINE DESID_INIT_REGIONS( ) END IF END DO -#ifndef mpas +!#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 +!#endif ! Error Check the Regions Array ! Any Negatives? @@ -5206,9 +5208,9 @@ SUBROUTINE DESID_READ_NAMELIST( ) 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 +!#ifdef mpas ! use util_module, only : junit, upcase -#endif +!#endif IMPLICIT NONE @@ -5726,45 +5728,45 @@ SUBROUTINE DESID_READ_NAMELIST( ) END SUBROUTINE DESID_READ_NAMELIST -!#ifdef mpas -! ------------------------------------------------------------------------- +#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, @@ -5776,11 +5778,11 @@ END SUBROUTINE DESID_READ_NAMELIST ! 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 ', @@ -5788,18 +5790,18 @@ END SUBROUTINE DESID_READ_NAMELIST ! 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(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 ) @@ -5807,19 +5809,19 @@ END SUBROUTINE DESID_READ_NAMELIST ! 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)) @@ -5832,16 +5834,16 @@ END SUBROUTINE DESID_READ_NAMELIST ! 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 ', @@ -5853,122 +5855,122 @@ END SUBROUTINE DESID_READ_NAMELIST ! 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, @@ -5981,38 +5983,38 @@ END SUBROUTINE DESID_READ_NAMELIST ! 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) @@ -6023,27 +6025,27 @@ END SUBROUTINE DESID_READ_NAMELIST ! 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 @@ -6060,26 +6062,26 @@ END SUBROUTINE DESID_READ_NAMELIST ! 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 @@ -6090,13 +6092,13 @@ END SUBROUTINE DESID_READ_NAMELIST ! end do ! end do ! end do -! + ! end if ! end if -! + ! end subroutine r_interpolate_var_3d -! -!#else + +#else ! ------------------------------------------------------------------------- subroutine r_interpolate_var_1ds (fname, vname, date, time, data) @@ -6982,6 +6984,6 @@ subroutine r_interpolate_var_3d (vname, date, time, data, fname) end if end subroutine r_interpolate_var_3d -!#endif !ifdefine mpas for the few functions in the interface (Wei Li) +#endif END MODULE CENTRALIZED_IO_MODULE From 5085bc6d51d46c334fca45f49c788ae9b90490d9 Mon Sep 17 00:00:00 2001 From: Beiming Tang <51177339+btang1@users.noreply.github.com> Date: Tue, 1 Aug 2023 00:12:43 -0400 Subject: [PATCH 68/90] Update centralized_io_module.F --- src/model/src/centralized_io_module.F | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/model/src/centralized_io_module.F b/src/model/src/centralized_io_module.F index 145a050..0513977 100644 --- a/src/model/src/centralized_io_module.F +++ b/src/model/src/centralized_io_module.F @@ -112,8 +112,8 @@ MODULE CENTRALIZED_IO_MODULE use get_env_module USE UTILIO_DEFN #ifdef mpas - ! use coupler_module (beiming tang) - ! use mio_module (beiming tang) + ! use coupler_module + ! use mio_module #endif implicit none From 77a9805562819055f5b653b2943fb163d33f24aa Mon Sep 17 00:00:00 2001 From: Beiming Tang <51177339+btang1@users.noreply.github.com> Date: Sat, 5 Aug 2023 00:25:40 -0400 Subject: [PATCH 69/90] Add files via upload un-commented all MAPS lines, and changed CMakeList.txt --- src/model/src/centralized_io_module.F | 2392 ++++++++++++------------- 1 file changed, 1195 insertions(+), 1197 deletions(-) diff --git a/src/model/src/centralized_io_module.F b/src/model/src/centralized_io_module.F index 0513977..6121fbc 100644 --- a/src/model/src/centralized_io_module.F +++ b/src/model/src/centralized_io_module.F @@ -112,8 +112,8 @@ MODULE CENTRALIZED_IO_MODULE use get_env_module USE UTILIO_DEFN #ifdef mpas - ! use coupler_module - ! use mio_module + use coupler_module + use mio_module #endif implicit none @@ -236,11 +236,11 @@ MODULE CENTRALIZED_IO_MODULE 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 +! 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(:) @@ -314,7 +314,7 @@ MODULE CENTRALIZED_IO_MODULE private :: gridded_files_setup, & retrieve_lufrac_cro_data #ifdef mpas -! & ,retrieve_ocean_data_mpas + & ,retrieve_ocean_data_mpas #else & ,boundary_files_setup, & retrieve_grid_cro_2d_data, @@ -357,10 +357,10 @@ MODULE CENTRALIZED_IO_MODULE interface interpolate_var #ifdef mpas -! module procedure r_interpolate_var_1ds, -! & r_interpolate_var_2d, -! & i_interpolate_var_2d, -! & r_interpolate_var_3d + 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 @@ -429,10 +429,10 @@ subroutine gridded_files_setup 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 + 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 @@ -458,22 +458,22 @@ subroutine gridded_files_setup 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. + 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 @@ -783,20 +783,20 @@ subroutine gridded_files_setup & 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), + & 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) + 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 @@ -817,53 +817,53 @@ subroutine gridded_files_setup 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) + 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' @@ -911,9 +911,9 @@ subroutine gridded_files_setup end do #ifdef mpas -! deallocate (bottom, top) + deallocate (bottom, top) -! n_dust_vars = 0 + n_dust_vars = 0 #else ! Wind blown dust data @@ -929,77 +929,77 @@ subroutine gridded_files_setup 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 ) +! 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 + 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 + 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 @@ -1008,8 +1008,8 @@ subroutine gridded_files_setup 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 + 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 @@ -1022,11 +1022,11 @@ subroutine gridded_files_setup 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 -! + 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 @@ -1058,58 +1058,58 @@ subroutine gridded_files_setup ! 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 + 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 + cro_ncols = ncols + cro_nrows = 1 + size_c2dx = 1 ! for standard domain -! s_cro_ncols = ncols -! s_cro_nrows = 1 + s_cro_ncols = ncols + s_cro_nrows = 1 #else cro_ncols = ENDCOLMC2 - STRTCOLMC2 + 1 cro_nrows = ENDROWMC2 - STRTROWMC2 + 1 @@ -1170,9 +1170,9 @@ subroutine gridded_files_setup cio_grid_data = 0.0 #ifdef mpas -! end = 0 -! allocate (cio_mpas_grid_data_tstamp(0:2, n_cio_grid_vars), -! & stat = stat) + end = 0 + allocate (cio_mpas_grid_data_tstamp(0:2, n_cio_grid_vars), + & stat = stat) #else begin = 1 @@ -1193,30 +1193,30 @@ subroutine gridded_files_setup 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 + 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) @@ -1274,11 +1274,11 @@ subroutine retrieve_time_dep_gridded_data (jdate, jtime, vname) 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 + 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 @@ -1306,11 +1306,11 @@ subroutine retrieve_time_dep_gridded_data (jdate, jtime, vname) 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 + 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) @@ -1318,19 +1318,19 @@ subroutine retrieve_time_dep_gridded_data (jdate, jtime, vname) if (firstime) then #ifdef mpas -! allocate (mpas_loc_time_stamp(n_opened_file), STAT=STAT) + 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 + 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 + pre_jdate = -1 + pre_jtime = -1 -! call get_env (exception1, 'exception1', ' ') -! call get_env (exception2, 'exception2', ' ') + call get_env (exception1, 'exception1', ' ') + call get_env (exception2, 'exception2', ' ') #else allocate (SOILCAT_A(ncols, nrows), STAT=STAT) @@ -1386,10 +1386,10 @@ subroutine retrieve_time_dep_gridded_data (jdate, jtime, vname) if (cio_grid_var_name(v,2) == 'mc2') then #ifndef mpas -! data_jdate = loc_jdate(f_met) -! data_jtime = loc_jtime(f_met) + 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 + 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, @@ -1469,52 +1469,50 @@ subroutine retrieve_time_dep_gridded_data (jdate, jtime, vname) 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 + 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 /)) + 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))) then - loc_jdate(f_emis(fnum)) = file_sdate(f_emis(fnum)) - end if + 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)) @@ -1535,50 +1533,50 @@ subroutine retrieve_time_dep_gridded_data (jdate, jtime, vname) 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 + 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 @@ -1603,49 +1601,49 @@ subroutine retrieve_time_dep_gridded_data (jdate, jtime, vname) else if (cio_grid_var_name(v,2) == 'ic') then #ifndef mpas -! data_jdate = loc_jdate(f_icon) -! data_jtime = loc_jtime(f_icon) + data_jdate = loc_jdate(f_icon) + data_jtime = loc_jtime(f_icon) -! if (iter == 1) then + 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 + 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) + data_jdate = loc_jdate(f_is_icon) + data_jtime = loc_jtime(f_is_icon) -! if ((iter == 1) .and. (ISAM_NEW_START == 'N')) then + 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 + 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 + 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 @@ -1655,20 +1653,20 @@ subroutine retrieve_time_dep_gridded_data (jdate, jtime, vname) end do #ifndef mpas -!! assign TEMPG to TSEASFC when TSEASFC is not available in the input file -! if (.not. TSEASFC_AVAIL) then -! begin = cio_grid_data_inx(1,buf_loc,tempg_loc) -! end = cio_grid_data_inx(2,buf_loc,tempg_loc) -! i = cio_grid_data_inx(1,buf_loc,tseasfc_loc) -! j = cio_grid_data_inx(2,buf_loc,tseasfc_loc) -! cio_grid_data(i:j) = cio_grid_data(begin:end) -! end if - -! CALL NEXTIME ( loc_jdate(f_met), loc_jtime(f_met), file_tstep(f_met) ) -! if (NLDNSTRIKE) then -! CALL NEXTIME ( loc_jdate(f_ltng), loc_jtime(f_ltng), file_tstep(f_ltng) ) -! end if -! CALL NEXTIME ( loc_jdate(f_bcon), loc_jtime(f_bcon), file_tstep(f_bcon) ) +! 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 @@ -1689,8 +1687,8 @@ subroutine retrieve_time_dep_gridded_data (jdate, jtime, vname) end if #ifdef mpas -! pre_jdate = jdate -! pre_jtime = jtime + pre_jdate = jdate + pre_jtime = jtime #endif deallocate (loc_jdate, loc_jtime) @@ -1720,11 +1718,11 @@ subroutine retrieve_lufrac_cro_data 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 + 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 ) @@ -1741,462 +1739,462 @@ end subroutine retrieve_lufrac_cro_data #ifdef mpas ! ------------------------------------------------------------------------- -! subroutine stack_files_setup_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 (beiming tang) -! 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) + 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 -! 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 + 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) -! call mio_fread (stkgname(n), 'STKHT', tdata_1dr) + 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 v = 1, my_nsrc(n) -! stkht( n )%arry(v) = tdata_1dr(my_nsrc_index(v, n)) -! end do + if ( .not. stk_prms_init( stkgname ) ) then + write (cio_logdev, *) 'Could not initialize stack parameters' + stop + end if -! call mio_fread (stkgname(n), 'STKTK', tdata_1dr) + do n = 1, nptgrps -! do v = 1, my_nsrc(n) -! stktk( n )%arry(v) = tdata_1dr(my_nsrc_index(v, n)) -! end do + floc = search_fname(stkgname(n)) -! call mio_fread (stkgname(n), 'STKVE', tdata_1dr) +! 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) -! do v = 1, my_nsrc(n) -! stkvel( n )%arry(v) = tdata_1dr(my_nsrc_index(v, n)) -! end do + nsrc( n ) = mio_file_data(floc)%dim_len(5) -! if ( fire_on( n ) ) then -! call mio_fread (stkgname(n), 'ACRESBURNED', tdata_1dr) + 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) -! do v = 1, my_nsrc(n) -! acres_burned( n )%arry(v) = tdata_1dr(my_nsrc_index(v, n)) -! end do + 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 -! end if +! read in stack group data -! deallocate (tdata_1dr) -! end if + do n = 1, nptgrps -! end do + allocate (tdata_1di(nsrc(n)), stat = stat) -!! process stack emission files -! max_nvars = 0 -! d_size = 0 -! do pt = 1, nptgrps + call mio_fread (stkgname(n), 'ROW', tdata_1di) -! write( cio_stack_file_name(pt), '( "STK_EMIS_",I3.3 )' ) pt + my_nsrc(n) = 0 + do v = 1, nsrc(n) + pt = index1 (tdata_1di(v), my_num_mesh_points, my_mpas_map_index) -! floc = search_fname(cio_stack_file_name(pt)) -! cio_stack_file_loc(pt) = floc + 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 -! 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 ) + deallocate (tdata_1di) -! cio_mpas_stack_emis_timestamp(pt) = mio_file_data(floc)%timestamp(1) + end do -! if (max_nvars .lt. mio_file_data(floc)%nvars) then -! max_nvars = mio_file_data(floc)%nvars -! end if + my_strt_src = 0 + do n = 1, nptgrps -! 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 + if ( my_nsrc( n ) .gt. 0 ) then -! end do + my_strt_src(n) = 1 + my_end_src(n) = my_nsrc(n) -! 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 + stkdiam(n)%len = my_nsrc(n) + stkht(n)%len = my_nsrc(n) + stktk(n)%len = my_nsrc(n) + stkvel(n)%len = my_nsrc(n) -! begin = 1 -! cio_stack_emis_data_inx = -1 -! do pt = 1, nptgrps + 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 ) -! floc = cio_stack_file_loc(pt) + if ( fire_on(n) ) then + acres_burned(n)%len = my_nsrc(n) + allocate (acres_burned(n)%arry(my_nsrc(n)), + & stat=stat ) + end if -! n_opened_file = n_opened_file + 1 -! f_stk_emis(pt) = n_opened_file + call mio_fread (stkgname(n), 'STKDM', tdata_1dr) -!! 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) + 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 -! 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 + call mio_fread (stkgname(n), 'STKHT', tdata_1dr) -! t_nvars = mio_file_data(floc)%nvars + do v = 1, my_nsrc(n) + stkht( n )%arry(v) = tdata_1dr(my_nsrc_index(v, n)) + end do -! cio_stack_var_name(1:t_nvars, pt) = mio_file_data(floc)%var_name(1:t_nvars) + call mio_fread (stkgname(n), 'STKTK', tdata_1dr) -! call quicksort(cio_stack_var_name(1:t_nvars,pt), 1, t_nvars) + do v = 1, my_nsrc(n) + stktk( n )%arry(v) = tdata_1dr(my_nsrc_index(v, n)) + end do -! 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 + 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 -! deallocate (d_size) + 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 -! end subroutine stack_files_setup_mpas + 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) + 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 + 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 + include SUBST_FILES_ID ! file name parameters -! integer, intent(in) :: jdate, jtime -! character (*), intent(in), optional :: fname, vname + integer, intent(in) :: jdate, jtime + character (*), intent(in), optional :: fname, vname -! character( 40 ), parameter :: pname = 'retrieve_stack_data_mpas' + 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(:) + 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 = ' ' + character( 120 ) :: xmsg = ' ' -! if (firstime) then + if (firstime) then -! allocate (mpas_stack_loc_time_stamp(nptgrps), stat=stat) + 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 + 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 + head_stack_emis = -1 + tail_stack_emis = -1 -! iterations = 2 -! else -! iterations = 1 -! end if + 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 + 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 + do gp = beg_gp, end_gp -! allocate (tdata_1dr(nsrc(gp)), stat = stat) + 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 (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 + 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 + do iter = 1, iterations -! call julian_to_mpas_date_time (loc_jdate, loc_jtime, mpas_time_stamp) + 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) + 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 + 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) + 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 + 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) + 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 + 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)) ) + call nextime ( loc_jdate, loc_jtime, file_tstep(f_stk_emis(gp)) ) -! end do ! end iter + end do ! end iter -! deallocate (tdata_1dr) + deallocate (tdata_1dr) -! end do + 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 + 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 + 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 + 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 @@ -4086,24 +4084,24 @@ subroutine lus_setup 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 ) + 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 + end if #endif -! determine land_scheme from GRID_CRO_2D + ! determine land_scheme from GRID_CRO_2D #ifdef twoway @@ -4153,11 +4151,11 @@ subroutine lus_setup end select #else -!#ifdef mpas -! dust_land_scheme = mminlu_mpas -!#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 #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 @@ -4272,14 +4270,14 @@ subroutine lus_setup 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 +#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 + lut = lufrac ! landuse category fraction is lufrac that is already been extracted -!#else +#else ! Get desert land (fraction) data (assume if BELD, all desert types are in file 1) do i = 1, n_dlcat #ifdef twoway @@ -4298,7 +4296,7 @@ subroutine lus_setup & // ' from ' // trim( lufile( 1 ) ) call m3exit( pname, cio_model_sdate, cio_model_stime, xmsg, xstat1 ) end if -!#endif +#endif end do ! Get land use (fraction) data @@ -4695,13 +4693,13 @@ end subroutine megan_setup subroutine centralized_io_init (in_ncols) use lsm_mod, only: n_lufrac, init_lsm - USE UTILIO_DEFN !, only : M3EXIT (this is interesting,beiming) + USE UTILIO_DEFN !, only : m3exit !beiming tang 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 + 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 @@ -4724,49 +4722,49 @@ subroutine centralized_io_init (in_ncols) call log_heading( logdev, 'Opening CMAQ Input Files' ) #ifdef mpas -! call gridded_files_setup -! -! call retrieve_lufrac_cro_data + call gridded_files_setup -! if (wb_dust) then -! call lus_setup -! end if + 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 + 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) + 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) + lon = g2ddata(:,:,lon_ind) + lat = g2ddata(:,:,lat_ind) + ht = g2ddata(:,:,ht_ind) + lwmask = g2ddata(:,:,lwmask_ind) -! call retrieve_ocean_data_mpas + 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 + 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 + cio_model_sdate = stdate + cio_model_stime = sttime -! call stack_files_setup_mpas + call stack_files_setup_mpas #else cio_logdev = init3() @@ -4859,13 +4857,13 @@ subroutine centralized_io_init (in_ncols) 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 +#ifdef mpas + call retrieve_stack_data_mpas (cio_model_sdate, cio_model_stime) +#else call retrieve_boundary_data (cio_model_sdate, cio_model_stime) call retrieve_stack_data (cio_model_sdate, cio_model_stime) -!#endif +#endif end subroutine centralized_io_init @@ -4883,10 +4881,10 @@ SUBROUTINE DESID_INIT_REGIONS( ) USE UTILIO_DEFN USE desid_param_module USE UTIL_FAMILY_MODULE -!#ifdef mpas -! USE util_module, only : index1, upcase +#ifdef mpas + USE util_module, only : index1, upcase -!#endif +#endif #ifdef parallel USE SE_MODULES ! stenex (using SE_UTIL_MODULE,SE_DATA_COPY_MODULE) @@ -4965,12 +4963,12 @@ SUBROUTINE DESID_INIT_REGIONS( ) DO IFILE = 1,NFILE IF ( FILENAMES( IFILE ) .EQ. 'N/A' ) CYCLE -!#ifdef mpas -! floc = search_fname (filenames( ifile )) +#ifdef mpas + floc = search_fname (filenames( ifile )) -! ldate = 0 -! ltime = 0 -!#else + ldate = 0 + ltime = 0 +#else ! Get domain decomp info from the emissions file CALL SUBHFILE ( FILENAMES( IFILE ), GXOFF, GYOFF, & STARTCOL, ENDCOL, STARTROW, ENDROW ) @@ -4988,7 +4986,7 @@ SUBROUTINE DESID_INIT_REGIONS( ) CALL M3EXIT( PNAME, STDATE, STTIME, XMSG, XSTAT1 ) END IF -!#endif +#endif ! Read data from regions file into region array DO IREAD = 1,N_REG_RULE @@ -5002,13 +5000,13 @@ SUBROUTINE DESID_INIT_REGIONS( ) & '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 +#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 +#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 '// @@ -5022,7 +5020,7 @@ SUBROUTINE DESID_INIT_REGIONS( ) 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)) + 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, @@ -5049,7 +5047,7 @@ SUBROUTINE DESID_INIT_REGIONS( ) VNAME = DESID_REG_READ( IREAD )%VAR #ifdef mpas -! call mio_fread (FILENAMES(IFILE), VNAME, DESID_REG_FAC(:,1,DESID_N_REG)) + 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, @@ -5064,13 +5062,13 @@ SUBROUTINE DESID_INIT_REGIONS( ) 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 +#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? @@ -5208,9 +5206,9 @@ SUBROUTINE DESID_READ_NAMELIST( ) 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 +#ifdef mpas + use util_module, only : junit, upcase +#endif IMPLICIT NONE @@ -5729,374 +5727,374 @@ SUBROUTINE DESID_READ_NAMELIST( ) 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. +! ------------------------------------------------------------------------- + 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) + & ((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) + 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)'), + & '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 + 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) + 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) + data(1:dsize) = cio_stack_data(store_beg_ind:store_beg_ind+dsize-1) -! end if + end if -! end subroutine r_interpolate_var_1ds + end subroutine r_interpolate_var_1ds ! ------------------------------------------------------------------------- -! subroutine r_interpolate_var_2d (vname, date, time, data, -! & scol, ecol, srow, erow, slay) + 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 + 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 + 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 + integer :: var_loc + character (40) :: msg -! var_loc = binary_search (vname, vname_2d, n2d_data) + 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 + 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 + end subroutine r_interpolate_var_2d ! ------------------------------------------------------------------------- -! subroutine i_interpolate_var_2d (vname, date, time, data) + 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 + 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(:,:) + character (*), intent(in) :: vname + integer, intent(in) :: date, time + integer, intent(out) :: data(:,:) -! integer :: var_loc -! character (40) :: msg + integer :: var_loc + character (40) :: msg -! var_loc = binary_search (vname, vname_2d, n2d_data) + 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 + 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 + end subroutine i_interpolate_var_2d ! ------------------------------------------------------------------------- -! subroutine r_interpolate_var_2dx (vname, date, time, data, flag) + 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 + 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(:,:) + character (*), intent(in) :: vname + integer, intent(in) :: date, time + logical, intent(in) :: flag + real, intent(out) :: data(:,:) -! integer :: var_loc -! character (40) :: msg + integer :: var_loc + character (40) :: msg -! var_loc = binary_search (vname, vname_2d, n2d_data) + 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 + 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 + 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 + 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 ! ------------------------------------------------------------------------- From c7027253e1cf2ff1345f99a7dcdb5490a65fec95 Mon Sep 17 00:00:00 2001 From: Beiming Tang <51177339+btang1@users.noreply.github.com> Date: Sat, 5 Aug 2023 00:26:28 -0400 Subject: [PATCH 70/90] Add files via upload commented MPAS in CMakeLists.txt --- CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index fc6c8f4..0682a02 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -105,7 +105,7 @@ target_compile_definitions(CCTM PUBLIC SUBST_FILES_ID="FILES_CTM.EXT" WR_INIT=DUMMY_WR_INIT verbose_aero verbose_gas - mpas + # mpas _AQM_) # AQM From 6c09037426570d81f3d76265c8c06a6d27815e1a Mon Sep 17 00:00:00 2001 From: Beiming Tang <51177339+btang1@users.noreply.github.com> Date: Tue, 8 Aug 2023 18:43:39 -0400 Subject: [PATCH 71/90] Add files via upload --- src/model/src/AERO_PHOTDATA.F | 58 +++++++++--------- src/model/src/ASX_DATA_MOD.F | 110 +++++++++------------------------- src/model/src/DUST_EMIS.F | 39 ++++++------ 3 files changed, 78 insertions(+), 129 deletions(-) diff --git a/src/model/src/AERO_PHOTDATA.F b/src/model/src/AERO_PHOTDATA.F index e7acd25..41c708d 100644 --- a/src/model/src/AERO_PHOTDATA.F +++ b/src/model/src/AERO_PHOTDATA.F @@ -1396,8 +1396,8 @@ SUBROUTINE FASTER_OPTICS ( NR, NI, ALPHV, XLNSIG, BETA_EXT, BETA_SCAT, G ) REAL T1F1, T2F1, T1F2, T2F2, T1F3, T2F3 REAL T1G1, T2G1, T1G2, T2G2, T1G3, T2G3, T1G4, T2G4 - REAL T1G5, T2G5 - REAL(8) T1P1, T2P1 !(Wei Li) + REAL T1G5, T2G5 + REAL(8) T1P1, T2P1 C***the following are for calculating the Penndorff Coefficients @@ -1486,7 +1486,7 @@ SUBROUTINE FASTER_OPTICS ( NR, NI, ALPHV, XLNSIG, BETA_EXT, BETA_SCAT, G ) REAL QQSUM, QQF1,QQF2, QQF3, QQCORR REAL, PARAMETER :: DEGTORAD = PI180 - REAL(8), PARAMETER :: THREE_PI_TWO = 3.0 * PI / 2.0 !(Wei Li) + REAL(8), PARAMETER :: THREE_PI_TWO = 3.0 * PI / 2.0 C***FSB start calculation SIGMA_G = EXP( XLNSIG ) @@ -1534,11 +1534,11 @@ SUBROUTINE FASTER_OPTICS ( NR, NI, ALPHV, XLNSIG, BETA_EXT, BETA_SCAT, G ) ALPHA_I = F2 BEXT = B BSCAT = B - PENN1 = DBLE(0.0) !(Wei Li) - PENN2 = DBLE(0.0) !(Wei Li) + PENN1 = DBLE(0.0) + PENN2 = DBLE(0.0) - ALPHV2 = DBLE(ALPHV * ALPHV) !(Wei Li) - ALPHV3 = DBLE(ALPHV2 * ALPHV) !(Wei Li) + ALPHV2 = DBLE(ALPHV * ALPHV) + ALPHV3 = DBLE(ALPHV2 * ALPHV) IF ( NI .GT. 0.0 ) THEN @@ -1605,14 +1605,14 @@ SUBROUTINE FASTER_OPTICS ( NR, NI, ALPHV, XLNSIG, BETA_EXT, BETA_SCAT, G ) EXPFAC2 = EXP( 2.0 * XLNSIG2 ) EXPFAC3 = EXP( 4.5 * XLNSIG2 ) - T1P1 = DBLE(A1 + A2 * ALPHV2 * EXPFAC2) !(Wei Li) - T2P1 = DBLE(A3 * ALPHV3 * EXPFAC3) !(Wei Li) + T1P1 = DBLE(A1 + A2 * ALPHV2 * EXPFAC2) + T2P1 = DBLE(A3 * ALPHV3 * EXPFAC3) 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 ) ) !(Wei Li) - PENN2 = DBLE(THREE_PI_TWO * T2P1) !(Wei Li) + PENN1 = DBLE(THREE_PI_TWO * ( T1P1 + T2P1 )) + PENN2 = DBLE(THREE_PI_TWO * T2P1) END IF ! test for ni > 0.0 @@ -1852,7 +1852,7 @@ SUBROUTINE FAST_OPTICS( NR, NI, LAMBDA, DGN, SIGMA_G, BETA_EXT, BETA_SCAT, G ) REAL C, CEXT, CSCAT REAL B, BEXT, BSCAT REAL BBFAC - REAL(8) ALPHV !(Wei Li) + REAL(8) ALPHV REAL ALPHA_I REAL A, LOGX2, XLNSIG, XLNSIG2, MM1 @@ -1866,7 +1866,7 @@ SUBROUTINE FAST_OPTICS( NR, NI, LAMBDA, DGN, SIGMA_G, BETA_EXT, BETA_SCAT, G ) REAL LARGEEXT ! large sphere limit for extinction REAL SMALL_G, LARGE_G - REAL(8) ALPHV2, ALPHV3 !(Wei Li) + REAL(8) ALPHV2, ALPHV3 REAL X_ALPHA, X_ALPHA2, X_ALPHA3 REAL FCORR REAL EXPFAC2, EXPFAC3 @@ -1879,12 +1879,12 @@ SUBROUTINE FAST_OPTICS( NR, NI, LAMBDA, DGN, SIGMA_G, BETA_EXT, BETA_SCAT, G ) REAL T1F1, T2F1, T1F2, T2F2, T1F3, T2F3 REAL T1G1, T2G1, T1G2, T2G2, T1G3, T2G3, T1G4, T2G4 REAL T1G5, T2G5 - REAL(8) T1P1, T2P1 !(Wei Li) + REAL(8) T1P1, T2P1 C***the following are for calculating the Penndorff Coefficients REAL A1, A2, A3 - REAL(8) PENN1, PENN2 !(Wei Li) + REAL(8) PENN1, PENN2 REAL XNR, XNI, XNR2, XNI2, XNRI, XNRI2, XNRMI REAL XRI, XRI2, XRI36, XNX, XNX2 REAL Z1, Z12, Z2, XC1 @@ -1969,7 +1969,7 @@ SUBROUTINE FAST_OPTICS( NR, NI, LAMBDA, DGN, SIGMA_G, BETA_EXT, BETA_SCAT, G ) REAL QQSUM, QQF1,QQF2, QQF3, QQCORR REAL, PARAMETER :: DEGTORAD = PI180 - REAL(8), PARAMETER :: THREE_PI_TWO = 3.0 * PI / 2.0 !(Wei Li) + REAL(8), PARAMETER :: THREE_PI_TWO = 3.0 * PI / 2.0 REAL, PARAMETER :: SCALE = 1.00E+9 @@ -1982,9 +1982,9 @@ SUBROUTINE FAST_OPTICS( NR, NI, LAMBDA, DGN, SIGMA_G, BETA_EXT, BETA_SCAT, G ) C***FSB start calculation XLNSIG = LOG( SIGMA_G ) - ALPHV = DBLE(SCALE * PI * DGN * EXP( 3.0 * XLNSIG * XLNSIG ) / LAMBDA) !(Wei Li) - ALPHV2 = DBLE(ALPHV * ALPHV) !(Wei Li) - ALPHV3 = DBLE(ALPHV * ALPHV * ALPHV) !(Wei Li) + ALPHV = DBLE(SCALE * PI * DGN * EXP( 3.0 * XLNSIG * XLNSIG ) / LAMBDA) + ALPHV2 = DBLE(ALPHV * ALPHV) + ALPHV3 = DBLE(ALPHV * ALPHV * ALPHV) XLNSIG2 = XLNSIG * XLNSIG A = 0.5 / XLNSIG2 @@ -2024,8 +2024,8 @@ SUBROUTINE FAST_OPTICS( NR, NI, LAMBDA, DGN, SIGMA_G, BETA_EXT, BETA_SCAT, G ) ALPHA_I = F2 BEXT = B BSCAT = B - PENN1 = DBLE(0.0) !(Wei Li) - PENN2 = DBLE(0.0) !(Wei Li) + PENN1 = DBLE(0.0) + PENN2 = DBLE(0.0) IF ( NI .GT. 0.0 ) THEN @@ -2079,25 +2079,25 @@ SUBROUTINE FAST_OPTICS( NR, NI, LAMBDA, DGN, SIGMA_G, BETA_EXT, BETA_SCAT, G ) Z12 = Z1 * Z1 Z2 = 4.0 * XNRI2 + 12.0 * XNRMI + 9.0 XC1 = 8.0 / ( 3.0 * Z12 ) - A1 = DBLE(24.0 * XRI / Z1) !(Wei Li) + A1 = DBLE(24.0 * XRI / Z1) - A2 = DBLE(44.0 * XRI / 15.0 + 20.0 * XRI / ( 3.0 * Z2 ) + + A2 = DBLE(4.0 * XRI / 15.0 + 20.0 * XRI / ( 3.0 * Z2 ) + & 4.8 * XRI * ( 7.0 * XNRI2 + - & 4.0 * ( XNRMI - 5.0 ) ) / Z12 ) !(Wei Li) + & 4.0 * ( XNRMI - 5.0 ) ) / Z12) - A3 = DBLE(XC1 * ( XNX2 - XRI36 )) !(Wei Li) + A3 = DBLE(XC1 * ( XNX2 - XRI36 )) EXPFAC2 = EXP( 2.0 * XLNSIG2 ) EXPFAC3 = EXP( 4.5 * XLNSIG2 ) - T1P1 = DBLE(A1 + A2 * ALPHV2 * EXPFAC2) !(Wei Li) - T2P1 = DBLE(A3 * ALPHV3 * EXPFAC3) !(Wei Li) + T1P1 = DBLE(A1 + A2 * ALPHV2 * EXPFAC2) + T2P1 = DBLE(A3 * ALPHV3 * EXPFAC3) 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 )) !(Wei Li) - PENN2 = DBLE(THREE_PI_TWO * T2P1 ) !(Wei Li) + 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 index 8270f49..e3bbfca 100644 --- a/src/model/src/ASX_DATA_MOD.F +++ b/src/model/src/ASX_DATA_MOD.F @@ -129,24 +129,14 @@ Module ASX_DATA_MOD Integer, Allocatable :: LPBL ( :,: ) ! PBL layer Logical, Allocatable :: CONVCT ( :,: ) ! convection flag Real, Allocatable :: PBL ( :,: ) ! pbl height (m) -! Real, Allocatable :: NACL_EMIS( :,: ) ! NACL mass emission rate of particles with d <10 um (g/m2/s) + +!Real, Allocatable :: NACL_EMIS( :,: ) ! NACL mass emission rate of particles with d <10 um (g/m2/s) Real, Allocatable :: COSZEN ( :,: ) ! Cosine of the zenith angle Real, Allocatable :: CFRAC ( :,: ) ! cloud fraction -!> Inline Canopy Processes (Wei Li) - 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 (Wei Li) - Real, Allocatable :: CLAYF ( :,: ) ! Fractional Clay Content - Real, Allocatable :: SANDF ( :,: ) ! Fractional Sand Content +!> 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 @@ -156,7 +146,7 @@ Module ASX_DATA_MOD !> 3-D meteorological fields: Real, Allocatable :: KZMIN ( :,:,: ) ! minimum Kz [m**2/s] Real, Allocatable :: PRES ( :,:,: ) ! pressure [Pa] - Real, Allocatable :: PRESF ( :,:,: ) ! full layer pressure [Pa] (Wei Li) + 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 @@ -169,8 +159,8 @@ Module ASX_DATA_MOD Real, Allocatable :: RJACM ( :,:,: ) ! reciprocal mid-layer Jacobian Real, Allocatable :: RJACF ( :,:,: ) ! reciprocal full-layer Jacobian Real, Allocatable :: RRHOJ ( :,:,: ) ! reciprocal density X Jacobian - Real, Allocatable :: UWINDA ( :,:,: ) ! [m/s] (Wei Li) - Real, Allocatable :: VWINDA ( :,:,: ) ! [m/s] (Wei Li) + Real, Allocatable :: UWINDA ( :,:,: ) ! [m/s] + Real, Allocatable :: VWINDA ( :,:,: ) ! [m/s] End Type MET_Type Type :: GRID_Type @@ -261,13 +251,9 @@ Module ASX_DATA_MOD Real, allocatable, private :: BUFF2D( :,: ) ! 2D temp var Real, allocatable, private :: BUFF3D( :,:,: ) ! 3D temp var -! Canopy option control (Wei Li) - CHARACTER( 20 ), SAVE :: CTM_CANOPY_SHADE = 'CTM_CANOPY_SHADE '! env var for in-line - LOGICAL, PUBLIC, SAVE :: CANOPY_SHADE ! flag in-lining canopy shading - -! FENGSHA option control (Wei Li) +! 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 + LOGICAL, PUBLIC, SAVE :: FENGSHA ! flag for fengsha option INTEGER IOSX ! i/o and allocate memory status @@ -623,15 +609,15 @@ Subroutine INIT_MET ( JDATE, JTIME ) & Met_Data%CONVCT ( NCOLS,NROWS ), & Met_Data%PBL ( NCOLS,NROWS ), ! & Met_Data%NACL_EMIS( NCOLS,NROWS ), + & Met_Data%UWINDA ( NCOLS,NROWS,NLAYS ), + & Met_Data%VWINDA ( NCOLS,NROWS,NLAYS ), & Met_Data%COSZEN ( NCOLS,NROWS ), & Met_Data%CFRAC ( NCOLS,NROWS ), - & Met_Data%UWINDA ( NCOLS,NROWS,NLAYS ), !(Wei Li) - & Met_Data%VWINDA ( NCOLS,NROWS,NLAYS ), !(Wei Li) & Met_Data%UWIND ( NCOLS+1,NROWS+1,NLAYS ), & Met_Data%VWIND ( NCOLS+1,NROWS+1,NLAYS ), & Met_Data%KZMIN ( NCOLS,NROWS,NLAYS ), - & Met_Data%PRESF ( NCOLS,NROWS,1:NLAYS+1 ), !(Wei Li) & Met_Data%PRES ( NCOLS,NROWS,NLAYS ), + & Met_Data%PRESF ( NCOLS,NROWS,1:NLAYS+1 ), & Met_Data%QV ( NCOLS,NROWS,NLAYS ), & Met_Data%QC ( NCOLS,NROWS,NLAYS ), & Met_Data%THETAV ( NCOLS,NROWS,NLAYS ), @@ -716,33 +702,7 @@ Subroutine INIT_MET ( JDATE, JTIME ) Grid_Data%BSLP = 0.0 End If -!> ccccccccccccccccccccc canopy shade option!ccccccccccccccccccccc (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 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 Canopy Shade variables' - Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - End If - -!> ccccccccccccccccccccc Fengsha option!ccccccccccccccccccccc (Wei Li) +!> ccccccccccccccccccccc Fengsha option!ccccccccccccccccccccc FENGSHA = ENVYN( CTM_WBDUST_FENGSHA, & 'Flag for in-line fengsha ', & .FALSE., IOSX ) @@ -761,9 +721,9 @@ Subroutine INIT_MET ( JDATE, JTIME ) If ( ALLOCSTAT .Ne. 0 ) Then XMSG = 'Failure allocating Fengsha variables' Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - End If - + End If + End If + !> ccccccccccccccccccccc enable backward compatiblity ccccccccccccccccccccc @@ -911,11 +871,7 @@ Subroutine GET_MET ( JDATE, JTIME, TSTEP ) call interpolate_var ('PRES', jdate, jtime, Met_Data%PRES) - call interpolate_var ('PRESF', jdate, jtime, Met_Data%PRESF) !(Wei Li) - - call interpolate_var ('UWINDA', jdate, jtime, Met_Data%UWINDA) !(Wei Li) - - call interpolate_var ('VWINDA', jdate, jtime, Met_Data%VWINDA) !(Wei Li) + call interpolate_var ('PRESF', jdate, jtime, Met_Data%PRESF) call interpolate_var ('ZF', jdate, jtime, Met_Data%ZF) @@ -941,36 +897,28 @@ Subroutine GET_MET ( JDATE, JTIME, TSTEP ) call interpolate_var ('QC', jdate, jtime, Met_Data%QC) + call interpolate_var ('UWINDA', jdate, jtime, Met_Data%UWINDA) + + call interpolate_var ('VWINDA', jdate, jtime, Met_Data%VWINDA) C-------------------------------- MET_CRO_2D -------------------------------- C Vegetation and surface vars + call interpolate_var ('LAI', jdate, jtime, Met_Data%LAI) call interpolate_var ('VEG', jdate, jtime, Met_Data%VEG) call interpolate_var ('ZRUF', jdate, jtime, Met_Data%Z0) -C Canopy vars (Wei Li) - If ( CANOPY_SHADE ) Then - call interpolate_var ('FCH', jdate, jtime, Met_Data%FCH) - call interpolate_var ('FRT', jdate, jtime, Met_Data%FRT) - call interpolate_var ('CLU', jdate, jtime, Met_Data%CLU) - call interpolate_var ('POPU', jdate, jtime, Met_Data%POPU) - call interpolate_var ('LAIE', jdate, jtime, Met_Data%LAIE) - call interpolate_var ('C1R', jdate, jtime, Met_Data%C1R) - call interpolate_var ('C2R', jdate, jtime, Met_Data%C2R) - call interpolate_var ('C3R', jdate, jtime, Met_Data%C3R) - call interpolate_var ('C4R', jdate, jtime, Met_Data%C4R) - End If +C FENGSHA vars + If ( FENGSHA ) Then + call interpolate_var ('CLAYF', jdate, jtime, Met_Data%CLAYF) -C FENGSHA vars (Wei Li) - If ( CANOPY_SHADE ) Then - call interpolate_var ('CLAYF', jdate, jtime, Met_Data%CLAYF) - call interpolate_var ('SANDF', jdate, jtime, Met_Data%SANDF) - call interpolate_var ('DRAG', jdate, jtime, Met_Data%DRAG) - call interpolate_var ('UTHR', jdate, jtime, Met_Data%UTHR) - End If + 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) diff --git a/src/model/src/DUST_EMIS.F b/src/model/src/DUST_EMIS.F index fe3352e..0a6d6fe 100644 --- a/src/model/src/DUST_EMIS.F +++ b/src/model/src/DUST_EMIS.F @@ -17,7 +17,7 @@ ! subject to their copyright restrictions. ! !------------------------------------------------------------------------! -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: +C::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: module dust_emis C----------------------------------------------------------------------- @@ -112,7 +112,7 @@ module dust_emis C Number of soil types: For WRF there are 16 types; integer, parameter :: nsltyp = 16 -C Variables for FENGSHA dust scheme (beiming tang) +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: @@ -273,13 +273,14 @@ function dust_emis_init( jdate, jtime, tstep ) result( success ) success = .false.; return end if - if ( fengsha ) then !(beiming tang) + if ( fengsha ) then C Disable diagnostic output if FENGSHA is used dustem_diag = .false. C Allocate private arrays - allocate( tfb( ncols,nrows ), stat = status ) + !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' @@ -471,7 +472,7 @@ function dust_emis_init( jdate, jtime, tstep ) result( success ) end if ! dustem_diag - end if !dust scheme (beiming tang) + end if !dust scheme l2sgj = log( sigj ) * log( sigj ) l2sgk = log( sigk ) * log( sigk ) @@ -635,7 +636,7 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt, real, parameter :: sigb_mb = sigb * mb ! = 0.5 real, parameter :: betab_mb = betab * mb ! = 45.0 - character( 24 ) :: ctm_wbdust_fengsha_alpha = 'CTM_WBDUST_FENGSHA_ALPHA' ! env var to (beiming tang) + character( 24 ) :: ctm_wbdust_fengsha_alpha = 'CTM_WBDUST_FENGSHA_ALPHA' ! env var to ! retrieve FENGSHA scaling factor character( 16 ) :: pname = 'GET_DUST_EMIS' @@ -675,7 +676,7 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt, real :: lambdav ! vegetation roughness density - Shao et. al [Aus. J. Soil Res., 1996] real :: flxfac1, flxfac2 ! combined soli type mapping factors real :: hflux, vflux ! horizontal and vertical dust flux - real :: v2h ! vertical/horizontal dust flux ratio (beiming tang) + real :: v2h ! vertical/horizontal dust flux ratio real :: wm ! max adsorb water [%] real :: jday integer :: emap( n_dlcat+1 ) @@ -762,9 +763,9 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt, if ( firstime ) then firstime = .false. if ( fengsha ) then - dust_alpha = 0.05 ! default (beiming tang) + 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' @@ -772,20 +773,20 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt, end if write(xmsg,'("Using FENGSHA alpha = ",g12.5)') dust_alpha call m3msg2 ( xmsg ) - else + 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 ) + & qam( ncols,nrows,n_dlcat+1 ), + & fruf( ncols,nrows,n_dlcat+1 ), + & kvh( ncols,nrows,n_dlcat+1 ), + & elus( ncols,nrows,n_dlcat+1 ), stat = status ) if ( status .ne. 0 ) then xmsg = '*** Failure allocating USTR, QAM, FRUF, KVH, or ELUS' call m3exit( pname, jdate, jtime, xmsg, xstat1 ) end if - end if + end if !end fengsha end if -C---Select dust scheme (beiming tang) +C---Select dust scheme if ( fengsha ) then do r = 1, nrows @@ -837,7 +838,7 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt, rlay1hgt = rjacm ( c,r ) / cellhgt - dust_em( c,r ) = dust_alpha * vflux * rlay1hgt *tfa(c,r) * tfb(c,r) + dust_em( c,r ) = dust_alpha * vflux * rlay1hgt! *tfa(c,r) * tfb(c,r) end if ! if rain & land & snow & drag @@ -1128,7 +1129,7 @@ subroutine get_dust_emis( jdate, jtime, tstep, rjacm, cellhgt, & out of total cells:', & dryhit, (c-1)*(r-1) #endif - end if !dust scheme (beiming tang) + end if !dust scheme do r = 1, nrows do c = 1, ncols @@ -1374,7 +1375,7 @@ 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 ) !beiming tang + function dust_hflux_fengsha( ustar, fmoit, drag, uthr,ssm, dens ) & result( hflux ) implicit none From e2e08b7106d781bfd68d4b2737a132e76beba3c8 Mon Sep 17 00:00:00 2001 From: Beiming Tang <51177339+btang1@users.noreply.github.com> Date: Wed, 9 Aug 2023 18:51:18 -0400 Subject: [PATCH 72/90] Add files via upload --- src/model/src/o3totcol.f | 24 +- src/model/src/vdiffacmx.F | 895 ++++++++++++++++++++++++++++++++++---- 2 files changed, 825 insertions(+), 94 deletions(-) diff --git a/src/model/src/o3totcol.f b/src/model/src/o3totcol.f index a500cee..5ab1134 100644 --- a/src/model/src/o3totcol.f +++ b/src/model/src/o3totcol.f @@ -96,12 +96,11 @@ subroutine o3totcol ( latitude, longitude, jdate, jtime, ozone ) real, allocatable, save :: lat( : ) real, allocatable, save :: lon( : ) real, allocatable, save :: oz( :, :, : ) ! two timesteps for interpolation - + + character( 8 ) :: label logical, save :: firsttime = .true. - character( 8 ) :: label !(Wei li) - real, external :: yr2day !(Wei Li: from io/ioapi/yr2day.F) - character*24, external :: dt2str !(Wei Li) - + real, external :: yr2day + character*24, external :: dt2str !---------------------------------------------------------------------- if ( firsttime ) then @@ -115,10 +114,10 @@ subroutine o3totcol ( latitude, longitude, jdate, jtime, ozone ) call m3exit ( pname, jdate, 0, xmsg, xstat1 ) end if - ! read nlat, nlon (Wei Li) + ! read nlat, nlon rewind( tmunit ) - read( tmunit, *) label, nlat - read( tmunit, *) label, nlon + read( tmunit, '(5x,i7)') label,nlat + read( tmunit, '(5x,i7)') label,nlon write(logdev,'(a,i7,a,i7)')'OMI Ozone column data has Lat by Lon Resolution: ', & nlat,'X',nlon @@ -135,17 +134,16 @@ subroutine o3totcol ( latitude, longitude, jdate, jtime, ozone ) call m3exit ( pname, jdate, 0, xmsg, xstat1 ) end if -! Assign values to array of longitudes: lon +!! 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 in longitudes instead (Wei Li) - read( tmunit, * ) label, label, lon + read( tmunit, * ) label, label, lon ! read in longitudes nrecs = 0 - ! read( tmunit, * ) !skip header record. Wei Li:no need here +! read( tmunit, * ) ! skip header record do read( tmunit, *, iostat=ios ) if ( ios .ne. 0 ) exit @@ -166,7 +164,6 @@ subroutine o3totcol ( latitude, longitude, jdate, jtime, ozone ) end if rewind( tmunit ) - ! skip header records read( tmunit, * ) read( tmunit, * ) read( tmunit, * ) @@ -310,7 +307,6 @@ subroutine o3totcol ( latitude, longitude, jdate, jtime, ozone ) end do x1loop ! Determine the corresponding bounding ozone values for all lats and lons rewind( tmunit ) - ! skip header records read( tmunit,* ) read( tmunit,* ) read( tmunit,* ) diff --git a/src/model/src/vdiffacmx.F b/src/model/src/vdiffacmx.F index 06954c4..d6da295 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, TOT_BD_EMIS, DDEPJ, 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,30 @@ 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 10 Feb 19 D.Wong: removed all MY_N clauses 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 -C USE PT3D_EMIS_DEFN + USE MOSAIC_MOD, ONLY: Tile_Data +! 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 IMPLICIT NONE @@ -67,12 +75,11 @@ SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, ICMP, DDEPJ, DDEPJ_FST, CNGRD ) C Arguments: REAL, INTENT( IN ) :: DTSEC ! model time step in seconds C--- SEDDY is strictly an input, but it gets modified here - REAL, INTENT( INOUT ) :: SEDDY ( :,:,: ) ! flipped EDDYV - REAL, INTENT( INOUT ) :: DDEP ( :,:,: ) ! ddep accumulator - REAL, INTENT( INOUT ) :: ICMP ( :,:,: ) ! component flux accumlator + REAL, INTENT( INOUT ) :: SEDDY ( :,:,: ) ! flipped EDDYV + REAL, INTENT( INOUT ) :: DDEP ( :,:,: ) ! ddep accumulator + REAL, INTENT( INOUT ) :: TOT_BD_EMIS ( :,:,: ) ! bidi emissions 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 + REAL, INTENT( INOUT ) :: CNGRD ( :,:,:,: ) ! cgrid replacement C Parameters: @@ -80,6 +87,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,58 +96,156 @@ 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 :: DD_FACJ ( :,: ) ! combined subexpression for mosaic REAL, ALLOCATABLE, SAVE :: DDBF ( : ) ! secondary DDEP - REAL, ALLOCATABLE, SAVE :: CMPF ( : ) ! intermediate CMP +! REAL, ALLOCATABLE, SAVE :: DDBFJ ( :,: ) ! secondary DDEP for mosaic + REAl, ALLOCATABLE, SAVE :: TMP_BD_EMIS( : ) ! intermediate bidi emissions 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 +! REAL, ALLOCATABLE, SAVE :: DEPVJCR ( :,: ) ! dep vel in one cell for each landuse 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 + REAL, ALLOCATABLE, SAVE :: EMIS_OVER_VD( : ) ! Bidi Emissions/DEPV (ppm) + REAL PLDV_HONO ! PLDV for HONO + REAL DEPV_NO2 ! dep vel of NO2 + REAL DEPV_HNO3 ! dep vel of HNO3 +! REAL FNL ! ACM2 Variable +! INTEGER NLP, NL, LCBL INTEGER, SAVE :: NO2_HIT, HONO_HIT, HNO3_HIT, NO2_MAP, HNO3_MAP - INTEGER, SAVE :: NH3_HIT + INTEGER, SAVE :: NH3_HIT, HG_HIT +! 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 + +! LOGICAL, SAVE :: XMOSAIC = .FALSE. + +#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 +#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 C set auxiliary depv arrays - ALLOCATE ( DD_FAC( N_SPC_DEPV ), - & DDBF ( N_SPC_DEPV ), - & DEPVCR( N_SPC_DEPV ), - & EFAC1 ( N_SPC_DEPV ), - & EFAC2 ( N_SPC_DEPV ), - & POL ( N_SPC_DEPV ), STAT = ASTAT ) + ALLOCATE ( DD_FAC ( N_SPC_DEPV ), + & DDBF ( N_SPC_DEPV ), + & DEPVCR ( N_SPC_DEPV ), + & EFAC1 ( N_SPC_DEPV ), + & EFAC2 ( N_SPC_DEPV ), + & EMIS_OVER_VD ( N_SPC_DEPV ), STAT = ASTAT ) IF ( ASTAT .NE. 0 ) THEN - XMSG = 'Failure allocating DD_FAC, DDBF, DEPVCR, EFAC1, EFAC2, or POL' + XMSG = 'Failure allocating DD_FAC, DDBF, DEPVCR, EFAC1, EFAC2, or EMIS_OVER_VDs' CALL M3EXIT( PNAME, MDATE, MTIME, XMSG, XSTAT1 ) END IF - ALLOCATE ( CMPF( LCMP ), STAT = ASTAT ) +! IF ( PRESENT ( DDEPJ ) ) XMOSAIC = .TRUE. + +! IF ( XMOSAIC ) THEN +! ALLOCATE ( DD_FACJ( Tile_Data%N_LUFRAC,N_SPC_DEPV ), +! & DDBFJ ( Tile_Data%N_LUFRAC,N_SPC_DEPV ), +! & DEPVJCR( Tile_Data%N_LUFRAC,N_SPC_DEPV ), STAT = ASTAT ) +! IF ( ASTAT .NE. 0 ) THEN +! XMSG = 'Failure allocating DD_FACJ, DDBFJ or DEPVJCR' +! CALL M3EXIT( PNAME, MDATE, MTIME, XMSG, XSTAT1 ) +! END IF +! END IF ! if Mosaic + + ALLOCATE ( TMP_BD_EMIS( N_BD_EMIS ), STAT = ASTAT ) IF ( ASTAT .NE. 0 ) THEN - XMSG = 'Failure allocating CMPF' + XMSG = 'Failure allocating TMP_BD_EMIS' CALL M3EXIT( PNAME, MDATE, MTIME, XMSG, XSTAT1 ) END IF @@ -150,6 +257,14 @@ 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 DO V = 1, N_SPC_DEPV @@ -163,68 +278,398 @@ SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, ICMP, DDEPJ, DDEPJ_FST, CNGRD ) HNO3_MAP = DV2DF( V ) ELSE IF ( DV2DF_SPC( V ) .EQ. 'NH3' ) THEN NH3_HIT = V + ELSE IF ( DV2DF_SPC( V ) .EQ. 'HG' ) THEN + HG_HIT = 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 + IF ( ISAM_DEPV( JSPCTAG ) .GT. 0 ) THEN + V = ISAM_DEPV( JSPCTAG ) + WRITE(LOGDEV,'(I4,4X,2(A16,1X))')JSPCTAG,ISAM_SPECIES,DV2DF_SPC( V ) + ELSE + WRITE(LOGDEV,'(I4,4X,2(A16,1X))')JSPCTAG,ISAM_SPECIES,'NONE' + END IF + 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 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 - DO 345 R = 1, MY_NROWS - DO 344 C = 1, MY_NCOLS +!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 + +! 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 ACM +! 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. MY_NROWS / 2 .AND. C .EQ. MY_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 + +#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 + 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 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, BIDI_VDEMIS > 0.0) + IF ( SA_BIDI ) THEN + SA_VDEMIS_DIFF( ISAM_INDEX_NH3,1,C,R,BIDITAG ) + & = Tile_Data%Bidi_Emis( C, R, Tile_Data%dep2vdiff( PLDV_INDEX_NH3 ) ) + 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 - RP = DFACP * Met_Data%RDEPVHT( C,R ) - RQ = DFACQ * Met_Data%RDEPVHT( C,R ) +! 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 ) + EMIS_OVER_VD = 0.0 DO V = 1, N_SPC_DEPV DDBF( V ) = DDEP( V,C,R ) - DEPVCR( V ) = DEPV( V,C,R ) + DEPVCR( V ) = Tile_Data%Vd_Fac( Tile_Data%dep2vdiff( V ) ) * + & Tile_Data%Grd_Vd( C,R,Tile_Data%dep2vdiff( V ) ) DD_FAC( V ) = DTDENS1 * DD_CONV( V ) * DEPVCR( V ) 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 + If( Tile_Data%Bidi_Emis( C, R, Tile_Data%dep2vdiff( V ) ) .Gt. 0.0 ) Then + If(DEPVCR( V ) .Eq. 0.0) Then + Write(Logdev,*) 'Warning: A deposition velocity of 0 m/s was detected with a production term greater' + Write(Logdev,*) 'than zero. Check for DEPV_FACs less than zero in the species name list for model species:' + Write(Logdev,*) DV2DF_SPC( V ), 'depvcr', DEPVCR( V ), 'bidi emissions', + & Tile_Data%Bidi_Emis( C, R, Tile_Data%dep2vdiff( V ) ) + DEPVCR( V ) = tiny( 0.0 ) + End If + EMIS_OVER_VD( V ) = Tile_Data%Bidi_Emis( C, R, Tile_Data%dep2vdiff( V ) ) / DEPVCR( V ) + End If + IF ( ABFLUX ) THEN + TMP_BD_EMIS( NH3_E ) = TOT_BD_EMIS( NH3_E,C,R ) + END IF + IF ( HGBIDI ) THEN + TMP_BD_EMIS( HG_E ) = TOT_BD_EMIS( HG_E,C,R ) + END IF + IF ( SFC_HONO ) THEN + TMP_BD_EMIS( HONO_E ) = TOT_BD_EMIS( HONO_E,C,R ) + END IF END DO - PLDV_HONO = PLDV( HONO_HIT,C,R ) + PLDV_HONO = Tile_Data%Bidi_Emis( C, R, Tile_Data%dep2vdiff( HONO_HIT ) ) -C----------------------------------------------------------------------- +#ifdef isam + DO JSPCTAG = 1, N_SPCTAG + SA_DDBF( JSPCTAG ) = SA_DDEP( C,R,JSPCTAG ) + END DO +#endif + +!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 +!C ---------------------------------------------------------------------- + +! IF ( XMOSAIC ) THEN +! DDBFJ( :,: ) = DDEPJ( :,:,C,R ) +! DO L = 1, Tile_Data%n_lufrac +! DEPVJCR( L,: ) = Tile_Data%Vd_Fac( Tile_Data%dep2vdiff ) * +! & Tile_Data%Lu_Vd( C,R,Tile_Data%dep2vdiff,L ) +! DD_FACJ( L,: ) = DTDENS1 * DD_CONV( : ) * DEPVJCR( L,: ) +! END DO +! END IF + +!C----------------------------------------------------------------------- + +! DO 301 NL = 1, NLP ! loop over sub time DO V = 1, N_SPC_DEPV C --------- HET HONO RX ----------------- + C Use special treatment for HNO3 C HNO3 produced via the heterogeneous reaction sticks on surfaces and C is accounted as depositional loss; calculate increased deposition loss IF ( V .EQ. HNO3_HIT ) THEN S = HNO3_MAP - CONC( S,1 ) = POL( V ) + ( CONC( S,1 ) - POL( V ) ) * EFAC1( V ) - DEPV_HNO3 = DEPVCR( V ) + PLDV_HONO / CONC( NO2_MAP,1 ) + CONC( S,1 ) = EMIS_OVER_VD( V ) + ( CONC( S,1 ) - EMIS_OVER_VD( V ) ) * EFAC1( V ) + 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 ) + DDBF( V ) = DDBF( V ) + THETA * DD_FAC( V ) * CONC( S,1 ) C Use special treatment for NO2 C Loss of NO2 via the heterogeneous reaction is accounted for as an additional @@ -232,87 +677,377 @@ SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, ICMP, DDEPJ, DDEPJ_FST, CNGRD ) C to the regular deposition velocity (increased dep. vel.). This will C reduce the NO2 conc. in the atmosphere without affecting the depositional loss. ELSE IF ( V .EQ. NO2_HIT ) THEN - S = NO2_MAP - DEPV_NO2 = DEPVCR( V ) + 2.0 * PLDV_HONO / CONC( S,1 ) - EFAC1 ( V ) = EXP( -DEPV_NO2 * RP ) - EFAC2 ( V ) = EXP( -DEPV_NO2 * RQ ) - 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 ) + S = NO2_MAP + DEPV_NO2 = DEPVCR( V ) + 2.0 * PLDV_HONO / CONC( S,1 ) + EFAC1 ( V ) = EXP( -DEPV_NO2 * RP ) + EFAC2 ( V ) = EXP( -DEPV_NO2 * RQ ) + EMIS_OVER_VD( V ) = Tile_Data%Bidi_Emis( C, R, Tile_Data%dep2vdiff( V ) ) / DEPV_NO2 + CONC( S,1 ) = EMIS_OVER_VD( V ) + ( CONC( S,1 ) - EMIS_OVER_VD( V ) ) * EFAC1( V ) + DDBF( V ) = DDBF( V ) + THETA * DD_FAC( V ) * CONC( S,1 ) 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 ) + CONC( S,1 ) = EMIS_OVER_VD( V ) + ( CONC( S,1 ) - EMIS_OVER_VD( V ) ) * EFAC1( V ) DDBF( V ) = DDBF( V ) + THETA * DD_FAC( V ) * CONC( S,1 ) 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 + TMP_BD_EMIS( NH3_E ) = TMP_BD_EMIS( NH3_E ) + + & THETA * Tile_Data%Bidi_Emis( C, R, Tile_Data%dep2vdiff( V ) ) * DD_CONV( V ) * DTDENS1 + END IF + IF ( HGBIDI .AND. V .EQ. HG_HIT ) THEN + TMP_BD_EMIS( HG_E ) = TMP_BD_EMIS( HG_E ) + + & THETA * Tile_Data%Bidi_Emis( C, R, Tile_Data%dep2vdiff( V ) ) * DD_CONV( V ) * DTDENS1 + END IF + IF ( SFC_HONO .AND. V .EQ. HONO_HIT ) THEN + TMP_BD_EMIS( HONO_E ) = TMP_BD_EMIS( HONO_E ) + + & THETA * Tile_Data%Bidi_Emis( C, R, Tile_Data%dep2vdiff( V ) ) * DD_CONV( V ) * DTDENS1 END IF END IF END DO -C --------- ADD EMISSIONS --------------- +! IF ( XMOSAIC ) THEN +! DO V = 1, N_SPC_DEPV +!C --------------- HET HONO RX ----------------- +! IF ( V .EQ. HNO3_HIT ) THEN +! S = HNO3_MAP +! WHERE( Tile_Data%LUFRAC( c,r,: ) .GT. 0.0 ) +! DD_FACJ( :,V ) = DTDENS1 * DD_CONV( V ) * DEPVJCR( :,V ) + PLDV_HONO / CONC( NO2_MAP,1 ) +! DDBFJ( :,V ) = DDBFJ( :,V ) + THETA * DD_FACJ( :,V ) * CONC( S,1 ) +! END WHERE +! ELSE IF ( V .EQ. NO2_HIT ) THEN +! S = NO2_MAP +! WHERE( Tile_Data%LUFRAC( c,r,: ) .GT. 0.0 .AND. DEPVJCR( :,V ) .GT. 0.0 ) +! DDBFJ ( :,V ) = DDBFJ( :,V ) + THETA * DD_FACJ( :,V ) * CONC( S,1 ) +! END WHERE +!C --------------- END of HET HONO RX ---------- +! ELSE +! S = DV2DF( V ) +! WHERE( Tile_Data%LUFRAC( c,r,: ) .GT. 0.0 ) +! DDBFJ( :,V ) = DDBFJ( :,V ) +! & + THETA * DD_FACJ( :,V ) * CONC( S,1 ) +! END WHERE +! END IF +! END DO +! END IF ! MOSAIC DO L = 1, NLAYS DO V = 1, N_SPC_DIFF - CONC( V,L ) = CONC( V,L ) + EMIS( V,L ) +! DD( V,L ) = 0.0 +! UU( V,L ) = 0.0 + CONC( V,L ) = CONC( V,L ) + EMIS( V,L ) END DO END DO -C --------- END EMISSIONS --------------- +#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 ) * EMIS_OVER_VD( S ) * ( 1.0 - EFAC1( S ) ) + SA_DDBF( JSPCTAG ) = SA_DDBF( JSPCTAG ) + & + THETA * DD_FAC( S ) * SACONC( JSPCTAG,1 ) + END IF + END DO + + 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 ) +! 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 +! 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 + +!C update conc +! DO L = 1, LCBL +! DO V = 1, N_SPC_DIFF +! CONC( V,L ) = UU( V,L ) +! 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 +! 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 ) +! 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 ) +! 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 ) ) +! 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 + +!C Load into CGRID +! DO L = 1, NLAYS +! DO V = 1, N_SPC_DIFF +! CONC( V,L ) = UU( V,L ) +! END DO +#ifdef isam + DO JSPCTAG = 1, N_SPCTAG + SACONC( JSPCTAG,L ) = SA_UU( JSPCTAG,L ) + END DO +#endif +! END DO + DO V = 1, N_SPC_DEPV C --------- HET HONO RX ----------------- IF ( V .EQ. HNO3_HIT ) THEN S = HNO3_MAP - CONC( S,1 ) = POL( V ) + ( CONC( S,1 ) - POL( V ) ) * EFAC2( V ) - DDBF( V ) = DDBF( V ) + THBAR * DD_FAC( V ) * CONC( S,1 ) + CONC( S,1 ) = EMIS_OVER_VD( V ) + ( CONC( S,1 ) - EMIS_OVER_VD( V ) ) * EFAC2( V ) + DDBF( V ) = DDBF( V ) + THBAR * DD_FAC( V ) * CONC( S,1 ) 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 ) + CONC( S,1 ) = EMIS_OVER_VD( V ) + ( CONC( S,1 ) - EMIS_OVER_VD( V ) ) * EFAC2( V ) + DDBF( V ) = DDBF( V ) + THBAR * DD_FAC( V ) * CONC( S,1 ) C --------- END of HET HONO RX ---------- ELSE S = DV2DF( V ) - CONC( S,1 ) = POL( V ) + ( CONC( S,1 ) - POL( V ) ) * EFAC2( V ) + CONC( S,1 ) = EMIS_OVER_VD( V ) + ( CONC( S,1 ) - EMIS_OVER_VD( 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 + TMP_BD_EMIS( NH3_E ) = TMP_BD_EMIS( NH3_E ) + + & THBAR * Tile_Data%Bidi_Emis( C, R, Tile_Data%dep2vdiff( V ) ) * DD_CONV( V ) * DTDENS1 + END IF + IF ( HGBIDI .AND. V .EQ. HG_HIT ) THEN + TMP_BD_EMIS( HG_E ) = TMP_BD_EMIS( HG_E ) + + & THBAR * Tile_Data%Bidi_Emis( C, R, Tile_Data%dep2vdiff( V ) ) * DD_CONV( V ) * DTDENS1 + END IF + IF ( SFC_HONO .AND. V .EQ. HONO_HIT ) THEN + TMP_BD_EMIS( HONO_E ) = TMP_BD_EMIS( HONO_E ) + + & THBAR * Tile_Data%Bidi_Emis( C, R, Tile_Data%dep2vdiff( V ) ) * DD_CONV( V ) * DTDENS1 END IF END IF END DO +! IF ( XMOSAIC ) THEN +! DO V = 1, N_SPC_DEPV +!C --------- HET HONO RX ----------------- +! IF ( V .EQ. HNO3_HIT ) THEN +! S = HNO3_MAP +! WHERE( Tile_Data%LUFRAC( c,r,: ) .GT. 0.0 ) +! DD_FACJ( :,V ) = DTDENS1 * DD_CONV( V ) * DEPVJCR( :,V ) + PLDV_HONO / CONC( NO2_MAP,1 ) +! DDBFJ( :,V ) = DDBFJ( :,V ) + THBAR * DD_FACJ( :,V ) * CONC( S,1 ) +! END WHERE +! ELSE IF ( V .EQ. NO2_HIT ) THEN +! S = NO2_MAP +! WHERE( Tile_Data%LUFRAC( c,r,: ) .GT. 0.0 .AND. DEPVJCR( :,V ) .GT. 0.0 ) +! DDBFJ ( :,V ) = DDBFJ( :,V ) + THETA * DD_FACJ( :,V ) * CONC( S,1 ) +! END WHERE +C --------- END of HET HONO RX ---------- +! ELSE +! S = DV2DF( V ) +! WHERE( Tile_Data%LUFRAC( c,r,: ) .GT. 0.0 ) +! DDBFJ( :,V ) = DDBFJ( :,V ) + THBAR * DD_FACJ( :,V ) * CONC( S,1 ) +! END WHERE +! END IF +! END DO +! END IF ! MOSAIC +#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 ) * EMIS_OVER_VD( S ) * ( 1.0 - EFAC2( S ) ) + SA_DDBF( JSPCTAG ) = SA_DDBF( JSPCTAG ) + & + THBAR * DD_FAC( S ) * SACONC( JSPCTAG,1 ) + END IF + END DO +#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 ) - END DO + TOT_BD_EMIS( NH3_E,C,R ) = TMP_BD_EMIS( NH3_E ) END IF + IF ( HGBIDI ) THEN + TOT_BD_EMIS( HG_E,C,R ) = TMP_BD_EMIS( HG_E ) + END IF + IF ( SFC_HONO ) THEN + TOT_BD_EMIS( HONO_E,C,R ) = TMP_BD_EMIS( HONO_E ) + END IF +! IF ( XMOSAIC ) THEN +! DDEPJ( :,:,C,R ) = DDBFJ( :,: ) +! END IF + +#ifdef isam + DO JSPCTAG = 1, N_SPCTAG + SA_DDEP( C,R,JSPCTAG ) = SA_DDBF( JSPCTAG ) + END DO +#endif + 344 CONTINUE ! end loop on col C 345 CONTINUE ! end loop on row R From a4da05201249976c004f832c2ffcfaf6f66e500e Mon Sep 17 00:00:00 2001 From: Beiming Tang <51177339+btang1@users.noreply.github.com> Date: Sat, 26 Aug 2023 06:00:34 -0400 Subject: [PATCH 73/90] Add files via upload --- src/model/src/ASX_DATA_MOD.F | 112 ++++++++++++++++++++++++++++------- 1 file changed, 89 insertions(+), 23 deletions(-) diff --git a/src/model/src/ASX_DATA_MOD.F b/src/model/src/ASX_DATA_MOD.F index e3bbfca..54e5a38 100644 --- a/src/model/src/ASX_DATA_MOD.F +++ b/src/model/src/ASX_DATA_MOD.F @@ -129,17 +129,27 @@ 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 :: COSZEN ( :,: ) ! Cosine of the zenith angle - Real, Allocatable :: CFRAC ( :,: ) ! cloud fraction - +! 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] @@ -160,7 +170,7 @@ Module ASX_DATA_MOD Real, Allocatable :: RJACF ( :,:,: ) ! reciprocal full-layer Jacobian Real, Allocatable :: RRHOJ ( :,:,: ) ! reciprocal density X Jacobian Real, Allocatable :: UWINDA ( :,:,: ) ! [m/s] - Real, Allocatable :: VWINDA ( :,:,: ) ! [m/s] + Real, Allocatable :: VWINDA ( :,:,: ) ! [m/s] End Type MET_Type Type :: GRID_Type @@ -251,12 +261,22 @@ Module ASX_DATA_MOD Real, allocatable, private :: BUFF2D( :,: ) ! 2D temp var Real, allocatable, private :: BUFF3D( :,:,: ) ! 3D temp var -! 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 +! Canopy option control + CHARACTER( 20 ), SAVE :: CTM_CANOPY_SHADE = 'CTM_CANOPY_SHADEC'! 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 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 / @@ -702,6 +722,32 @@ Subroutine INIT_MET ( JDATE, JTIME ) Grid_Data%BSLP = 0.0 End If +!> 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 Canopy Shade variables' + Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) + End If + End If + !> ccccccccccccccccccccc Fengsha option!ccccccccccccccccccccc FENGSHA = ENVYN( CTM_WBDUST_FENGSHA, & 'Flag for in-line fengsha ', @@ -715,15 +761,14 @@ Subroutine INIT_MET ( JDATE, JTIME ) 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 XMSG = 'Failure allocating Fengsha variables' Call M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - End If - End If - + End If + End If !> ccccccccccccccccccccc enable backward compatiblity ccccccccccccccccccccc @@ -897,28 +942,49 @@ Subroutine GET_MET ( JDATE, JTIME, TSTEP ) call interpolate_var ('QC', jdate, jtime, Met_Data%QC) - call interpolate_var ('UWINDA', jdate, jtime, Met_Data%UWINDA) + call interpolate_var ('UWINDA', jdate, jtime, Met_Data%UWINDA) + + call interpolate_var ('VWINDA', jdate, jtime, Met_Data%VWINDA) - call interpolate_var ('VWINDA', jdate, jtime, Met_Data%VWINDA) C-------------------------------- MET_CRO_2D -------------------------------- C Vegetation and surface vars - call interpolate_var ('LAI', jdate, jtime, Met_Data%LAI) call interpolate_var ('VEG', jdate, jtime, Met_Data%VEG) call interpolate_var ('ZRUF', jdate, jtime, Met_Data%Z0) -C FENGSHA vars - If ( FENGSHA ) Then - call interpolate_var ('CLAYF', jdate, jtime, Met_Data%CLAYF) +C Canopy vars + If ( CANOPY_SHADE ) Then + call interpolate_var ('FCH', jdate, jtime, Met_Data%FCH) - call interpolate_var ('SANDF', jdate, jtime, Met_Data%SANDF) + call interpolate_var ('FRT', jdate, jtime, Met_Data%FRT) - call interpolate_var ('DRAG', jdate, jtime, Met_Data%DRAG) + call interpolate_var ('CLU', jdate, jtime, Met_Data%CLU) - call interpolate_var ('UTHR', jdate, jtime, Met_Data%UTHR) - End If + call interpolate_var ('POPU', jdate, jtime, Met_Data%POPU) + + call interpolate_var ('LAIE', jdate, jtime, Met_Data%LAIE) + + call interpolate_var ('C1R', jdate, jtime, Met_Data%C1R) + + call interpolate_var ('C2R', jdate, jtime, Met_Data%C2R) + + call interpolate_var ('C3R', jdate, jtime, Met_Data%C3R) + + call interpolate_var ('C4R', jdate, jtime, Met_Data%C4R) + + End if !(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) From de38743602a6734d57022b333614457fa9cd862e Mon Sep 17 00:00:00 2001 From: Beiming Tang <51177339+btang1@users.noreply.github.com> Date: Sat, 26 Aug 2023 06:00:48 -0400 Subject: [PATCH 74/90] Add files via upload --- src/model/src/vdiffacmx.F | 661 +++++++++++++++++++++++--------------- 1 file changed, 408 insertions(+), 253 deletions(-) diff --git a/src/model/src/vdiffacmx.F b/src/model/src/vdiffacmx.F index d6da295..beb1fee 100644 --- a/src/model/src/vdiffacmx.F +++ b/src/model/src/vdiffacmx.F @@ -17,7 +17,7 @@ !------------------------------------------------------------------------! C::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, TOT_BD_EMIS, DDEPJ, CNGRD ) + SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, ICMP, CNGRD ) C----------------------------------------------------------------------- C Asymmetric Convective Model v2 (ACM2/ACM1) -- Pleim(2006/2014) @@ -41,24 +41,26 @@ SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, TOT_BD_EMIS, DDEPJ, 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 10 Feb 19 D.Wong: removed all MY_N clauses +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 DESID_VARS, ONLY : VDEMIS_DIFF, DESID_LAYS + 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 MOSAIC_MOD, ONLY: Tile_Data +! USE BIDI_MOD +! USE LSM_MOD, ONLY: N_LUFRAC ! USE VDIFF_DIAG, NLPCR => NLPCR_MEAN -C USE PT3D_EMIS_DEFN +C USE PT3D_EMIS_DEFN USE HGRD_DEFN,only : COLSX_PE, ROWSX_PE - USE BDSNP_MOD, ONLY: GET_N_DEP - + 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, @@ -66,6 +68,13 @@ SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, TOT_BD_EMIS, DDEPJ, CNGRD ) & 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 INCLUDE SUBST_FILES_ID ! file name parameters @@ -75,11 +84,10 @@ SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, TOT_BD_EMIS, DDEPJ, CNGRD ) C Arguments: REAL, INTENT( IN ) :: DTSEC ! model time step in seconds C--- SEDDY is strictly an input, but it gets modified here - REAL, INTENT( INOUT ) :: SEDDY ( :,:,: ) ! flipped EDDYV - REAL, INTENT( INOUT ) :: DDEP ( :,:,: ) ! ddep accumulator - REAL, INTENT( INOUT ) :: TOT_BD_EMIS ( :,:,: ) ! bidi emissions accumlator - REAL, INTENT( INOUT ), OPTIONAL :: DDEPJ ( :,:,:,: ) ! ddep for mosaic - REAL, INTENT( INOUT ) :: CNGRD ( :,:,:,: ) ! cgrid replacement + REAL, INTENT( INOUT ) :: SEDDY ( :,:,: ) ! flipped EDDYV + REAL, INTENT( INOUT ) :: DDEP ( :,:,: ) ! ddep accumulator + REAL, INTENT( INOUT ) :: ICMP ( :,:,: ) ! component flux accumlator + REAL, INTENT( INOUT ) :: CNGRD ( :,:,:,: ) ! cgrid replacement C Parameters: @@ -87,7 +95,7 @@ SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, TOT_BD_EMIS, DDEPJ, CNGRD ) REAL, PARAMETER :: THETA = 0.5, & THBAR = 1.0 - THETA - REAL, PARAMETER :: EPS = 1.0E-06 +! REAL, PARAMETER :: EPS = 1.0E-06 C External Functions: None @@ -99,29 +107,27 @@ SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, TOT_BD_EMIS, DDEPJ, CNGRD ) LOGICAL, SAVE :: SPECLOG = .TRUE. ! For BDSNP REAL, ALLOCATABLE, SAVE :: DD_FAC ( : ) ! combined subexpression -! REAL, ALLOCATABLE, SAVE :: DD_FACJ ( :,: ) ! combined subexpression for mosaic REAL, ALLOCATABLE, SAVE :: DDBF ( : ) ! secondary DDEP -! REAL, ALLOCATABLE, SAVE :: DDBFJ ( :,: ) ! secondary DDEP for mosaic - REAl, ALLOCATABLE, SAVE :: TMP_BD_EMIS( : ) ! intermediate bidi emissions + 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 :: 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 @@ -131,30 +137,30 @@ SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, TOT_BD_EMIS, DDEPJ, CNGRD ) ! REAL :: LFAC3( NLAYS ) ! intermediate factor for eddy ! REAL :: LFAC4( NLAYS ) ! intermediate factor for eddy REAL, ALLOCATABLE, SAVE :: DEPVCR ( : ) ! dep vel in one cell -! REAL, ALLOCATABLE, SAVE :: DEPVJCR ( :,: ) ! dep vel in one cell for each landuse + ! one cell for each landuse category REAL, ALLOCATABLE, SAVE :: EFAC1 ( : ) REAL, ALLOCATABLE, SAVE :: EFAC2 ( : ) - REAL, ALLOCATABLE, SAVE :: EMIS_OVER_VD( : ) ! Bidi Emissions/DEPV (ppm) - REAL PLDV_HONO ! PLDV for HONO - REAL DEPV_NO2 ! dep vel of NO2 - REAL DEPV_HNO3 ! dep vel of HNO3 -! REAL FNL ! ACM2 Variable + 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 +! REAL FNL ! ACM2 Variable ! INTEGER NLP, NL, LCBL - INTEGER, SAVE :: NO2_HIT, HONO_HIT, HNO3_HIT, NO2_MAP, HNO3_MAP - INTEGER, SAVE :: NH3_HIT, HG_HIT + 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 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 -! LOGICAL, SAVE :: XMOSAIC = .FALSE. - #ifdef isam REAL :: TOTAL_SA_NO2 REAL, ALLOCATABLE, SAVE :: SA_DDBF( : ) @@ -177,11 +183,15 @@ SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, TOT_BD_EMIS, DDEPJ, CNGRD ) 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 @@ -194,6 +204,7 @@ SUBROUTINE VDIFFACMX ( DTSEC, SEDDY, DDEP, TOT_BD_EMIS, DDEPJ, CNGRD ) ! 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 @@ -220,32 +231,20 @@ END SUBROUTINE SA_TRI C set auxiliary depv arrays - ALLOCATE ( DD_FAC ( N_SPC_DEPV ), - & DDBF ( N_SPC_DEPV ), - & DEPVCR ( N_SPC_DEPV ), - & EFAC1 ( N_SPC_DEPV ), - & EFAC2 ( N_SPC_DEPV ), - & EMIS_OVER_VD ( N_SPC_DEPV ), STAT = ASTAT ) + ALLOCATE ( DD_FAC( N_SPC_DEPV ), + & DDBF ( N_SPC_DEPV ), + & DEPVCR( N_SPC_DEPV ), + & EFAC1 ( N_SPC_DEPV ), + & EFAC2 ( N_SPC_DEPV ), + & POL ( N_SPC_DEPV ), STAT = ASTAT ) IF ( ASTAT .NE. 0 ) THEN - XMSG = 'Failure allocating DD_FAC, DDBF, DEPVCR, EFAC1, EFAC2, or EMIS_OVER_VDs' + XMSG = 'Failure allocating DD_FAC, DDBF, DEPVCR, EFAC1, EFAC2, or POL' CALL M3EXIT( PNAME, MDATE, MTIME, XMSG, XSTAT1 ) END IF -! IF ( PRESENT ( DDEPJ ) ) XMOSAIC = .TRUE. - -! IF ( XMOSAIC ) THEN -! ALLOCATE ( DD_FACJ( Tile_Data%N_LUFRAC,N_SPC_DEPV ), -! & DDBFJ ( Tile_Data%N_LUFRAC,N_SPC_DEPV ), -! & DEPVJCR( Tile_Data%N_LUFRAC,N_SPC_DEPV ), STAT = ASTAT ) -! IF ( ASTAT .NE. 0 ) THEN -! XMSG = 'Failure allocating DD_FACJ, DDBFJ or DEPVJCR' -! CALL M3EXIT( PNAME, MDATE, MTIME, XMSG, XSTAT1 ) -! END IF -! END IF ! if Mosaic - - ALLOCATE ( TMP_BD_EMIS( N_BD_EMIS ), STAT = ASTAT ) + ALLOCATE ( CMPF( LCMP ), STAT = ASTAT ) IF ( ASTAT .NE. 0 ) THEN - XMSG = 'Failure allocating TMP_BD_EMIS' + XMSG = 'Failure allocating CMPF' CALL M3EXIT( PNAME, MDATE, MTIME, XMSG, XSTAT1 ) END IF @@ -266,20 +265,22 @@ END SUBROUTINE SA_TRI ! 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. 'HG' ) THEN - HG_HIT = V + ELSE IF ( DV2DF_SPC( V ) .EQ. 'O3' ) THEN + O3_HIT = V + O3_MAP = DV2DF( V ) END IF END DO @@ -328,7 +329,6 @@ END SUBROUTINE SA_TRI 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 @@ -336,6 +336,7 @@ END SUBROUTINE SA_TRI EXIT END IF END DO + ! find NH3 in tracked species IF ( SA_BIDI ) THEN DO S = 1, NSPC_SA @@ -368,14 +369,8 @@ END SUBROUTINE SA_TRI ISAM_DEPV( JSPCTAG ) = V END IF END DO - IF ( ISAM_DEPV( JSPCTAG ) .GT. 0 ) THEN - V = ISAM_DEPV( JSPCTAG ) - WRITE(LOGDEV,'(I4,4X,2(A16,1X))')JSPCTAG,ISAM_SPECIES,DV2DF_SPC( V ) - ELSE - WRITE(LOGDEV,'(I4,4X,2(A16,1X))')JSPCTAG,ISAM_SPECIES,'NONE' - END IF END DO - WRITE(LOGDEV,'(/,A4,1X,A13,1X,A16))')'ITAG','INDEX_SA_HONO','ISAM_SPECIES' + 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 @@ -388,7 +383,6 @@ END SUBROUTINE SA_TRI 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 @@ -404,15 +398,57 @@ END SUBROUTINE SA_TRI 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 ------------------------------------------- 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 @@ -426,19 +462,19 @@ END SUBROUTINE SA_TRI !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)) @@ -453,7 +489,7 @@ END SUBROUTINE SA_TRI ! & 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 ) +! CALL M3EXIT( PNAME, MDATE, MTIME, XMSG, XSTAT2 ) ! END IF ! IF ( ( FNL .LE. 0.0 ) .OR. ! never gonna happen for CONVCT @@ -461,7 +497,7 @@ END SUBROUTINE SA_TRI ! & ( 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 @@ -472,7 +508,7 @@ END SUBROUTINE SA_TRI ! MBARKS(LCBL) = MDWN(LCBL) ! MDWN(LCBL+1) = 0.0 -!C Modify Timestep for ACM +!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 ) @@ -490,11 +526,32 @@ END SUBROUTINE SA_TRI DFACQ = THBAR * DTS !#ifdef Verbose_Vdiff -! IF ( R .EQ. MY_NROWS / 2 .AND. C .EQ. MY_NCOLS / 2 ) +! 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 @@ -528,18 +585,7 @@ END SUBROUTINE SA_TRI END DO END IF #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 - + EMIS = 0.0 ! array assignment IF ( DESID_N_SRM .GE. 1 ) & EMIS( :,1:DESID_LAYS ) = DTS * VDEMIS_DIFF( :,:,C,R ) @@ -547,10 +593,10 @@ END SUBROUTINE SA_TRI #ifdef isam SAEMIS = 0.0 -! modify ground emissions for bidirectional species (for bidi, BIDI_VDEMIS > 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 ) - & = Tile_Data%Bidi_Emis( C, R, Tile_Data%dep2vdiff( PLDV_INDEX_NH3 ) ) + & = PLDV(PLDV_INDEX_NH3,C,R) * Met_Data%RDEPVHT( C,R ) END IF ! collapse ISAM emissions array @@ -563,43 +609,41 @@ END SUBROUTINE SA_TRI 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 ) - EMIS_OVER_VD = 0.0 + RP = DFACP * Met_Data%RDEPVHT( C,R ) + RQ = DFACQ * Met_Data%RDEPVHT( C,R ) DO V = 1, N_SPC_DEPV DDBF( V ) = DDEP( V,C,R ) - DEPVCR( V ) = Tile_Data%Vd_Fac( Tile_Data%dep2vdiff( V ) ) * - & Tile_Data%Grd_Vd( C,R,Tile_Data%dep2vdiff( V ) ) + DEPVCR( V ) = DEPV( V,C,R ) DD_FAC( V ) = DTDENS1 * DD_CONV( V ) * DEPVCR( V ) EFAC1 ( V ) = EXP( -DEPVCR( V ) * RP ) EFAC2 ( V ) = EXP( -DEPVCR( V ) * RQ ) - If( Tile_Data%Bidi_Emis( C, R, Tile_Data%dep2vdiff( V ) ) .Gt. 0.0 ) Then - If(DEPVCR( V ) .Eq. 0.0) Then - Write(Logdev,*) 'Warning: A deposition velocity of 0 m/s was detected with a production term greater' - Write(Logdev,*) 'than zero. Check for DEPV_FACs less than zero in the species name list for model species:' - Write(Logdev,*) DV2DF_SPC( V ), 'depvcr', DEPVCR( V ), 'bidi emissions', - & Tile_Data%Bidi_Emis( C, R, Tile_Data%dep2vdiff( V ) ) - DEPVCR( V ) = tiny( 0.0 ) - End If - EMIS_OVER_VD( V ) = Tile_Data%Bidi_Emis( C, R, Tile_Data%dep2vdiff( V ) ) / DEPVCR( V ) - End If - IF ( ABFLUX ) THEN - TMP_BD_EMIS( NH3_E ) = TOT_BD_EMIS( NH3_E,C,R ) - END IF - IF ( HGBIDI ) THEN - TMP_BD_EMIS( HG_E ) = TOT_BD_EMIS( HG_E,C,R ) - END IF - IF ( SFC_HONO ) THEN - TMP_BD_EMIS( HONO_E ) = TOT_BD_EMIS( HONO_E,C,R ) - END IF + POL ( V ) = PLDV( V,C,R ) / DEPVCR( V ) +#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 - PLDV_HONO = Tile_Data%Bidi_Emis( C, R, Tile_Data%dep2vdiff( HONO_HIT ) ) +#endif #ifdef isam DO JSPCTAG = 1, N_SPCTAG @@ -629,47 +673,40 @@ END SUBROUTINE SA_TRI ! 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 -!C ---------------------------------------------------------------------- - -! IF ( XMOSAIC ) THEN -! DDBFJ( :,: ) = DDEPJ( :,:,C,R ) -! DO L = 1, Tile_Data%n_lufrac -! DEPVJCR( L,: ) = Tile_Data%Vd_Fac( Tile_Data%dep2vdiff ) * -! & Tile_Data%Lu_Vd( C,R,Tile_Data%dep2vdiff,L ) -! DD_FACJ( L,: ) = DTDENS1 * DD_CONV( : ) * DEPVJCR( L,: ) -! END DO -! END IF - -!C----------------------------------------------------------------------- -! DO 301 NL = 1, NLP ! loop over sub time +! DO 301 NL = 1, NLP ! loop over sub time - DO V = 1, N_SPC_DEPV + DO V = 1, N_SPC_DEPV C --------- HET HONO RX ----------------- - C Use special treatment for HNO3 C HNO3 produced via the heterogeneous reaction sticks on surfaces and C is accounted as depositional loss; calculate increased deposition loss IF ( V .EQ. HNO3_HIT ) THEN S = HNO3_MAP - CONC( S,1 ) = EMIS_OVER_VD( V ) + ( CONC( S,1 ) - EMIS_OVER_VD( V ) ) * EFAC1( V ) - DEPV_HNO3 = DEPVCR( V ) + PLDV_HONO / CONC( NO2_MAP,1 ) + CONC( S,1 ) = POL( V ) + ( CONC( S,1 ) - POL( V ) ) * EFAC1( V ) + 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 ) + 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 @@ -677,19 +714,38 @@ END SUBROUTINE SA_TRI C to the regular deposition velocity (increased dep. vel.). This will C reduce the NO2 conc. in the atmosphere without affecting the depositional loss. ELSE IF ( V .EQ. NO2_HIT ) THEN - S = NO2_MAP - DEPV_NO2 = DEPVCR( V ) + 2.0 * PLDV_HONO / CONC( S,1 ) - EFAC1 ( V ) = EXP( -DEPV_NO2 * RP ) - EFAC2 ( V ) = EXP( -DEPV_NO2 * RQ ) - EMIS_OVER_VD( V ) = Tile_Data%Bidi_Emis( C, R, Tile_Data%dep2vdiff( V ) ) / DEPV_NO2 - CONC( S,1 ) = EMIS_OVER_VD( V ) + ( CONC( S,1 ) - EMIS_OVER_VD( V ) ) * EFAC1( V ) - DDBF( V ) = DDBF( V ) + THETA * DD_FAC( V ) * CONC( S,1 ) + S = NO2_MAP + DEPV_NO2 = DEPVCR( V ) + 2.0 * PLDV_HONO / CONC( S,1 ) + EFAC1 ( V ) = EXP( -DEPV_NO2 * RP ) + EFAC2 ( V ) = EXP( -DEPV_NO2 * RQ ) + 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 @@ -732,55 +788,34 @@ END SUBROUTINE SA_TRI END IF !end BDSNP check S = DV2DF( V ) - CONC( S,1 ) = EMIS_OVER_VD( V ) + ( CONC( S,1 ) - EMIS_OVER_VD( V ) ) * EFAC1( V ) - DDBF( V ) = DDBF( V ) + THETA * DD_FAC( V ) * CONC( S,1 ) + CONC( S,1 ) = POL( V ) + ( CONC( S,1 ) - POL( V ) ) * EFAC1( V ) + 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 - TMP_BD_EMIS( NH3_E ) = TMP_BD_EMIS( NH3_E ) + - & THETA * Tile_Data%Bidi_Emis( C, R, Tile_Data%dep2vdiff( V ) ) * DD_CONV( V ) * DTDENS1 - END IF - IF ( HGBIDI .AND. V .EQ. HG_HIT ) THEN - TMP_BD_EMIS( HG_E ) = TMP_BD_EMIS( HG_E ) + - & THETA * Tile_Data%Bidi_Emis( C, R, Tile_Data%dep2vdiff( V ) ) * DD_CONV( V ) * DTDENS1 - END IF - IF ( SFC_HONO .AND. V .EQ. HONO_HIT ) THEN - TMP_BD_EMIS( HONO_E ) = TMP_BD_EMIS( HONO_E ) + - & THETA * Tile_Data%Bidi_Emis( C, R, Tile_Data%dep2vdiff( V ) ) * DD_CONV( V ) * DTDENS1 - END IF END IF END DO -! IF ( XMOSAIC ) THEN -! DO V = 1, N_SPC_DEPV -!C --------------- HET HONO RX ----------------- -! IF ( V .EQ. HNO3_HIT ) THEN -! S = HNO3_MAP -! WHERE( Tile_Data%LUFRAC( c,r,: ) .GT. 0.0 ) -! DD_FACJ( :,V ) = DTDENS1 * DD_CONV( V ) * DEPVJCR( :,V ) + PLDV_HONO / CONC( NO2_MAP,1 ) -! DDBFJ( :,V ) = DDBFJ( :,V ) + THETA * DD_FACJ( :,V ) * CONC( S,1 ) -! END WHERE -! ELSE IF ( V .EQ. NO2_HIT ) THEN -! S = NO2_MAP -! WHERE( Tile_Data%LUFRAC( c,r,: ) .GT. 0.0 .AND. DEPVJCR( :,V ) .GT. 0.0 ) -! DDBFJ ( :,V ) = DDBFJ( :,V ) + THETA * DD_FACJ( :,V ) * CONC( S,1 ) -! END WHERE -!C --------------- END of HET HONO RX ---------- -! ELSE -! S = DV2DF( V ) -! WHERE( Tile_Data%LUFRAC( c,r,: ) .GT. 0.0 ) -! DDBFJ( :,V ) = DDBFJ( :,V ) -! & + THETA * DD_FACJ( :,V ) * CONC( S,1 ) -! END WHERE -! END IF -! END DO -! END IF ! MOSAIC - 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 ) + 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 @@ -789,12 +824,32 @@ END SUBROUTINE SA_TRI S = ISAM_DEPV( JSPCTAG ) IF ( S .GT. 0 ) THEN SACONC( JSPCTAG,1 ) = SACONC( JSPCTAG,1 ) * EFAC1( S ) - & + SAFRAC( JSPCTAG ) * EMIS_OVER_VD( S ) * ( 1.0 - 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 @@ -805,15 +860,22 @@ END SUBROUTINE SA_TRI !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 ) -! END DO +#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 @@ -829,6 +891,14 @@ END SUBROUTINE SA_TRI ! & - 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 @@ -847,10 +917,22 @@ END SUBROUTINE SA_TRI 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 @@ -864,6 +946,12 @@ END SUBROUTINE SA_TRI ! 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 @@ -880,6 +968,13 @@ END SUBROUTINE SA_TRI ! 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 @@ -896,6 +991,14 @@ END SUBROUTINE SA_TRI ! & + 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 @@ -911,6 +1014,12 @@ END SUBROUTINE SA_TRI ! 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 @@ -924,10 +1033,22 @@ END SUBROUTINE SA_TRI 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 @@ -936,80 +1057,109 @@ END SUBROUTINE SA_TRI #endif ! END DO + + + + + + DO V = 1, N_SPC_DEPV C --------- HET HONO RX ----------------- IF ( V .EQ. HNO3_HIT ) THEN S = HNO3_MAP - CONC( S,1 ) = EMIS_OVER_VD( V ) + ( CONC( S,1 ) - EMIS_OVER_VD( V ) ) * EFAC2( V ) - DDBF( V ) = DDBF( V ) + THBAR * DD_FAC( V ) * CONC( S,1 ) + 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 ) = EMIS_OVER_VD( V ) + ( CONC( S,1 ) - EMIS_OVER_VD( V ) ) * EFAC2( V ) - DDBF( V ) = DDBF( V ) + THBAR * DD_FAC( V ) * CONC( S,1 ) + 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 ) = EMIS_OVER_VD( V ) + ( CONC( S,1 ) - EMIS_OVER_VD( V ) ) * EFAC2( V ) - DDBF( V ) = DDBF( V ) + THBAR * DD_FAC( V ) * CONC( S,1 ) - IF ( ABFLUX .AND. V .EQ. NH3_HIT ) THEN - TMP_BD_EMIS( NH3_E ) = TMP_BD_EMIS( NH3_E ) + - & THBAR * Tile_Data%Bidi_Emis( C, R, Tile_Data%dep2vdiff( V ) ) * DD_CONV( V ) * DTDENS1 - END IF - IF ( HGBIDI .AND. V .EQ. HG_HIT ) THEN - TMP_BD_EMIS( HG_E ) = TMP_BD_EMIS( HG_E ) + - & THBAR * Tile_Data%Bidi_Emis( C, R, Tile_Data%dep2vdiff( V ) ) * DD_CONV( V ) * DTDENS1 - END IF - IF ( SFC_HONO .AND. V .EQ. HONO_HIT ) THEN - TMP_BD_EMIS( HONO_E ) = TMP_BD_EMIS( HONO_E ) + - & THBAR * Tile_Data%Bidi_Emis( C, R, Tile_Data%dep2vdiff( V ) ) * DD_CONV( V ) * DTDENS1 - END IF - + CONC( S,1 ) = POL( V ) + ( CONC( S,1 ) - POL( V ) ) * EFAC2( V ) + 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 - -! IF ( XMOSAIC ) THEN -! DO V = 1, N_SPC_DEPV -!C --------- HET HONO RX ----------------- -! IF ( V .EQ. HNO3_HIT ) THEN -! S = HNO3_MAP -! WHERE( Tile_Data%LUFRAC( c,r,: ) .GT. 0.0 ) -! DD_FACJ( :,V ) = DTDENS1 * DD_CONV( V ) * DEPVJCR( :,V ) + PLDV_HONO / CONC( NO2_MAP,1 ) -! DDBFJ( :,V ) = DDBFJ( :,V ) + THBAR * DD_FACJ( :,V ) * CONC( S,1 ) -! END WHERE -! ELSE IF ( V .EQ. NO2_HIT ) THEN -! S = NO2_MAP -! WHERE( Tile_Data%LUFRAC( c,r,: ) .GT. 0.0 .AND. DEPVJCR( :,V ) .GT. 0.0 ) -! DDBFJ ( :,V ) = DDBFJ( :,V ) + THETA * DD_FACJ( :,V ) * CONC( S,1 ) -! END WHERE -C --------- END of HET HONO RX ---------- -! ELSE -! S = DV2DF( V ) -! WHERE( Tile_Data%LUFRAC( c,r,: ) .GT. 0.0 ) -! DDBFJ( :,V ) = DDBFJ( :,V ) + THBAR * DD_FACJ( :,V ) * CONC( S,1 ) -! END WHERE -! END IF -! END DO -! END IF ! MOSAIC #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 ) * EMIS_OVER_VD( S ) * ( 1.0 - 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 -!301 CONTINUE ! end sub time loop DO L = 1, NLAYS DO V = 1, N_SPC_DIFF @@ -1021,6 +1171,7 @@ END SUBROUTINE SA_TRI ISAM( C,R,L,S_SPCTAG( JSPCTAG ),T_SPCTAG( JSPCTAG ) ) = SACONC( JSPCTAG,L ) END IF END DO + #endif END DO @@ -1028,26 +1179,30 @@ END SUBROUTINE SA_TRI DDEP( V,C,R ) = DDBF( V ) END DO - IF ( ABFLUX ) THEN - TOT_BD_EMIS( NH3_E,C,R ) = TMP_BD_EMIS( NH3_E ) - END IF - IF ( HGBIDI ) THEN - TOT_BD_EMIS( HG_E,C,R ) = TMP_BD_EMIS( HG_E ) - END IF - IF ( SFC_HONO ) THEN - TOT_BD_EMIS( HONO_E,C,R ) = TMP_BD_EMIS( HONO_E ) - END IF - -! IF ( XMOSAIC ) THEN -! DDEPJ( :,:,C,R ) = DDBFJ( :,: ) -! END IF - #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 + + 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 From 584144f89c87e485fe1d7d38d9fc098e5f6fff57 Mon Sep 17 00:00:00 2001 From: Beiming Tang <51177339+btang1@users.noreply.github.com> Date: Sun, 27 Aug 2023 19:21:59 -0400 Subject: [PATCH 75/90] Update ASX_DATA_MOD.F --- src/model/src/ASX_DATA_MOD.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/model/src/ASX_DATA_MOD.F b/src/model/src/ASX_DATA_MOD.F index 54e5a38..0a03e63 100644 --- a/src/model/src/ASX_DATA_MOD.F +++ b/src/model/src/ASX_DATA_MOD.F @@ -262,7 +262,7 @@ Module ASX_DATA_MOD Real, allocatable, private :: BUFF3D( :,:,: ) ! 3D temp var ! Canopy option control - CHARACTER( 20 ), SAVE :: CTM_CANOPY_SHADE = 'CTM_CANOPY_SHADEC'! env var for in-line + 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 From 2f507f3da8fe6babf7972bb81016a970b072e471 Mon Sep 17 00:00:00 2001 From: Beiming Tang <51177339+btang1@users.noreply.github.com> Date: Sun, 27 Aug 2023 19:24:21 -0400 Subject: [PATCH 76/90] Update o3totcol.f --- src/model/src/o3totcol.f | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/model/src/o3totcol.f b/src/model/src/o3totcol.f index 5ab1134..0e069e9 100644 --- a/src/model/src/o3totcol.f +++ b/src/model/src/o3totcol.f @@ -116,8 +116,8 @@ subroutine o3totcol ( latitude, longitude, jdate, jtime, ozone ) ! read nlat, nlon rewind( tmunit ) - read( tmunit, '(5x,i7)') label,nlat - read( tmunit, '(5x,i7)') 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 From d8f049ace2f116f426ed057184771608a2008722 Mon Sep 17 00:00:00 2001 From: Beiming Tang <51177339+btang1@users.noreply.github.com> Date: Fri, 1 Sep 2023 01:48:23 -0400 Subject: [PATCH 77/90] Update vdiffacmx.F comment a 'end do', after that, code compiled successfully --- src/model/src/vdiffacmx.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/model/src/vdiffacmx.F b/src/model/src/vdiffacmx.F index beb1fee..3ec8114 100644 --- a/src/model/src/vdiffacmx.F +++ b/src/model/src/vdiffacmx.F @@ -875,7 +875,7 @@ END SUBROUTINE SA_TRI & + LFAC2( L ) * SENS( V,L+1,NP ) END DO #endif - END DO +! END DO #ifdef isam DO JSPCTAG = 1, N_SPCTAG From 9aa4bff70e7138e2166d39af55a4209f191e49a5 Mon Sep 17 00:00:00 2001 From: Beiming Tang <51177339+btang1@users.noreply.github.com> Date: Fri, 1 Sep 2023 01:54:34 -0400 Subject: [PATCH 78/90] Update aqm_files.cmake turn on according changed codes in local src/ folder --- aqm_files.cmake | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/aqm_files.cmake b/aqm_files.cmake index b23a84f..394512d 100644 --- a/aqm_files.cmake +++ b/aqm_files.cmake @@ -237,7 +237,7 @@ list(APPEND aqm_CCTM_files ${VDIFF}/VDIFF_DATA.F ${VDIFF}/VDIFF_DIAG.F ${VDIFF}/VDIFF_MAP.F - ${VDIFF}/vdiffacmx.F + #${VDIFF}/vdiffacmx.F #${VDIFF}/vdiffproc.F ${VDIFF}/../../biog/megan3/BDSNP_MOD.F ${localCCTM}/o3totcol.f @@ -251,7 +251,8 @@ list(APPEND aqm_CCTM_files ${localCCTM}/ASX_DATA_MOD.F ${localCCTM}/DUST_EMIS.F ${localCCTM}/AERO_PHOTDATA.F - ${localCCTM}/phot.F + ${localCCTM}/vdiffacmx.F + #${localCCTM}/phot.F ${localCCTM}/centralized_io_module.F ${localCCTM}/centralized_io_util_module.F ) From 18916a26dc8cf766009f82f293f97a76ecb70495 Mon Sep 17 00:00:00 2001 From: Wei Li Date: Fri, 20 Oct 2023 19:06:15 -0500 Subject: [PATCH 79/90] add localized files --- src/model/src/PT3D_DEFN.F | 106 +++---- src/model/src/PT3D_FIRE_DEFN.F | 223 ++++--------- src/model/src/PT3D_STKS_DEFN.F | 114 ++----- src/model/src/RUNTIME_VARS.F | 29 +- src/model/src/centralized_io_module.F | 49 ++- src/model/src/get_env_mod.f90 | 438 ++++++++++++++++++++++++++ 6 files changed, 628 insertions(+), 331 deletions(-) create mode 100644 src/model/src/get_env_mod.f90 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..a27ff2f 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,11 +170,12 @@ 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 ) + PTLAYS = EMLYRS FIRSTIME = .FALSE. END IF @@ -400,13 +399,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 +414,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 +450,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/RUNTIME_VARS.F b/src/model/src/RUNTIME_VARS.F index eee3d62..264b803 100644 --- a/src/model/src/RUNTIME_VARS.F +++ b/src/model/src/RUNTIME_VARS.F @@ -73,7 +73,7 @@ MODULE RUNTIME_VARS PUBLIC - INTEGER :: OUTDEV = 6 ! File Unit for Standard Output + 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 @@ -97,7 +97,7 @@ MODULE RUNTIME_VARS ! this is for MPAS LOGICAL :: ncd_64bit_offset = .FALSE. - INTEGER :: cell_num !beiming tang + !----------------------------------------------------------------------------------- !>> Define Environment Variables for Controlling CMAQ Processes !----------------------------------------------------------------------------------- @@ -341,7 +341,7 @@ SUBROUTINE INIT_ENV_VARS( JDATE, JTIME ) CALL MPI_COMM_SIZE ( MPI_COMM_WORLD, TOTPE, ERROR ) #else MYPE = 0 - TOTPE = 0 + TOTPE = 1 !(AQM change from 0) #endif IF ( MYPE .EQ. 0 ) VARDEV = OUTDEV @@ -349,8 +349,8 @@ SUBROUTINE INIT_ENV_VARS( JDATE, JTIME ) ! 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() + ! 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" ) @@ -609,7 +609,7 @@ SUBROUTINE INIT_ENV_VARS( JDATE, JTIME ) 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 ) !this could be wrong, why char before NWAVE, beiming??? + CALL GET_ENV( 'NWAVE_PHOTDIAG', NWAVE, WAVE_ENV, VARDEV ) END IF ! Get flag to use core-shell mixing model for aerosol optical properties @@ -925,17 +925,18 @@ SUBROUTINE INIT_ENV_VARS( JDATE, JTIME ) CALL M3EXIT( 'INIT_ENV_VARS', JDATE, JTIME, XMSG, EXIT_STATUS ) END IF - IF ( OCEAN_CHEM ) THEN - IF ( (INDEX( MECHNAME, 'CB6R5M_AE7_AQ') .GT. 0 ) .OR. - & (INDEX( MECHNAME, 'CB6R5_AE7_AQ' ) .GT. 0) ) then - USE_MARINE_GAS_EMISSION = .TRUE. - ENDIF - ENDIF + ! 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) + call get_env (ncd_64bit_offset, 'ncd_64bit_offset', .false., vardev) + call get_env( cell_num, 'cell_num', 1, vardev) #endif #ifdef twoway diff --git a/src/model/src/centralized_io_module.F b/src/model/src/centralized_io_module.F index 6121fbc..c0605e6 100644 --- a/src/model/src/centralized_io_module.F +++ b/src/model/src/centralized_io_module.F @@ -317,7 +317,7 @@ MODULE CENTRALIZED_IO_MODULE & ,retrieve_ocean_data_mpas #else & ,boundary_files_setup, - & retrieve_grid_cro_2d_data, + & retrieve_grid_cro_2d_data, !public this function (AQM) & retrieve_grid_dot_2d_data, & retrieve_ocean_data #endif @@ -560,6 +560,7 @@ subroutine gridded_files_setup file_xcell(f_met) = xcell3d file_ycell(f_met) = ycell3d + IF (INDEX1( 'TSEASFC', NVARS3D, VNAME3D ) .gt. 0) then TSEASFC_AVAIL = .true. adj = 0 @@ -775,8 +776,9 @@ subroutine gridded_files_setup ! emission file, could be one or multiple layer - call desid_read_namelist() - call desid_init_regions() + !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), @@ -1347,7 +1349,7 @@ subroutine retrieve_time_dep_gridded_data (jdate, jtime, vname) Call M3EXIT( PNAME, 0, 0, XMSG, XSTAT1 ) END IF #else - If ( .Not. XTRACT3( MET_CRO_2D, 'SLTYP', + 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 @@ -1524,6 +1526,7 @@ subroutine retrieve_time_dep_gridded_data (jdate, jtime, vname) 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 @@ -1586,7 +1589,7 @@ subroutine retrieve_time_dep_gridded_data (jdate, jtime, vname) 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), @@ -1596,6 +1599,7 @@ subroutine retrieve_time_dep_gridded_data (jdate, jtime, vname) CALL M3EXIT ( PNAME, data_jdate, data_jtime, XMSG, XSTAT1 ) END IF + #endif else if (cio_grid_var_name(v,2) == 'ic') then @@ -1650,7 +1654,7 @@ subroutine retrieve_time_dep_gridded_data (jdate, jtime, vname) cio_grid_data_tstamp(1, buf_loc, v) = data_jdate cio_grid_data_tstamp(2, buf_loc, v) = data_jtime - end do + end do !end v #ifndef mpas ! assign TEMPG to TSEASFC when TSEASFC is not available in the input file @@ -4693,7 +4697,7 @@ end subroutine megan_setup subroutine centralized_io_init (in_ncols) use lsm_mod, only: n_lufrac, init_lsm - USE UTILIO_DEFN !, only : m3exit !beiming tang + USE UTILIO_DEFN, only : m3exit USE RUNTIME_VARS, only: log_heading, logdev #ifdef mpas @@ -4801,9 +4805,9 @@ subroutine centralized_io_init (in_ncols) call gridded_files_setup - call boundary_files_setup + !call boundary_files_setup !(AQM) - call stack_files_setup + !call stack_files_setup !(AQM) if (BIOGEMIS_BEIS) then call biogemis_setup @@ -4841,7 +4845,6 @@ subroutine centralized_io_init (in_ncols) call soilinp_setup end if - call retrieve_grid_cro_2d_data call retrieve_grid_dot_2d_data @@ -4860,9 +4863,9 @@ subroutine centralized_io_init (in_ncols) #ifdef mpas call retrieve_stack_data_mpas (cio_model_sdate, cio_model_stime) #else - call retrieve_boundary_data (cio_model_sdate, cio_model_stime) + !call retrieve_boundary_data (cio_model_sdate, cio_model_stime) !(AQM) - call retrieve_stack_data (cio_model_sdate, cio_model_stime) + !call retrieve_stack_data (cio_model_sdate, cio_model_stime) !(AQM) #endif end subroutine centralized_io_init @@ -6282,6 +6285,7 @@ subroutine r_interpolate_var_2d (vname, date, time, data, 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 @@ -6290,12 +6294,20 @@ subroutine r_interpolate_var_2d (vname, date, time, data, 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) - 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 @@ -6353,8 +6365,10 @@ subroutine r_interpolate_var_2d (vname, date, time, data, 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 + + 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 @@ -6465,6 +6479,7 @@ subroutine i_interpolate_var_2d (vname, date, time, data) 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) @@ -6887,8 +6902,8 @@ subroutine r_interpolate_var_3d (vname, date, time, data, fname) 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 + 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 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 From a419a75c184bd13f68184ea6f5709db631a81c8f Mon Sep 17 00:00:00 2001 From: Wei Li Date: Fri, 20 Oct 2023 19:18:07 -0500 Subject: [PATCH 80/90] Add other modified files --- CMakeLists.txt | 2 + aqm_files.cmake | 40 ++- src/aqm_comp_mod.F90 | 21 +- src/drv/cmaq_mod.F90 | 142 +++++----- src/drv/cmaq_model_mod.F90 | 19 +- src/io/ioapi/IODECL3.EXT | 319 ++++++++++++++++++++++ src/io/ioapi/daymon.F | 102 +++++++ src/io/ioapi/m3err.F | 59 ++++ src/io/ioapi/m3utilio.F90 | 53 +++- src/model/src/PTMAP.F | 341 ----------------------- src/shr/aqm_config_mod.F90 | 51 ++++ src/shr/aqm_emis_mod.F90 | 27 +- src/shr/aqm_methods.F90 | 538 ++++++++++++++++++++++++++++++++----- 13 files changed, 1217 insertions(+), 497 deletions(-) create mode 100644 src/io/ioapi/IODECL3.EXT create mode 100644 src/io/ioapi/daymon.F create mode 100644 src/io/ioapi/m3err.F delete mode 100644 src/model/src/PTMAP.F diff --git a/CMakeLists.txt b/CMakeLists.txt index 0682a02..7df5792 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -93,6 +93,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,6 +106,7 @@ target_compile_definitions(CCTM PUBLIC SUBST_FILES_ID="FILES_CTM.EXT" WR_INIT=DUMMY_WR_INIT verbose_aero verbose_gas + verbose_cio # mpas _AQM_) diff --git a/aqm_files.cmake b/aqm_files.cmake index 394512d..127f003 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,16 +60,19 @@ 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/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") @@ -86,12 +90,14 @@ set(STENEX "${CCTM_ROOT}/STENEX/noop") set(UTIL "${CCTM_ROOT}/util/util") 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_nml_modes.F ${AERO}/AEROMET_DATA.F + ${AERO}/AERO_EMIS.F ${AERO}/AEROSOL_CHEMISTRY.F ${AERO}/aero_subs.F ${AERO}/coags.f @@ -111,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 @@ -144,12 +157,14 @@ list(APPEND aqm_CCTM_files ${EMIS}/UDTYPES.F ${EMIS}/biog_emis_param_module.F ${EMIS}/CMAQ_Control_DESID.nml - #${EMIS}/desid_module.F ${EMIS}/desid_param_module.F ${EMIS}/desid_util.F ${EMIS}/desid_vars.F + ${EMIS}/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}/hrdata_mod.F @@ -219,10 +234,11 @@ list(APPEND aqm_CCTM_files ${STENEX}/noop_util_module.f ${UTIL}/findex.f ${UTIL}/log_header.F - ${UTIL}/get_env_mod.f90 + #${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 @@ -237,22 +253,22 @@ list(APPEND aqm_CCTM_files ${VDIFF}/VDIFF_DATA.F ${VDIFF}/VDIFF_DIAG.F ${VDIFF}/VDIFF_MAP.F - #${VDIFF}/vdiffacmx.F - #${VDIFF}/vdiffproc.F - ${VDIFF}/../../biog/megan3/BDSNP_MOD.F + ${VDIFF}/vdiffproc.F + #${CIO}/centralized_io_module.F ${localCCTM}/o3totcol.f - ${localCCTM}/AERO_EMIS.F - ${localCCTM}/RUNTIME_VARS.F + #${localCCTM}/AERO_EMIS.F #${localCCTM}/PTMAP.F #${localCCTM}/PT3D_DATA_MOD.F - #${localCCTM}/PT3D_DEFN.F - #${localCCTM}/PT3D_FIRE_DEFN.F - #${localCCTM}/PT3D_STKS_DEFN.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}/vdiffacmx.F - #${localCCTM}/phot.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/src/aqm_comp_mod.F90 b/src/aqm_comp_mod.F90 index ecc81c5..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 diff --git a/src/drv/cmaq_mod.F90 b/src/drv/cmaq_mod.F90 index ac47610..ff3b705 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,38 @@ 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 + 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 + 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 +562,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 +578,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 +836,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/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/shr/aqm_config_mod.F90 b/src/shr/aqm_config_mod.F90 index 4147b7d..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 @@ -140,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) @@ -538,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) diff --git a/src/shr/aqm_emis_mod.F90 b/src/shr/aqm_emis_mod.F90 index 711264d..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 @@ -1617,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 @@ -1720,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 @@ -1736,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 7412e7d..49c1278 100644 --- a/src/shr/aqm_methods.F90 +++ b/src/shr/aqm_methods.F90 @@ -86,7 +86,6 @@ LOGICAL FUNCTION DESC3( FNAME ) IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: FNAME - CHARACTER(LEN=len(FNAME)) :: FNAME_TRIM !(Wei Li) INCLUDE SUBST_FILES_ID @@ -107,8 +106,7 @@ LOGICAL FUNCTION DESC3( FNAME ) STIME3D = 0 TSTEP3D = 0 - FNAME_TRIM = TRIM(FNAME_TRIM) - !!Replace INIT_GASC,AERO,NONR,TRAC to INIT_CONC_1 (Wei Li) + !!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 @@ -126,21 +124,31 @@ LOGICAL FUNCTION DESC3( FNAME ) call aqm_emis_desc("biogenic", NLAYS3D, NVARS3D, VNAME3D, UNITS3D) -! EMIS_1 is not used anymore. Change to other env variables. (Wei Li) - ELSE IF ( ( (FNAME_TRIM(1:8) .EQ. 'GR_EMIS_') .AND. (len(FNAME_TRIM) .EQ. 11 )) .OR. & - ( (FNAME_TRIM(1:9) .EQ. 'STK_EMIS_').AND. (len(FNAME_TRIM) .EQ. 12 )) ) THEN - +! 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 + + SDATE3D = config % ctm_stdate + STIME3D = config % ctm_sttime + TSTEP3D = config % ctm_tstep - call aqm_emis_desc("point-source", NLAYS=EMLAYS) + 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 ) = & @@ -221,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) @@ -366,14 +374,14 @@ logical function envyn(name, description, defaultval, status) envyn = .false. em => aqm_emis_get("biogenic") if (associated(em)) envyn = (trim(em % period) == "summer") - ! case ('CTM_AOD') - ! envyn = config % ctm_aod + case ('CTM_AOD') + envyn = config % ctm_aod case ('CTM_BIOGEMIS') envyn = aqm_emis_ispresent("biogenic") case ('CTM_DEPVFILE') envyn = config % ctm_depvfile - ! case ('CTM_PMDIAG') - ! envyn = config % ctm_pmdiag + case ('CTM_PMDIAG') + envyn = config % ctm_pmdiag case ('CTM_PHOTODIAG') envyn = config % ctm_photodiag case ('CTM_PT3DEMIS') @@ -569,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) @@ -591,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") @@ -621,7 +638,6 @@ logical function interpx( fname, vname, pname, & implicit none character(len=*), intent(in) :: fname, vname, pname - CHARACTER(LEN=len(fname)) :: FNAME_TRIM !(Wei Li) integer, intent(in) :: col0, col1, row0, row1, lay0, lay1 integer, intent(in) :: jdate, jtime real, intent(out) :: buffer(*) @@ -646,7 +662,6 @@ logical function interpx( fname, vname, pname, & ! -- begin interpx = .false. - FNAME_TRIM = TRIM(fname) !(Wei Li) lbuf = (col1-col0+1) * (row1-row0+1) * (lay1-lay0+1) buffer(1:lbuf) = 0. @@ -861,14 +876,15 @@ logical function interpx( fname, vname, pname, & return end select -! EMIS_1 is not used anymore. Change to other env variables. (Wei Li) - else if ( ( (FNAME_TRIM(1:8) .EQ. 'GR_EMIS_') .AND. (len(FNAME_TRIM) .EQ. 11 )) ) then +! 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) @@ -1050,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 @@ -1074,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 @@ -1095,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 @@ -1110,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 @@ -1133,7 +1501,7 @@ LOGICAL FUNCTION XTRACT3 ( FNAME, VNAME, & end do END IF - !!Replace INIT_GASC,AERO,NONR,TRAC to INIT_CONC_1 (Wei Li) + !!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) @@ -1171,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 @@ -1231,24 +1636,29 @@ LOGICAL FUNCTION WRITE3_REAL2D( FNAME, VNAME, JDATE, JTIME, BUFFER ) type(aqm_state_type), pointer :: stateOut WRITE3_REAL2D = .TRUE. -!CTM_AOD_1 seems to be removed. (Wei Li) -! IF ( TRIM( FNAME ) .EQ. TRIM( CTM_AOD_1 ) ) THEN -! +!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( 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 -! + ! stateOut % aod = BUFFER -! + ! END IF -! + ! WRITE3_REAL2D = .TRUE. -! + ! END IF END FUNCTION WRITE3_REAL2D @@ -1274,32 +1684,34 @@ 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. -!CTM_PMDIAG_1 seems to be removed. (Wei Li) -! IF ( TRIM( FNAME ) .EQ. TRIM( CTM_PMDIAG_1 ) ) THEN -! -! WRITE3_REAL4D = .FALSE. -! -! IF ( TRIM( VNAME ) .EQ. TRIM( ALLVAR3 ) ) THEN -! -! nullify(config) -! nullify(stateOut) -! call aqm_model_get(config=config, stateOut=stateOut, rc=localrc) -! if (aqm_rc_check(localrc, msg="Failure to retrieve model output state", & -! file=__FILE__, line=__LINE__)) return -! -! do s = 0, config % species % ndiag - 2 -! stateOut % tr(:,:,:,config % species % p_diag_beg + s) = & -! buffer(:,:,:,p_pm25at + s) -! end do -! -! END IF -! -! WRITE3_REAL4D = .TRUE. -! -! END IF +!CTM_PMDIAG_1 seems to be removed. Use CTM_ELMO_1. + IF ( TRIM( FNAME ) .EQ. TRIM( CTM_ELMO_1 ) ) THEN + + WRITE3_REAL4D = .FALSE. + + IF ( TRIM( VNAME ) .EQ. TRIM( ALLVAR3 ) ) THEN + + nullify(config) + nullify(stateOut) + call aqm_model_get(config=config, stateOut=stateOut, rc=localrc) + if (aqm_rc_check(localrc, msg="Failure to retrieve model output state", & + file=__FILE__, line=__LINE__)) return + + do s = 0, config % species % ndiag - 2 + stateOut % tr(:,:,:,config % species % p_diag_beg + s) = & + buffer(:,:,:,p_pm25at + s) + end do + ! add AOD here; point to the 4th species in ELMO_INST + !stateOut % aod = BUFFER(:,:,1,4) + + END IF + + WRITE3_REAL4D = .TRUE. + + END IF END FUNCTION WRITE3_REAL4D From 2306c94c6b465408c67384eabcadda355af70670 Mon Sep 17 00:00:00 2001 From: Wei Li Date: Fri, 20 Oct 2023 19:19:33 -0500 Subject: [PATCH 81/90] Add other modified files --- src/model/src/AERO_EMIS.F | 579 -------------------------------------- 1 file changed, 579 deletions(-) delete mode 100644 src/model/src/AERO_EMIS.F diff --git a/src/model/src/AERO_EMIS.F b/src/model/src/AERO_EMIS.F deleted file mode 100644 index 0088145..0000000 --- a/src/model/src/AERO_EMIS.F +++ /dev/null @@ -1,579 +0,0 @@ - -!------------------------------------------------------------------------! -! The Community Multiscale Air Quality (CMAQ) system software is in ! -! continuous development by various groups and is based on information ! -! from these groups: Federal Government employees, contractors working ! -! within a United States Government contract, and non-Federal sources ! -! including research institutions. These groups give the Government ! -! permission to use, prepare derivative works of, and distribute copies ! -! of their work in the CMAQ system to the public and to permit others ! -! to do so. The United States Environmental Protection Agency ! -! therefore grants similar permission to use the CMAQ system software, ! -! but users are requested to provide copies of derivative works or ! -! products designed to operate in the CMAQ system to the United States ! -! Government without restrictions as to use by others. Software ! -! that is used with the CMAQ system but distributed under the GNU ! -! General Public License or the GNU Lesser General Public License is ! -! subject to their copyright restrictions. ! -!------------------------------------------------------------------------! - -C::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - MODULE AERO_EMIS - -C Emissions data and code required for the modal aerosol module in CMAQ -C Based on original codes by Dr. Francis S. Binkowski and J. Young - -C Dependent Upon: NONE - -C Revision History: - -C 30 Aug 01 J.Young: dyn alloc - Use HGRD_DEFN -C 09 Oct 03 J.Gipson: added MW array for AE emis species to module contents -C 31 Jan 05 J.Young: dyn alloc - establish both horizontal & vertical -C domain specifications in one module, GRID_CONF -C 26 Apr 05 P.Bhave: removed code supporting the "old type" of emission -C files that had unspeciated PM10 and PM2.5 only -C removed need for 'AERO_SPC.EXT' by declaring the -C required variables locally -C 13 Jun 05 P.Bhave: added vars needed for sea-salt emission processing -C inherit N_AE_EMIS,AE_EMIS,AE_EMIS_MAP from AE_EMIS.EXT -C moved RHO* parameters from RDEMIS_AE to this module -C for use by SSEMIS routine -C 24 Aug 07 J.Young: Modified to enable in-line plume rise calculation for -C 3D pt source emissions. Distinguish between PM (primary, -C unspeciated, file data) and AE (model speciated). Re- -C named RDEMIS_AE to GET_AERO_EMIS. -C 11 Apr 08 J.Kelly: added code to emit coarse surface area -C 4 Jan 10 J.Young: restructure; eliminate ref to older AERO versions -C 21 Feb 10 J.Young: move sea salt emissions to its own module (SSEMIS) -C 23 Apr 10 J.Young: replace include files with mechanism namelists -C 30 Apr 10 J.Young: update to use aero_reeng by Steve Howard, Prakash Bhave, -C Jeff Young, and Sergey Napelenok -C 23 Jul 10 D.Wong: remove CLOSE3 and BARRIER -C 24 Feb 11 J.Young: Reorganized module with initialization and timestepping -C procedures -C 25 Feb 11 J.Young: add windblown dust module -C 25 Mar 11 S.Roselle: replaced I/O API include files with UTILIO_DEFN -C 11 May 11 D.Wong: incorporated twoway model implementation -C 18 Aug 11 David Wong: In the merge inline point source PM species calculation, -C arrays EMBUFF and PMEMIS_PT have incorrect index values -C 17 Apr 13 J.Young: replace "SPFC ASO4" (found by Havala Pye) with "SPFC_ASO4" -C 07 Nov 14 J.Bash: Updated for the ASX_DATA_MOD shared data module. -C----------------------------------------------------------------------- - - USE AERO_DATA, ONLY: DESID_N_AERO_REF, N_MODE - USE DESID_VARS, ONLY: DESID_LAYS, DESID_STREAM_AERO, DESID_N_SRM, CELLVOL - - IMPLICIT NONE - SAVE -C aerosol emissions: [ppmv/s] for mass & number spcs, [m2/mol/s] for surface area spcs - PUBLIC DESID_SIZE_DIST, AERO_EMIS_INIT, DESID_INIT_SIZE_DIST, - & MAP_ISTRtoAERO, MAP_ISTRtoMODE, MAP_NUMtoISTR, MAP_SRFtoISTR, - & MAP_ISTRtoNUM, MAP_ISTRtoSRF, MAP_ISTRtoSD, DESID_STREAM_AERO, - & SD_SPLIT - PRIVATE - -C Variables for converting mass emissions rate to number emissions rate - REAL :: FACNUM( DESID_N_AERO_REF,N_MODE ) - -C Variables for converting mass emissions rate to 2nd moment emissions rate - REAL :: FACSRF( DESID_N_AERO_REF,N_MODE ) - -C Variables for Saving split factors between emission modes - REAL, ALLOCATABLE :: SD_SPLIT( :,: ) - -C Emission rate of all aerosol species interpolated to current time - INTEGER, ALLOCATABLE :: MAP_ISTRtoAERO( : ) - INTEGER, ALLOCATABLE :: MAP_ISTRtoMODE( : ) - INTEGER, ALLOCATABLE :: MAP_NUMtoISTR ( : ) - INTEGER, ALLOCATABLE :: MAP_SRFtoISTR ( : ) - INTEGER, ALLOCATABLE :: MAP_ISTRtoNUM ( : ) - INTEGER, ALLOCATABLE :: MAP_ISTRtoSRF ( : ) - INTEGER, ALLOCATABLE :: MAP_ISTRtoSD ( :,: ) - INTEGER, ALLOCATABLE :: MAP_AEROtoDIFF( :,: ) ! indices of aero species to CGRID - -C Miscellaneous variables - CHARACTER( 200 ) :: XMSG = ' ' - - CONTAINS - -C----------------------------------------------------------------------- - FUNCTION AERO_EMIS_INIT ( JDATE, JTIME, TSTEP ) RESULT ( SUCCESS) - -C Revision History: - -C 30 Aug 01 J.Young: dynamic allocation - Use INTERPX -C 29 Jul 03 P.Bhave: added compatibility with emission files that contain -C PM10, PEC, POA, PNO3, PSO4, and PMF, but do not -C contain PMC -C 20 Aug 03 J.Young: return aero emissions in molar mixing ratio, ppm units -C 09 Oct 03 J.Gipson: added MW array for AE emis species to module contents -C 01 Sep 04 P.Bhave: changed MW for primary organics from 120 to 220 g/mol, -C to match MWPOA in subroutine ORGAER3. -C 31 Jan 05 J.Young: dyn alloc - removed HGRD_ID, VGRID_ID, and COORD_ID -C include files because those parameters are now -C inherited from the GRID_CONF module -C 26 Apr 05 P.Bhave: removed code supporting the "old type" of emission -C files that had unspeciated PM10 and PM2.5 only -C removed need for 'AERO_CONST.EXT' by declaring the -C required variables locally -C simplified the CONVM, CONVN, CONVS calculations -C updated and enhanced in-line documentation -C 03 May 05 P.Bhave: fixed bug in the H2SO4 unit conversion, initially -C identified by Jinyou Liang of CARB -C 13 Jun 05 P.Bhave: calculate sea-salt emissions; execute if MECHNAME = AE4 -C read input fields from new OCEAN_1 file -C read extra input fields from MET_CRO_2D and MET_CRO_3D -C write diagnostic sea-salt emission file -C added TSTEP to call vector for diagnostic output file -C inherit MWs from AE_SPC.EXT instead of hardcoding -C find pointers to CGRID indices instead of hardcoding -C 08 Mar 07 P.Bhave& added capability for emission files that contain -C S.Roselle: POC or POA -C 30 Jan 08 P.Bhave: added compatibility with AE5 mechanisms -C 23 Mar 08 J.Young: modifications to allow for in-line point source emissions -C 11 Apr 08 J.Kelly: added code to emit coarse surface area -C 09 Sep 08 P.Bhave: backward compatibility with AE4 mechanisms -C 20 Feb 10 J.Young: move ssemis out to its own F90 module -C 24 Feb 11 J.Young: add windblown dust emissions option -C 25 Mar 11 S.Roselle: Replaced I/O API include files with UTILIO_DEFN -C 07 Jul 14 B.Hutzell: replaced mechanism include file(s) with fortran module -C 17 Sep 14 K.Fahey: Changed geometric mean diameter and geometric -C standard deviation of emitted particles according to -C Elleman and Covert (2010) -C 15 Apr 16 J.Young: Use aerosol factors from the AERO_DATA module's named constants; -C Moved K.Fahey's mods to geometric mean diameter and standard -C deviation to the AERO_DATA module - -C References: -C CRC76, "CRC Handbook of Chemistry and Physics (76th Ed)", -C CRC Press, 1995 -C Elleman & Covert, "Aerosol size distribution modeling with the Community -C Multiscale Air Quality modeling system in the Pacific -C Northwest: 3. Size distribution of particles emitted -C into a mesoscale model", J. Geophys. Res., Vol 115, -C No D3, doi:10.1029/2009JD012401, 2010 -C Hobbs, P.V. "Basic Physical Chemistry for the Atmospheric Sciences", -C Cambridge Univ. Press, 206 pp, 1995. -C Snyder, J.P. "Map Projections-A Working Manual", U.S. Geological Survey -C Paper 1395 U.S.GPO, Washington, DC, 1987. -C Binkowski & Roselle Models-3 Community Multiscale Air Quality (CMAQ) -C model aerosol component 1: Model Description. -C J. Geophys. Res., Vol 108, No D6, 4183 -C doi:10.1029/2001JD001409, 2003 -C----------------------------------------------------------------------- - - USE AERO_DATA, ONLY: DESID_AERO_REF, N_AEROSPC, AEROSPC, - & AERO_MISSING, MAP_AERO - USE GRID_CONF, ONLY: GDTYP_GD, XCELL_GD, YCELL_GD, YORIG_GD, GL_NROWS, X3FACE_GD - USE DUST_EMIS, ONLY: DUST_EMIS_INIT - USE DESID_VARS, ONLY: MAP_ISTRtoEMVAR - USE PRECURSOR_DATA, ONLY: MAP_PRECURSOR - USE RUNTIME_VARS, ONLY: OCEAN_CHEM, WB_DUST - USE SSEMIS, ONLY: SSEMIS_INIT - USE UTILIO_DEFN !(Wei Li), ONLY: INDEX1, M3EXIT, LATGRD3, XSTAT1, XSTAT2 - USE VDIFF_MAP, ONLY : N_SPC_DIFF, DIFF_SPC - - INCLUDE SUBST_CONST ! physical and mathematical constants - INCLUDE SUBST_FILES_ID ! file name parameters - -C Arguments: - - INTEGER, INTENT( IN ) :: JDATE ! current model date, coded YYYYDDD - INTEGER, INTENT( IN ) :: JTIME ! current model time, coded HHMMSS - INTEGER, INTENT( IN ) :: TSTEP ! time step vector (HHMMSS) - ! TSTEP(1) = local output step - LOGICAL SUCCESS - -C External Functions: - INTEGER, EXTERNAL :: FINDEX ! looks up number in table. - -C Local Variables: - REAL DGV, SG, SPLIT_ACCUM - -C Domain decomposition info from emission and meteorology files - INTEGER GXOFF, GYOFF ! origin offset - -C Miscellaneous variables - INTEGER STATUS ! ENV..., ALLOCATE status - CHARACTER( 16 ), SAVE :: PNAME = 'AERO_EMIS_INIT ' - CHARACTER( 16 ) :: VNAME ! temp var for species names - CHARACTER( 50 ) :: VARDESC ! variable for reading environ. variables - INTEGER L, N, S, V, IAERO, ISRM, ! Loop indices - & IEM, IDIFF, ISPC - -C ---------------------------------------------------------------------- - - SUCCESS = .TRUE. - -C *** Map data modules - CALL MAP_AERO() - CALL MAP_PRECURSOR() - -C *** set up for sea-spray emission processing - IF ( OCEAN_CHEM ) THEN - IF ( .NOT. SSEMIS_INIT( JDATE, JTIME, TSTEP ) ) THEN - XMSG = 'Failure initializing sea-spray emission processing' - CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT2 ) - END IF - END IF - -C *** set up for dust emission processing - IF ( WB_DUST ) THEN - IF ( .NOT. DUST_EMIS_INIT( JDATE, JTIME, TSTEP ) ) THEN - XMSG = 'Failure initializing dust emission processing' - CALL M3EXIT( PNAME, JDATE, JTIME, XMSG, XSTAT2 ) - END IF - END IF - -C *** Set up emissions size distribution arrays - ! Calculate factors for converting 3rd moment emission rates into - ! number and surface area emission rates. See Equation 7b of - ! Binkowski & Roselle (2003) - DO IEM = 1,DESID_N_AERO_REF - DO N = 1, N_MODE - DGV = DESID_AERO_REF( IEM )%DGVEM( N ) - SG = DESID_AERO_REF( IEM )%SGEM ( N ) - - IF ( DESID_AERO_REF( IEM )%SPLIT( N ) .GT. 0.0 ) THEN - FACNUM( IEM,N ) = EXP( 4.5 * LOG( SG ) ** 2 ) / DGV ** 3 - FACSRF( IEM,N ) = PI * EXP( 0.5 * LOG( SG ) ** 2 ) / DGV - ELSE - FACNUM( IEM,N ) = 0.0 - FACSRF( IEM,N ) = 0.0 - END IF - END DO - - END DO - - ! Map the Modal-Dependent Names to Transported Species - ALLOCATE ( MAP_AEROtoDIFF( N_AEROSPC, N_MODE ) ) - DO ISPC = 1,N_AEROSPC - DO N = 1,N_MODE - MAP_AEROtoDIFF( ISPC, N ) = INDEX1( AEROSPC( ISPC )%name( N ), - & N_SPC_DIFF, DIFF_SPC ) - END DO - END DO - - - ! Modify the reference emissions splits based on what transported - ! aerosol species are actually available. For example, if the aerosol - ! namelist only includes the accumulation mode (J) but not the - ! Aitken mode (I) for a particular species, then the split for - ! Aitken mode should be added to the Accumulation mode. Save - ! these scale factors as a function of transported species and - ! mode. - ALLOCATE( SD_SPLIT( N_SPC_DIFF, DESID_N_AERO_REF ) ) - SD_SPLIT = 0.0 - DO IEM = 1,DESID_N_AERO_REF - ! For the Fine Mode Reference Distribution, lump Aitken - ! with Accumulation mode if Aitken Mode does not exist - IF ( DESID_AERO_REF( IEM )%NAME .EQ. 'FINE_REF' ) THEN - DO ISPC = 1,N_AEROSPC - SPLIT_ACCUM = 0.0 - DO N = 1,N_MODE-1 - IF ( AERO_MISSING( ISPC,N ) ) THEN - SPLIT_ACCUM = SPLIT_ACCUM + DESID_AERO_REF( IEM )%SPLIT( N ) - ELSE - SD_SPLIT( MAP_AEROtoDIFF( ISPC,N ),IEM ) = - & SD_SPLIT( MAP_AEROtoDIFF( ISPC,N ),IEM ) + - & DESID_AERO_REF( IEM )%SPLIT( N ) + SPLIT_ACCUM - SPLIT_ACCUM = 0.0 - END IF - END DO - END DO - ELSE - ! Arbitrary Distribution -> Apply factor to species - ! if it exists in each mode - DO ISPC = 1, N_AEROSPC - DO N = 1, N_MODE - IF ( .NOT. AERO_MISSING( ISPC,N ) ) THEN - SD_SPLIT( MAP_AEROtoDIFF( ISPC,N ),IEM ) = - & DESID_AERO_REF( IEM )%SPLIT( N ) - END IF - END DO - END DO - END IF - END DO - - ALLOCATE ( MAP_NUMtoISTR ( N_MODE ), - & MAP_SRFtoISTR ( N_MODE ), STAT = STATUS ) - CALL CHECKMEM( STATUS, 'MAP_NUMtoEM', PNAME ) - CALL CHECKMEM( STATUS, 'MAP_SRFtoEM', PNAME ) - - END FUNCTION AERO_EMIS_INIT - -C----------------------------------------------------------------------- - - SUBROUTINE DESID_INIT_SIZE_DIST ( JDATE, JTIME ) - -C EM_SD_INIT initializes the structures that map modes and streams to -C reference modes including splits, diameters, and standard deviations. - -C----------------------------------------------------------------------- - USE AERO_DATA, ONLY: DESID_AERO_REF, DESID_N_AERO_REF - USE DESID_VARS, ONLY: DESID_SD_NML - USE DESID_UTIL, ONLY: DESID_GET_RULE_STREAMS - USE UTILIO_DEFN, ONLY: INDEX1, XSTAT1 - - IMPLICIT NONE - - INTEGER, INTENT( IN ) :: JDATE ! current model date, coded YYYYDDD - INTEGER, INTENT( IN ) :: JTIME ! current model time, coded HHMMSS - INTEGER ISRM - - INTEGER :: N_SD_RULE - INTEGER :: N_SD( DESID_N_SRM ) - CHARACTER( 16 ) :: SD_NAME( DESID_N_SRM, 10 ) - INTEGER :: SD( DESID_N_SRM, 10 ) - LOGICAL :: RULE_STREAM( DESID_N_SRM ) - CHARACTER( 16 ) :: CSUR - CHARACTER( 16 ), SAVE :: PNAME = 'EM_SD_INIT ' - CHARACTER( 20 ) :: DESID_AERO_REF_CAPS( DESID_N_AERO_REF ) - - INTEGER IRULE, ISUR, N, NLEN, ISD, IM, IEM, NRULE - LOGICAL :: LREMOVE - - ! Find Total Number of Size Distribution Registries - N_SD_RULE = 0 - DO IRULE = 1,SIZE( DESID_SD_NML ) - IF ( DESID_SD_NML( IRULE )%STREAM .EQ. '' ) EXIT - N_SD_RULE = IRULE - END DO - - ! First Load all of the Streams with the Default FINE, COARSE, and - ! AERO Mode references - SD = 0 - SD_NAME = '' - - ! Capitalize EM_AERO_REF(:)%NAME - DO IM = 1,DESID_N_AERO_REF - DESID_AERO_REF_CAPS( IM ) = DESID_AERO_REF( IM )%NAME - CALL UPCASE( DESID_AERO_REF_CAPS( IM ) ) - ENDDO - - DO ISRM = 1,DESID_N_SRM - N_SD( ISRM ) = 2 - SD_NAME( ISRM,1 ) = 'FINE' - SD( ISRM,1 ) = INDEX1( 'FINE_REF', DESID_N_AERO_REF, DESID_AERO_REF_CAPS( : ) ) - SD_NAME( ISRM,2 ) = 'COARSE' - SD( ISRM,2 ) = INDEX1( 'COARSE_REF', DESID_N_AERO_REF, DESID_AERO_REF_CAPS( : ) ) - END DO - - ! Now Modify those defaults or add new modes to desired streams - DO IRULE = 1, N_SD_RULE - ! Expand Size Distribution Rule to All Streams if Requested - LREMOVE = .FALSE. - IF ( DESID_SD_NML( IRULE )%STREAM .EQ. '' ) CYCLE - CALL DESID_GET_RULE_STREAMS( DESID_SD_NML( IRULE )%STREAM, IRULE, - & RULE_STREAM, LREMOVE ) - IF ( LREMOVE ) CYCLE - - ! Loop through streams, set defaults, and build map array - DO ISRM = 1, DESID_N_SRM - IF ( RULE_STREAM( ISRM ) ) THEN - ! This Stream is Being Modified by a Size Distribution - ! rule - CALL UPCASE( DESID_SD_NML( IRULE )%MODE_REF ) - IF ( DESID_SD_NML( IRULE )%MODE .EQ. 'FINE' ) THEN - ! Overwrite the FINE mode. All fine particle species - ! will go to this mode by default - SD( ISRM,1 ) = INDEX1( DESID_SD_NML( IRULE )%MODE_REF, - & DESID_N_AERO_REF, DESID_AERO_REF_CAPS( : ) ) - IF ( SD( ISRM,1 ) .EQ. 0 ) THEN - WRITE( XMSG,'(A,A,A,/,A,I2,A)' ), '*** Reference Aerosol Mode (', - & DESID_SD_NML( IRULE )%MODE_REF, 'Specified in Emissions Size ', - & 'Dist Rule ',IRULE,' does not exist in AERO_DATA.' - CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - END IF - - ELSEIF ( DESID_SD_NML( IRULE )%MODE .EQ. 'COARSE' ) THEN - ! Overwrite the COARSE mode. All coarse particle - ! species will go to this mode by default - SD( ISRM,2 ) = INDEX1( DESID_SD_NML( IRULE )%MODE_REF, - & DESID_N_AERO_REF, DESID_AERO_REF_CAPS( : ) ) - IF ( SD( ISRM,2 ) .EQ. 0 ) THEN - WRITE( XMSG,'(A,A,A,/,A,I2,A)' ), '*** Reference Aerosol Mode (', - & DESID_SD_NML( IRULE )%MODE_REF, 'Specified in Emissions Size ', - & 'Dist Rule ',IRULE,' does not exist in AERO_DATA.' - CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - END IF - - ELSE - ! Add a New Available Mode. For example, add a mode - ! just for BC, call it PUREBC, and make sure the AEC - ! for this stream is pointing to this mode. Also make - ! sure you set AEC for FINE mode aerosol to 0.0 if - ! you have default mapping turned on. - N_SD( ISRM ) = N_SD( ISRM ) + 1 - SD_NAME( ISRM,N_SD( ISRM ) ) = DESID_SD_NML( IRULE )%MODE - SD( ISRM,N_SD( ISRM ) ) = INDEX1( DESID_SD_NML( IRULE )%MODE_REF, - & DESID_N_AERO_REF, DESID_AERO_REF_CAPS( : ) ) - IF ( SD( ISRM,N_SD( ISRM )) .EQ. 0 ) THEN - WRITE( XMSG,'(A,A,A,/,A,I2,A)' ), '*** Reference Aerosol Mode (', - & DESID_SD_NML( IRULE )%MODE_REF, 'Specified in Emissions Size ', - & 'Dist Rule ',IRULE,' does not exist in AERO_DATA.' - CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT1 ) - END IF - - END IF - END IF - END DO - END DO - - ! Finally, transfer this data to a global variable which - ! captures and organizes the modes of each stream - ALLOCATE( DESID_STREAM_AERO( DESID_N_SRM ) ) - DO ISRM = 1,DESID_N_SRM - N = N_SD( ISRM ) - DESID_STREAM_AERO( ISRM )%LEN = N + 1 - ALLOCATE( DESID_STREAM_AERO( ISRM )%NAME( N+1 ) ) - ALLOCATE( DESID_STREAM_AERO( ISRM )%REF( N+1 ) ) - ALLOCATE( DESID_STREAM_AERO( ISRM )%FACNUM( N+1,N_MODE ) ) - ALLOCATE( DESID_STREAM_AERO( ISRM )%FACSRF( N+1,N_MODE ) ) - - DESID_STREAM_AERO( ISRM )%NAME( 2:N+1 ) = SD_NAME( ISRM,1:N ) - DESID_STREAM_AERO( ISRM )%REF( 2:N+1 ) = SD( ISRM,1:N ) - DESID_STREAM_AERO( ISRM )%NAME( 1 ) = 'GAS' - DESID_STREAM_AERO( ISRM )%REF( 1 ) = 0 - - ! Map Factors for Converting Aerosol Mass to Number and - ! Surface Area to each Emission Stream - DESID_STREAM_AERO( ISRM )%FACNUM( :,: ) = 0.0 - DESID_STREAM_AERO( ISRM )%FACSRF( :,: ) = 0.0 - DO ISD = 2,N+1 - IEM = DESID_STREAM_AERO( ISRM )%REF( ISD ) - DO IM = 1,N_MODE - DESID_STREAM_AERO( ISRM )%FACNUM( ISD,IM ) = FACNUM( IEM,IM ) - DESID_STREAM_AERO( ISRM )%FACSRF( ISD,IM ) = FACSRF( IEM,IM ) - END DO - END DO - END DO - - END SUBROUTINE DESID_INIT_SIZE_DIST - - -C----------------------------------------------------------------------- - - SUBROUTINE DESID_SIZE_DIST ( ISRM, VDEMIS, NL ) - -C EMISS_SIZE_DIST distributes bulk aerosol emissions into size space -C using parameters precompiled in the AERO_DATA module. -C -C Revision History: - -C 16 AUG 17 BMURPHY: Created -C -C ---------------------------------------------------------------------- - - USE AERO_DATA, ONLY: AEROSPC, N_AEROSPC, AEROSPC_MWINV - USE AEROMET_DATA, ONLY: F6DPI - USE ASX_DATA_MOD, ONLY: MET_DATA - USE DESID_VARS, ONLY: DESID_N_ISTR, IDUSTSRM, ISEASRM - USE GRID_CONF, ONLY: NCOLS, NROWS - USE SSEMIS, ONLY: SEA_FACTNUM, SEA_FACTSRF - - INTEGER, INTENT( IN ) :: ISRM, NL - REAL, INTENT( INOUT ) :: VDEMIS ( :,:,:,: ) - - INTEGER :: N, S, IAERO, IM, ISD, ISTR ! Looping Variables - INTEGER :: ROW, COL, LAY, N_SD, INUM, ISRF - REAL :: FACNUM, FACSRF, MW_FAC - REAL, ALLOCATABLE :: EMISM3( :,:,:,:,: ) - REAL, ALLOCATABLE, SAVE :: GSFAC( :,:,: ) - REAL, ALLOCATABLE, SAVE :: DENS_FAC( : ) - REAL, PARAMETER :: F6DPIM9 = 1.0E-9 * F6DPI ! 1.0E-9 = Kg/ug - LOGICAL, SAVE :: FIRST_TIME = .TRUE. - -C *** Initialize Variables - IF ( FIRST_TIME ) THEN - FIRST_TIME = .FALSE. - ALLOCATE( GSFAC ( DESID_LAYS,NCOLS,NROWS ) ) - - ALLOCATE( DENS_FAC( N_AEROSPC ) ) - DO IAERO = 1,N_AEROSPC - DENS_FAC( IAERO ) = F6DPIM9 / AEROSPC( IAERO )%DENSITY - END DO - - END IF - - N_SD = DESID_STREAM_AERO( ISRM )%LEN - ALLOCATE( EMISM3( DESID_LAYS,NCOLS,NROWS,N_MODE,N_SD ) ) - EMISM3 = 0.0 - -C *** Calculate scaling factor for converting mass emissions into [ug/m3/s] -C note: RJACM converts grid heights from sigma coordinates to meters -C Also calculate scaling factors for converting to molar-mixing-ratio units - DO LAY = 1,NL - GSFAC( LAY,:,: ) = Met_Data%RJACM( :,:,LAY ) / CELLVOL( :,:,LAY ) ![ug/s] to [ug/m3/s] - END DO - -C *** Apply Aerosol Size Distribution - DO ISTR = 1, DESID_N_ISTR - ! Find which Size Distribution or Phase this emissions species belongs - ! to for this stream. If the value is a 0, then there are no emissions - ! for this species from this stream. If it is a 1, then this species is - ! a gas and the following aerosol conversions should be skipped. - ISD = MAP_ISTRtoSD( ISTR,ISRM ) - IF ( ISD .LE. 1 ) CYCLE - - ! Look up Aerosol Species and Mode of Interest - IAERO = MAP_ISTRtoAERO( ISTR ) !This maps to the CMAQ aerosol - ! species so we can retrieve density - IM = MAP_ISTRtoMODE( ISTR ) !This maps to the internal CMAQ modes - ! (ie. I, J, and K) - !DENS_FAC = F6DPIM9 / AEROSPC( IAERO )%DENSITY - - ! Convert Aerosol from [g/s] to [ug/m3/s] for all streams - ! except Dust and Sea Spray. For those streams, convert - ! [g/m3/s] to [ug/m3/s] - VDEMIS( ISTR,1:NL,:,: ) = VDEMIS( ISTR,1:NL,:,: ) * 1.0E6 - IF ( ISRM .NE. ISEASRM .AND. ISRM .NE. IDUSTSRM ) THEN - VDEMIS( ISTR,1:NL,:,: ) = VDEMIS( ISTR,1:NL,:,: ) * GSFAC( 1:NL,:,: ) - END IF - - ! Sum Total Volume of Mode N [m3/m3/s] - IF ( .NOT. AEROSPC( IAERO )%TRACER ) - & EMISM3( 1:NL,:,:,IM,ISD ) = EMISM3( 1:NL,:,:,IM,ISD ) + - & VDEMIS( ISTR,1:NL,:,: ) * DENS_FAC( IAERO ) - - ! Convert Mass Emission Rates from [ug/m3/s] to [umol/m3/s] - VDEMIS( ISTR,1:NL,:,: ) = VDEMIS( ISTR,1:NL,:,: ) * AEROSPC_MWINV( IAERO ) - END DO - -C *** Calculate the number emissions rate for each mode [1/m3/s], using -C Equation 7b of Binkowski & Roselle (2003). -C Calculate the surface area emissions rate for the fine modes [m2/m3/s], -C using Equation 7c of Binkowski & Roselle (2003). Multiplying by PI -C converts 2nd moment to surface area. - - DO ISD = 2, N_SD ! Skip the Index for the Gas Phase - IF ( ISRM .EQ. ISEASRM ) THEN - ! Apply Spatially-Dependent Number and Surface Area Scale Factors - DO IM = 1, N_MODE - INUM = MAP_NUMtoISTR(IM) - VDEMIS( INUM,1,:,: ) = VDEMIS( INUM,1,:,: ) - & + EMISM3( 1,:,:,IM,ISD ) * SEA_FACTNUM( IM,:,: ) - - ISRF = MAP_SRFtoISTR(IM) - VDEMIS( ISRF,1,:,: ) = VDEMIS( ISRF,1,:,: ) - & + EMISM3( 1,:,:,IM,ISD ) * SEA_FACTSRF( IM,:,: ) - END DO - ELSE - ! Apply Homogeneous Scale Factors Consistent with this Stream - DO IM = 1, N_MODE - INUM = MAP_NUMtoISTR(IM) - FACNUM = DESID_STREAM_AERO( ISRM )%FACNUM( ISD,IM ) - VDEMIS( INUM,1:NL,:,: ) = VDEMIS( INUM,1:NL,:,: ) + EMISM3( 1:NL,:,:,IM,ISD ) * FACNUM - - ISRF = MAP_SRFtoISTR(IM) - FACSRF = DESID_STREAM_AERO( ISRM )%FACSRF( ISD,IM ) - VDEMIS( ISRF,1:NL,:,: ) = VDEMIS( ISRF,1:NL,:,: ) + EMISM3( 1:NL,:,:,IM,ISD ) * FACSRF - END DO - END IF - END DO - - END SUBROUTINE DESID_SIZE_DIST - - END MODULE AERO_EMIS - From 6351dd4ed226464290cd2fd4d2c1eb50454bb68e Mon Sep 17 00:00:00 2001 From: lwcugb <35088762+lwcugb@users.noreply.github.com> Date: Fri, 20 Oct 2023 20:51:34 -0400 Subject: [PATCH 82/90] Update .gitmodules point to CMAQ 5.4+ --- .gitmodules | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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+ From 5e768a662e332ca9225f4f7e5c83d104a40a678c Mon Sep 17 00:00:00 2001 From: lwcugb <35088762+lwcugb@users.noreply.github.com> Date: Sat, 21 Oct 2023 01:47:45 -0400 Subject: [PATCH 83/90] Update aqm_methods.F90 Forget to turn on AOD --- src/shr/aqm_methods.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/shr/aqm_methods.F90 b/src/shr/aqm_methods.F90 index 49c1278..0098d07 100644 --- a/src/shr/aqm_methods.F90 +++ b/src/shr/aqm_methods.F90 @@ -1705,7 +1705,7 @@ LOGICAL FUNCTION WRITE3_REAL4D( FNAME, VNAME, JDATE, JTIME, BUFFER ) buffer(:,:,:,p_pm25at + s) end do ! add AOD here; point to the 4th species in ELMO_INST - !stateOut % aod = BUFFER(:,:,1,4) + stateOut % aod = BUFFER(:,:,1,4) END IF From 4492f165063be33891daca60951ff50f94896cd9 Mon Sep 17 00:00:00 2001 From: lwcugb <35088762+lwcugb@users.noreply.github.com> Date: Wed, 10 Jan 2024 14:08:56 -0500 Subject: [PATCH 84/90] Update RUNTIME_VARS.F Need to comment out two lines for writing to OUTDEV and LOGDEV in aqm_dev branch --- src/model/src/RUNTIME_VARS.F | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/model/src/RUNTIME_VARS.F b/src/model/src/RUNTIME_VARS.F index 264b803..0a4d5b0 100644 --- a/src/model/src/RUNTIME_VARS.F +++ b/src/model/src/RUNTIME_VARS.F @@ -982,8 +982,9 @@ SUBROUTINE INIT_ENV_VARS( JDATE, JTIME ) XMSG = 'MET data determined based on WRF ARW version ' IF( MYPE .EQ. 0 ) THEN - WRITE(OUTDEV,'(/,5X,2(A,1X),/)')TRIM( XMSG ), TRIM( FDESC3D(NV)(LOC+9:STR_LEN) ) - WRITE(LOGDEV,'(/,5X,2(A,1X),/)')TRIM( XMSG ), TRIM( FDESC3D(NV)(LOC+9:STR_LEN) ) + !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 From b33ded4fde3d4d2b904c1906545a18417b8566c3 Mon Sep 17 00:00:00 2001 From: lwcugb <35088762+lwcugb@users.noreply.github.com> Date: Fri, 9 Aug 2024 15:05:32 -0400 Subject: [PATCH 85/90] Change aqm_files.cmake to use ROS3 solver --- aqm_files.cmake | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/aqm_files.cmake b/aqm_files.cmake index 127f003..36bae14 100644 --- a/aqm_files.cmake +++ b/aqm_files.cmake @@ -76,7 +76,7 @@ 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_cb6r5_ae7_aq") +set(GAS "${CCTM_ROOT}/gas/ros3") set(GRID "${CCTM_ROOT}/grid/cartesian") set(ICL "${CCTM_ROOT}/ICL/fixed") set(INIT "${CCTM_ROOT}/init") @@ -167,16 +167,15 @@ list(APPEND aqm_CCTM_files ${EMIS}/PTMET.F ${GAS}/../../reactive_tracers/DEGRADE_PARAMETERS.F ${GAS}/../../reactive_tracers/DEGRADE_ROUTINES.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}/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 @@ -259,6 +258,8 @@ list(APPEND aqm_CCTM_files #${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 From ff0892f05d9ce57ecca373c7c3ebbb27f32df815 Mon Sep 17 00:00:00 2001 From: lwcugb <35088762+lwcugb@users.noreply.github.com> Date: Fri, 9 Aug 2024 15:07:49 -0400 Subject: [PATCH 86/90] Add rbdriver.F file to localCCTM folder. There is a typo in CMAQ's source file and therefore need to put it here --- src/model/src/rbdriver.F | 778 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 778 insertions(+) create mode 100644 src/model/src/rbdriver.F 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 + From 1de518e375978409afe631a6fc81becc13b6b9c0 Mon Sep 17 00:00:00 2001 From: lwcugb <35088762+lwcugb@users.noreply.github.com> Date: Wed, 18 Sep 2024 10:53:17 -0400 Subject: [PATCH 87/90] Add files via upload Better handle of the emission unit. This will not impact the simulation results. --- src/drv/cmaq_mod.F90 | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/src/drv/cmaq_mod.F90 b/src/drv/cmaq_mod.F90 index ff3b705..70ccf7d 100644 --- a/src/drv/cmaq_mod.F90 +++ b/src/drv/cmaq_mod.F90 @@ -528,12 +528,18 @@ subroutine cmaq_emis_init(rc) 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 - CALL UPCASE( DESID_RULES_NML( IRULE )%PHASE ) + 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 @@ -574,6 +580,11 @@ subroutine cmaq_emis_init(rc) file=__FILE__, line=__LINE__, rc=rc)) return em % factors(n) = ucnv * em % factors(n) umap(n) = 0 + !Wei Li write to log + if (em % species(n) .eq. 'SO2' .and. trim(etype(item)) .eq. 'point-source') then + write(*,*) 'Test unit:',em % units(n),em % table(umap(n),2),DESID_EMVAR_TABLE( spc )%MW,em % dens_flag(n),ucnv + end if + !write to log end end if end if end do From 05a32c1e36086853838e9ff8ea07c0245bbe743d Mon Sep 17 00:00:00 2001 From: lwcugb <35088762+lwcugb@users.noreply.github.com> Date: Wed, 18 Sep 2024 10:58:24 -0400 Subject: [PATCH 88/90] Update PT3D_STKS_DEFN.F Resolve a bug in point source emission. Only the first layer emission is included with his bug, which leads to much lower SO2 simulations. --- src/model/src/PT3D_STKS_DEFN.F | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/model/src/PT3D_STKS_DEFN.F b/src/model/src/PT3D_STKS_DEFN.F index a27ff2f..beccab0 100644 --- a/src/model/src/PT3D_STKS_DEFN.F +++ b/src/model/src/PT3D_STKS_DEFN.F @@ -175,10 +175,11 @@ END SUBROUTINE PLSPRD C set number of emissions layers depending on whether plumerise is on CALL AQM_EMIS_DESC( ETYPE, NLAYS=EMLYRS ) - PTLAYS = EMLYRS - + FIRSTIME = .FALSE. END IF + + PTLAYS = EMLYRS C Allocate Buffer space for Reading Emissions NSRC = SIZE( EM % IJMAP ) From feff9811041948d8db2d79ed27376afd2e39a61e Mon Sep 17 00:00:00 2001 From: lwcugb <35088762+lwcugb@users.noreply.github.com> Date: Wed, 18 Sep 2024 11:16:53 -0400 Subject: [PATCH 89/90] Delete some comments for testing purpose --- src/drv/cmaq_mod.F90 | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/drv/cmaq_mod.F90 b/src/drv/cmaq_mod.F90 index 70ccf7d..5b95dda 100644 --- a/src/drv/cmaq_mod.F90 +++ b/src/drv/cmaq_mod.F90 @@ -580,11 +580,6 @@ subroutine cmaq_emis_init(rc) file=__FILE__, line=__LINE__, rc=rc)) return em % factors(n) = ucnv * em % factors(n) umap(n) = 0 - !Wei Li write to log - if (em % species(n) .eq. 'SO2' .and. trim(etype(item)) .eq. 'point-source') then - write(*,*) 'Test unit:',em % units(n),em % table(umap(n),2),DESID_EMVAR_TABLE( spc )%MW,em % dens_flag(n),ucnv - end if - !write to log end end if end if end do From 584637b390efba3d267dca95fc81d8460d7ba65f Mon Sep 17 00:00:00 2001 From: Youhua Tang Date: Mon, 23 Sep 2024 11:34:24 -0400 Subject: [PATCH 90/90] Update CMakeLists.txt --- CMakeLists.txt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 7df5792..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()