diff --git a/models/atm/cam/bld/build-namelist b/models/atm/cam/bld/build-namelist index c81855cdfbd6..64acc8a16413 100755 --- a/models/atm/cam/bld/build-namelist +++ b/models/atm/cam/bld/build-namelist @@ -2462,10 +2462,16 @@ add_default($nl, 'srf_flux_avg', 'eddy_scheme'=>$eddy_scheme); # Microphysics scheme add_default($nl, 'use_subcol_microp'); add_default($nl, 'microp_scheme'); +add_default($nl, 'micro_do_icesupersat'); add_default($nl, 'macrop_scheme'); if ($cfg->get('microphys') =~ /^mg/) { add_default($nl, 'micro_mg_version'); add_default($nl, 'micro_mg_sub_version'); + add_default($nl, 'micro_mg_num_steps'); + add_default($nl, 'nucleate_ice_subgrid'); + add_default($nl, 'cld_macmic_num_steps'); + add_default($nl, 'micro_mg_precip_frac_method'); + add_default($nl, 'micro_mg_berg_eff_factor'); } add_default($nl, 'micro_mg_dcs'); @@ -2512,11 +2518,34 @@ else { # CLUBB_SGS add_default($nl, 'do_clubb_sgs'); -add_default($nl, 'clubb_history'); -add_default($nl, 'clubb_rad_history'); +my $clubb_sgs = $nl->get_value('do_clubb_sgs'); +if ($clubb_sgs =~ /$TRUE/io) { + my $clubb_do_adv = $cfg->get('clubb_do_adv'); + if($clubb_do_adv == '1') { + add_default($nl, 'clubb_do_adv', 'val'=>'.true.'); + } + my $clubb_do_deep = $cfg->get('clubb_do_deep'); + if($clubb_do_deep == '1') { + add_default($nl, 'clubb_do_deep', 'val'=>'.true.'); + } + add_default($nl, 'clubb_history'); + add_default($nl, 'clubb_rad_history'); + + # Check compatibility of clubb_do_deep (if set) with deep_scheme + my $clubb_do_deep = $nl->get_value('clubb_do_deep'); + if (defined $clubb_do_deep) { + my $deep_scheme = $nl->get_value('deep_scheme'); + if ($deep_scheme ne "'CLUBB_SGS'" && $clubb_do_deep == /$TRUE/io) { + die "$ProgName - ERROR: clubb_do_deep = .true. but incompatible deep_scheme=$deep_scheme and needs to be 'CLUBB_SGS'\n"; + } + } -if ($nl->get_value('clubb_history') =~ "true" && $nl->get_value('atm_nthreads') != 1) { - die "$ProgName - ERROR: clubb_history = .true. with multiple threads is not supported. \n"; + add_default($nl, 'clubb_expldiff'); + add_default($nl, 'clubb_rainevap_turb'); + add_default($nl, 'clubb_cloudtop_cooling'); + add_default($nl, 'clubb_timestep'); + add_default($nl, 'clubb_rnevap_effic'); + add_default($nl, 'clubb_stabcorrect'); } #in-cloud scav tuning for cloud-borne aerosol @@ -2564,6 +2593,13 @@ add_default($nl, 'cldfrc_premit'); add_default($nl, 'cldfrc_premib'); add_default($nl, 'cldfrc_iceopt'); add_default($nl, 'cldfrc_icecrit'); +add_default($nl, 'cldfrc2m_rhmini'); +add_default($nl, 'cldfrc2m_rhmaxi'); + +my $cldfrc_rhminp = $nl->get_value('cldfrc_rhminp'); +if ($cldfrc_rhminp and !($cfg->get('microphys') eq 'rk')) { + die "$ProgName - ERROR: cldfrc_rhminp is valid only for RK microphysics scheme\n"; +} # condensate to rain autoconversion coefficients add_default($nl, 'zmconv_c0_lnd'); @@ -3000,7 +3036,8 @@ if ($cfg->get('dyn') =~ /se/) { statefreq se_partmethod se_topology se_ftype integration nu nu_div nu_p nu_q nu_top se_phys_tscale interpolate_analysis interp_nlat interp_nlon vert_remap_q_alg - interp_type interp_gridtype se_limiter_option qsplit rsplit tstep_type); + interp_type interp_gridtype se_limiter_option qsplit rsplit tstep_type + hypervis_scaling mesh_file); foreach my $var (@vars) { add_default($nl, $var); @@ -3015,6 +3052,7 @@ add_default($nl, 'history_aero_optics'); add_default($nl, 'history_budget'); add_default($nl, 'history_eddy'); add_default($nl, 'history_waccm'); +add_default($nl, 'history_clubb'); # The history output for the AMWG variability diagnostics assumes that auxilliary history # files h1, h2, and h3 contain daily, 6-hrly, and 3-hrly output respectively. If this output diff --git a/models/atm/cam/bld/config_files/definition.xml b/models/atm/cam/bld/config_files/definition.xml index 72038ad26fab..e18051ce6f61 100644 --- a/models/atm/cam/bld/config_files/definition.xml +++ b/models/atm/cam/bld/config_files/definition.xml @@ -38,8 +38,8 @@ Option to turn on waccmx thermosphere/ionosphere extension: 0 => no, 1 => yes Physics package: cam3, cam4, cam5, ideal (Held-Suarez forcings), adiabatic. - -Microphysics package: rk (Rasch and Kristjansson), mg1 (Morrison and Gettelman two moment scheme CAM5.1), mg1.5 (Morrison and Gettelman second version development). + +Microphysics package: rk (Rasch and Kristjansson), mg1 (Morrison and Gettelman two moment scheme CAM5.1), mg1.5 (Morrison and Gettelman second version development), mg2 ((Morrison and Gettelman second version). Macrophysics package: RK, Park, CLUBB_SGS. @@ -47,6 +47,15 @@ Macrophysics package: RK, Park, CLUBB_SGS. Switch to turn on/off CLUBB_SGS package: 0 => no, 1 => yes + +Switch to turn on UNICON package: 0 => off, 1 => on + + +Switch to turn on/off CLUBB_SGS using clubb to calculate deep: 0 => no, 1 => yes + + +Switch to turn on/off advecting CLUBB moments: 0 => no, 1 => yes + PBL package: uw (University of Washington), hb (Holtslag and Boville), hbr (Holtslag, Boville, and Rasch), clubb_sgs. diff --git a/models/atm/cam/bld/config_files/horiz_grid.xml b/models/atm/cam/bld/config_files/horiz_grid.xml index f13774722ece..1220a5e0bebc 100644 --- a/models/atm/cam/bld/config_files/horiz_grid.xml +++ b/models/atm/cam/bld/config_files/horiz_grid.xml @@ -38,5 +38,9 @@ + + + + diff --git a/models/atm/cam/bld/configure b/models/atm/cam/bld/configure index a55235c4e52a..cd7e76e258cc 100755 --- a/models/atm/cam/bld/configure +++ b/models/atm/cam/bld/configure @@ -123,6 +123,8 @@ OPTIONS trop_mam3 | trop_mam7 | super_fast_llnl | super_fast_llnl_mam3 | trop_strat_soa | trop_strat_mam3 | trop_strat_mam7 | none ]. Default: trop_mam3. -clubb_sgs Turns on CLUBB_SGS + -clubb_opts Comma separated list of CLUBB options to turn on/off. By default they are all off. Current + options are: clubb_do_adv(Advect CLUBB moments), clubb_do_deep(CLUBB does the deep convection) -co2_cycle This option is meant to be used with the -ccsm_seq option. It modifies the CAM configuration by increasing the number of advected constituents by 4. -comp_intf Specify the component interfaces [mct | esmf] (default: mct). @@ -136,7 +138,7 @@ OPTIONS se grids. -max_n_rad_cnst Maximum number of constituents that are either radiatively active, or in any single diagnostic list for the radiation. - -microphys Specify the microphysics option [mg1 | mg1.5 | rk]. + -microphys Specify the microphysics option [mg1 | mg1.5 | mg2 | rk]. -nadv Set total number of advected species to . -nadv_tt Set number of advected test tracers . -nlev Set number of levels to . @@ -856,6 +858,12 @@ if ($co2_cycle and $print>=2) { print "co2_cycle option: ON$eol"; } # Micro-physics package # The default for the current physics package is: my $microphys_pkg = 'mg1'; + +#Set the default microphysics package for CLUBB to mg2 +if (defined $opts{'clubb_sgs'}) { + $microphys_pkg = 'mg2'; +} + # But if the physics package is adiabatic, ideal, cam3, cam4, change the default if ($phys_pkg =~ m/^ideal$|^adiabatic$|^cam[34]$/) { $microphys_pkg = 'rk'; @@ -916,6 +924,20 @@ if ($clubb_sgs and $microphys_pkg !~ m/^mg/) { EOF } +#----------------------------------------------------------------------------------------------- +# Break apart CLUBB options into separate fields + +if (defined $opts{'clubb_opts'}) { + my @clubb_temp_opts = split /,/, $opts{'clubb_opts'}; + foreach (@clubb_temp_opts) { + $cfg_ref->set("$_", '1'); + } +} +my $clubb_do_deep = $cfg_ref->get('clubb_do_deep'); +my $clubb_do_adv = $cfg_ref->get('clubb_do_adv'); +if ($print>=2) { print "clubb_do_deep=',$clubb_do_deep,$eol"; } +if ($print>=2) { print "clubb_do_adv=',$clubb_do_adv,$eol"; } + #----------------------------------------------------------------------------------------------- # Macro-physics package # The default for the current physics package is: @@ -1434,10 +1456,19 @@ else { $nadv += 2; if ($print>=2) { print "Advected constituents added by $microphys_pkg microphysics: 2$eol"; } } - elsif ($microphys_pkg =~ /^mg/) { + elsif ($microphys_pkg =~ /^mg1/) { $nadv += 4; if ($print>=2) { print "Advected constituents added by $microphys_pkg microphysics: 4$eol"; } } + elsif ($microphys_pkg =~/^mg2/) { + $nadv += 8; + if ($print>=2) { print "Advected constituents added by $microphys_pkg microphysics: 8$eol"; } + } + + if ($clubb_do_adv) { + $nadv += 9; + if ($print>=2) { print "Advected constituents added by $microphys_pkg microphysics: 8$eol"; } + } # co2_cycle if ($co2_cycle) { @@ -1960,6 +1991,10 @@ if ($clubb_sgs == 1) { $cfg_cppdefs .= " -DCLUBB_REAL_TYPE=dp"; } +if ($clubb_do_deep == 1) { + $cfg_cppdefs .= ' -DCLUBBND_CAM'; +} + #----------------------------------------------------------------------------------------------- # External libraries ########################################################################### #----------------------------------------------------------------------------------------------- diff --git a/models/atm/cam/bld/namelist_files/namelist_defaults_cam.xml b/models/atm/cam/bld/namelist_files/namelist_defaults_cam.xml index d715c4a5dd3c..7ff11c50534c 100644 --- a/models/atm/cam/bld/namelist_files/namelist_defaults_cam.xml +++ b/models/atm/cam/bld/namelist_files/namelist_defaults_cam.xml @@ -21,6 +21,10 @@ 1800 900 600 +600 +900 +600 +600 3600 @@ -144,7 +148,28 @@ atm/cam/inic/homme/cami_1850-01-01_ne240np4_L26_c110314.nc atm/cam/inic/homme/cami_0000-09-01_ne240np4_L26_c061106.nc -atm/cam/inic/homme/cami-mam3_0000-01-ne240np4_L30_c111004.nc +atm/cam/inic/homme/cami-mam3_0000-01-ne240np4_L30_c111004.nc + +atm/cam/inic/homme/cami-mam3_0000-01-01_arm30x8_L30_c130424.nc +atm/cam/inic/homme/cami_0003-01-01_arm30x8_L26_ape_c000000.nc + +atm/cam/inic/homme/cami-mam3_0000-01-01_arm_x8v3_lowcon_np4_L30_c000000.nc +atm/cam/inic/homme/cami_0003-01-01_arm_x8v3_lowcon_np4_L26_ape_c000000.nc + + + +atm/cam/inic/homme/cami-mam3_0000-01-01_conusx4v1np4_L30_c141106.nc +atm/cam/inic/homme/cami_0003-01-01_conusx4v1np4_L30_ape_c000000.nc + + + +atm/cam/inic/homme/cami-mam3_0000-01-01_svalbardx8v1np4_L30_c141107.nc +atm/cam/inic/homme/cami_0003-01-01_svalbardx8v1np4_L30_ape_c000000.nc + + + +atm/cam/inic/homme/cami-mam3_0000-01-01_sooberingoax4x8v1np4_L30_c141110.nc +atm/cam/inic/homme/cami_0003-01-01_sooberingoax4x8v1np4_L30_ape_c000000.nc atm/cam/inic/homme/cami_0000-01-01_ne5np8_L26_ape_c061102.nc atm/cam/inic/homme/cami_0000-01-01_ne16np4_L26_ape_c071213.nc @@ -178,6 +203,10 @@ atm/cam/topo/USGS-gtopo30_ne120np4_16xdel2-PFC-consistentSGH.nc atm/cam/topo/USGS_gtopo30_0.23x0.31_smooth1000-50_ne240np4_c061107.nc +atm/cam/inic/homme/USGS-gtopo30_arm_x8v3_lowcon_tensor12xconsistentSGH.nc +atm/cam/topo/USGS-gtopo30_0.9x1.25_remap_conusx4v1_c051027.nc +atm/cam/topo/USGS-gtopo30_0.9x1.25_remap_svalbardx8v1_c051027.nc +atm/cam/topo/USGS-gtopo30_0.9x1.25_remap_sooberingoax4x8v1_c051027.nc @@ -621,6 +650,10 @@ atm/cam/chem/trop_mam/atmsrf_ne60np4_110920.nc atm/cam/chem/trop_mam/atmsrf_ne120np4_110920.nc atm/cam/chem/trop_mam/atmsrf_ne240np4_110920.nc +atm/cam/chem/trop_mam/atmsrf_armx8v3.nc +atm/cam/chem/trop_mam/atmsrf_conusx4v1.nc +atm/cam/chem/trop_mam/atmsrf_svalbardx8v1.nc +atm/cam/chem/trop_mam/atmsrf_sooberingoax4x8v1.nc atm/cam/chem/trop_mozart/dvel/depvel_monthly.nc @@ -700,6 +733,15 @@ .false. .true. + + .false. + .true. + .false. + .false. + .true. + .false. + 300.0D0 + 1.2D0 .false. @@ -707,21 +749,48 @@ -RK -MG + RK + MG MG + MG + + 1 + 0 + 1 + 400.D-6 + + 1 + 5 + 2 + 250.D-6 + + 2 + 0 + 2 + 1 + 150.D-6 + 195.D-6 + 195.D-6 + + max_overlap + in_cloud -1 -0 + 1.0D0 + 0.1D0 -1 -5 + .false. + + 1 + 6 .false. - 400.0D-6 - 400.0D-6 - 250.0D-6 + +1.0D0 +1.2D0 +1.2D0 +1.2D0 +1.0D0 none @@ -776,6 +845,8 @@ 1.0D0 0.6D0 +1.0D0 +3.0D0 .false. @@ -798,6 +869,8 @@ ZM +CLUBB_SGS +UNICON diag_TKE @@ -806,6 +879,7 @@ CLUBB_SGS UW +UNICON Hack Hack CLUBB_SGS @@ -824,6 +898,7 @@ 0.900D0 0.910D0 + 0.950D0 0.8975D0 0.9125D0 0.8875D0 @@ -901,9 +976,15 @@ 0.70D0 0.70D0 + 0.80D0 + 0.85D0 + + 1.1D0 + 1.0D0 + 5.0e-6 - 9.5e-6 + 9.5e-6 45.0e-6 45.0e-6 45.0e-6 @@ -958,6 +1039,7 @@ 0.0030D0 0.0059D0 0.0035D0 + 0.0075D0 0.0035D0 0.0035D0 0.0020D0 @@ -982,6 +1064,7 @@ 1.0E-6 1.0E-6 + .false. @@ -1038,6 +1121,7 @@ .false. .false. .true. + .true. @@ -1049,6 +1133,12 @@ 480 "explicit" +/dev/null +atm/cam/inic/homme/arm_x8v3_lowcon.g +atm/cam/inic/homme/conusx4v1.g +atm/cam/inic/homme/svalbardx8v1.g +atm/cam/inic/homme/sooberingoax4x8v1.g + 2.5e5 1.0e5 @@ -1060,6 +1150,11 @@ 1.0e13 1.1e12 + 8.0e-8 + 8.0e-8 + 8.0e-8 + 8.0e-8 + -1.0 @@ -1070,7 +1165,10 @@ 1.0e14 1.0e13 1.1e12 - + 8.0e-8 + 8.0e-8 + 8.0e-8 + 8.0e-8 2.5e15 5.0e16 @@ -1079,6 +1177,10 @@ 2.5e14 2.5e13 2.5e12 + 20.0e-8 + 20.0e-8 + 20.0e-8 + 20.0e-8 2 @@ -1090,6 +1192,10 @@ 4 4 1 + 8 + 7 + 8 + 8 1 @@ -1112,6 +1218,10 @@ 4 4 5 + 5 + 4 + 5 + 5 5 5 @@ -1120,6 +1230,17 @@ 20 25 + 0 + 3.2 + 3.2 + 3.2 + 3.2 + + 0 + 0 + 0 + 0 + 0 @@ -1188,7 +1309,11 @@ ccsm4_init/b40.1850.track1.1deg.006/0863-01-01/b40.1850.track1.1deg.006.clm2.r.0863-01-01-00000.nc ccsm4_init/b40.1850.track1.2deg.003/year_401/b40.1850.track1.2deg.003.clm2.r.0401-01-01-00000.nc lnd/clm2/initdata/clmi.BCN.1850-01-01_48x96_gx3v7_simyr1850_c110421.nc -lnd/clm2/initdata/clmi.BCN.2000-01-01_ne30np4_gx1v6_simyr2000_c110328.nc +lnd/clm2/initdata/clmi.BCN.2000-01-01_ne30np4_gx1v6_simyr2000_c110328.nc +lnd/clm2/initdata/clmi.armx8v3.1850-01-01.nc +lnd/clm2/initdata/clmi.conusx4v1.2000-01-01_c141106.nc +lnd/clm2/initdata/clmi.svalbardx8v1.1850-01-01.nc +lnd/clm2/initdata/clmi.sooberingoax4x8v1.1850-01-01_c141110.nc diff --git a/models/atm/cam/bld/namelist_files/namelist_definition.xml b/models/atm/cam/bld/namelist_files/namelist_definition.xml index 0200bbe675f8..ec6cdb2355ef 100644 --- a/models/atm/cam/bld/namelist_files/namelist_definition.xml +++ b/models/atm/cam/bld/namelist_files/namelist_definition.xml @@ -53,6 +53,218 @@ This is an optional attribute that is mainly useful for variables that have only a small number of allowed values. --> + + + + Toggle Model Nudging ON/OFF. + Default: FALSE + + + + Full pathname of analyses data to use for nudging. + Default: none + + + + Template for Nudging analyses file names. + Default: none + + + + Number of analyses files per day. + Default: none + + + + Number of time to update model data per day. + Default: none + + + + Profile index for U nudging. + Default: none + + + + Coeffcient for U nudging. + Default: none + + + + Profile index for V nudging. + Default: none + + + + Coeffcient for V nudging. + Default: none + + + + Profile index for T nudging. + Default: none + + + + Coeffcient for T nudging. + Default: none + + + + Profile index for Q nudging. + Default: none + + + + Coeffcient for Q nudging. + Default: none + + + + Profile index for PS nudging. + Default: none + + + + Coeffcient for PS nudging. + Default: none + + + + Year at which Nudging Begins. + Default: none + + + + Month at which Nudging Begins. + Default: none + + + + Day at which Nudging Begins. + Default: none + + + + Year at which Nudging Ends. + Default: none + + + + Month at which Nudging Ends. + Default: none + + + + Day at which Nudging Ends. + Default: none + + + + LOW Coeffcient for Horizontal Window. + Default: none + + + + HIGH Coeffcient for Horizontal Window. + Default: none + + + + LAT0 of Horizonalt Window. + Default: none + + + + Width of LAT Window. + Default: none + + + + Steepness of LAT Window. + Default: none + + + + LON0 of Horizontal Window. + Default: none + + + + Width of LON Window. + Default: none + + + + Steepness of LON Window. + Default: none + + + + LOW Coeffcient for Vertical Window. + Default: none + + + + HIGH Coeffcient for Vertical Window. + Default: none + + + + HIGH Level Index for Verical Window. + Default: none + + + + Steepness of HIGH end of Vertical Window. + Default: none + + + + LOW Level Index for Verical Window. + Default: none + + + + Steepness of LOW end of Vertical Window. + Default: none + + @@ -1586,6 +1798,14 @@ This default logical is set in cospsimulator_intr.F90 Default: FALSE + + + +Number of macrophysics/microphysics substeps. +Default: 1 + + @@ -1661,6 +1881,24 @@ cloud liquid (cldliq). Default: .true. + +Number of substeps over MG microphysics. +Default: 1 + + + +Type of precipitation fraction. +Default: max_overlap + + + +Efficiency factor for berg +Default: 1 + + Switch to control whether MG microphysics performs a uniform calculation or not @@ -1675,12 +1913,42 @@ Default: set by build-namelist - prescribed aerosol bulk sulfur scale factor Default: 2 + +Switch to turn on heterogeneous freezing code. +Default: .false. + + + +Add diagnostic output for heterogeneous freezing code. +Default: .false. + + + +Switch to turn on treatment of pre-existing ice in the ice nucleation code. +Default: .false. + + + +Add diagnostics for pre-existing ice option in ice nucleation code to history output. +Default: .false. + + + +Subgrid scaling factor for relative humidity in ice nucleation code. +Default: set by build-namelist + + @@ -1734,6 +2002,17 @@ Minimum rh for high stable clouds. Default: set by build-namelist + +Minimum rh for high stable clouds poleward of 60 degrees. +**This is valid only for RK microphysis scheme** +Default: set to cldfrc_rhminh + + + +Maximum pressure level (mbars) where the cldfrc_rhminp setting is applied. +Default: 300. mbar + + parameter for shallow convection cloud fraction. @@ -1783,6 +2062,18 @@ Critical RH for ice clouds (Wilson & Ballard scheme). Default: 0.93 + +Minimum rh for ice cloud fraction > 0. +Default: set by build-namelist + + + +rhi at which ice cloud fraction = 1. +Default: set by build-namelist + + @@ -1808,6 +2099,12 @@ Relaxation time in ZM deep convection scheme. Default: set by build-namelist + +Trigger and memory option in ZM deep convection scheme. +Default: FALSE + + + group="phys_ctl_nl" valid_values="ZM,UNICON,CLUBB_SGS,off" > Type of deep convection scheme employed. 'ZM' for Zhang-McFarlane; 'off' for none. -Default: 'ZM' +Default: 'ZM' unless using 'UNICON' Type of macrophysics scheme employed. 'park' for Park (1998); 'RK' for Rasch and Kristjansson (1998); 'CLUBB_SGS' clubb. -Default: 'park' +Default: set by build-namelist + group="phys_ctl_nl" valid_values="Hack,UW,CLUBB_SGS,UNICON" > Type of shallow convection scheme employed. 'Hack' for Hack shallow convection; 'UW' for original McCaa UW pbl scheme, modified by Sungsu Park; 'CLUBB_SGS' -for CLUBB_SGS. +for CLUBB_SGS; or UNICON which doesn't distinquish shallow and deep. Default: set by build-namelist (depends on eddy_scheme). @@ -1956,6 +2253,12 @@ vertical diffusion routine. Default: set by build-namelist + +Apply ice supersaturation adjustment code +Default: .false. + + Maximum master length scale designed to address issues in diag_TKE outside the @@ -2019,6 +2322,55 @@ diffusion solver routine. Default: set by build-namelist + +Apply cloud top radiative cooling parameterization +Default: .false. + + + +Include effects of precip evaporation on turbulent moments +Default: .false. + + + +Explicit diffusion on temperature and moisture when CLUBB is on +Default: .false. + + + +CLUBB do explicit diffusion with a stability correction +Default: .false. + + + + +CLUBB timestep. +Default: set by build-namelist + + + +Rain evaporation efficiency factor. +Default: set by build-namelist + + + +Switch for CLUBB_ADV +Default: FALSE + + + +Switch for CLUBBND_CAM +Default: FALSE + + + +Switch for diagnostics specific to CLUBB. +Default: .true. + + @@ -4528,6 +4886,33 @@ Only "cube" is supported in CAM. Default: Set by build-namelist. + +baseline ne for scalar hypervis tuning +Default: Set by build-namelist. + + + +Exodus format grid file +Default: Set by build-namelist. + + + +Default: Set by build-namelist. + + + +Default: Set by build-namelist. + + + +Default: Set by build-namelist. + + 0 + real(r8), intent(in) :: T0(pcols,pver) ! Temperature [K] + real(r8), intent(in) :: p(pcols,pver) ! Pressure at the layer mid-point [Pa] + real(r8), intent(in) :: clrw_old(pcols,pver) ! Clear sky fraction at the previous time step for liquid stratus process + real(r8), intent(in) :: clri_old(pcols,pver) ! Clear sky fraction at the previous time step for ice stratus process + real(r8), pointer :: tke(:,:) ! (pcols,pverp) TKE from the PBL scheme + real(r8), pointer :: qtl_flx(:,:) ! (pcols,pverp) overbar(w'qtl') from PBL scheme where qtl = qv + ql + real(r8), pointer :: qti_flx(:,:) ! (pcols,pverp) overbar(w'qti') from PBL scheme where qti = qv + qi + real(r8), pointer :: cmfr_det(:,:) ! (pcols,pver) Detrained mass flux from the convection scheme + real(r8), pointer :: qlr_det(:,:) ! (pcols,pver) Detrained ql from the convection scheme + real(r8), pointer :: qir_det(:,:) ! (pcols,pver) Detrained qi from the convection scheme + + real(r8), intent(out) :: rhmini_arr(pcols,pver) + real(r8), intent(out) :: rhminl_arr(pcols,pver) + real(r8), intent(out) :: rhminl_adj_land_arr(pcols,pver) + real(r8), intent(out) :: rhminh_arr(pcols,pver) + real(r8), intent(out) :: d_rhmin_liq_PBL(pcols,pver) + real(r8), intent(out) :: d_rhmin_ice_PBL(pcols,pver) + real(r8), intent(out) :: d_rhmin_liq_det(pcols,pver) + real(r8), intent(out) :: d_rhmin_ice_det(pcols,pver) + + ! local variables + + integer :: i, k + + real(r8) :: esat_tmp(pcols) ! Dummy for saturation vapor pressure calc. + real(r8) :: qsat_tmp(pcols) ! Saturation water vapor specific humidity [kg/kg] + real(r8) :: sig_tmp + !--------------------------------------------------------------------------------------------------- + + + + ! ---------------------------------- ! + ! Calc critical RH for ice stratus ! + ! ---------------------------------- ! + + rhmini_arr(:,:) = rhmini_const + + if (i_rhmini > 0) then + + ! Compute the drop of critical RH by convective detrainment of cloud condensate + + do k = top_lev, pver + do i = 1, ncol + d_rhmin_ice_det(i,k) = tau_deti*(gravit/dp(i,k))*cmfr_det(i,k)*clri_old(i,k)*qir_det(i,k)*3.6e6_r8 + d_rhmin_ice_det(i,k) = max(0._r8,min(0.5_r8,d_rhmin_ice_det(i,k))) + end do + end do + + if (i_rhmini == 1) then + rhmini_arr(:ncol,:) = rhmini_const - d_rhmin_ice_det(:ncol,:) + end if + + end if + + if (i_rhmini == 2) then + + ! Compute the drop of critical RH by the variability induced by PBL turbulence + + do k = top_lev, pver + call qsat_ice(T0(1:ncol,k), p(1:ncol,k), esat_tmp(1:ncol), qsat_tmp(1:ncol)) + + do i = 1, ncol + sig_tmp = 0.5_r8 * ( qti_flx(i,k) / sqrt(max(qsmall,tke(i,k))) + & + qti_flx(i,k+1) / sqrt(max(qsmall,tke(i,k+1))) ) + d_rhmin_ice_PBL(i,k) = c_aniso*sig_tmp/max(qsmall,qsat_tmp(i)) + d_rhmin_ice_PBL(i,k) = max(0._r8,min(0.5_r8,d_rhmin_ice_PBL(i,k))) + + rhmini_arr(i,k) = 1._r8 - d_rhmin_ice_PBL(i,k) - d_rhmin_ice_det(i,k) + end do + end do + end if + + if (i_rhmini > 0) then + do k = top_lev, pver + do i = 1, ncol + rhmini_arr(i,k) = max(0._r8,min(rhmaxi,rhmini_arr(i,k))) + end do + end do + end if + + ! ------------------------------------- ! + ! Choose critical RH for liquid stratus ! + ! ------------------------------------- ! + + rhminl_arr(:,:) = rhminl_const + rhminl_adj_land_arr(:,:) = rhminl_adj_land_const + rhminh_arr(:,:) = rhminh_const + + if (i_rhminl > 0) then + + ! Compute the drop of critical RH by convective detrainment of cloud condensate + + do k = top_lev, pver + do i = 1, ncol + d_rhmin_liq_det(i,k) = tau_detw*(gravit/dp(i,k))*cmfr_det(i,k)*clrw_old(i,k)*qlr_det(i,k)*3.6e6_r8 + d_rhmin_liq_det(i,k) = max(0._r8,min(0.5_r8,d_rhmin_liq_det(i,k))) + end do + end do + + if (i_rhminl == 1) then + rhminl_arr(:ncol,top_lev:) = rhminl_const - d_rhmin_liq_det(:ncol,top_lev:) + rhminh_arr(:ncol,top_lev:) = rhminh_const - d_rhmin_liq_det(:ncol,top_lev:) + end if + + end if + + if (i_rhminl == 2) then + + ! Compute the drop of critical RH by the variability induced by PBL turbulence + + do k = top_lev, pver + call qsat_water(T0(1:ncol,k), p(1:ncol,k), esat_tmp(1:ncol), qsat_tmp(1:ncol)) + + do i = 1, ncol + sig_tmp = 0.5_r8 * ( qtl_flx(i,k) / sqrt(max(qsmall,tke(i,k))) + & + qtl_flx(i,k+1) / sqrt(max(qsmall,tke(i,k+1))) ) + d_rhmin_liq_PBL(i,k) = c_aniso*sig_tmp/max(qsmall,qsat_tmp(i)) + d_rhmin_liq_PBL(i,k) = max(0._r8,min(0.5_r8,d_rhmin_liq_PBL(i,k))) + + rhminl_arr(i,k) = 1._r8 - d_rhmin_liq_PBL(i,k) - d_rhmin_liq_det(i,k) + rhminl_adj_land_arr(i,k) = 0._r8 + rhminh_arr(i,k) = rhminl_arr(i,k) + end do + end do + end if + + if (i_rhminl > 0) then + do k = top_lev, pver + do i = 1, ncol + rhminl_arr(i,k) = max(rhminl_adj_land_arr(i,k),min(1._r8,rhminl_arr(i,k))) + rhminh_arr(i,k) = max(0._r8,min(1._r8,rhminh_arr(i,k))) + end do + end do + end if + +end subroutine rhcrit_calc + +!======================================================================================================= subroutine instratus_condensate( lchnk, ncol, k, & p_in, T0_in, qv0_in, ql0_in, qi0_in, & + ni0_in, & a_dc_in, ql_dc_in, qi_dc_in, & a_sc_in, ql_sc_in, qi_sc_in, & landfrac, snowh, & + rhmini_in, rhminl_in, rhminl_adj_land_in, rhminh_in, & T_out, qv_out, ql_out, qi_out, & al_st_out, ai_st_out, ql_st_out, qi_st_out ) @@ -1173,10 +1418,6 @@ subroutine instratus_condensate( lchnk, ncol, k, & ! whenever stratus exists in the equilibrium state ! ! ------------------------------------------------------- ! - use time_manager, only: is_first_step, get_nstep - - implicit none - integer, intent(in) :: lchnk ! Chunk identifier integer, intent(in) :: ncol ! Number of atmospheric columns integer, intent(in) :: k ! Layer index @@ -1186,6 +1427,7 @@ subroutine instratus_condensate( lchnk, ncol, k, & real(r8), intent(in) :: qv0_in(pcols) ! Grid-mean water vapor [kg/kg] real(r8), intent(in) :: ql0_in(pcols) ! Grid-mean LWC [kg/kg] real(r8), intent(in) :: qi0_in(pcols) ! Grid-mean IWC [kg/kg] + real(r8), intent(in) :: ni0_in(pcols) real(r8), intent(in) :: a_dc_in(pcols) ! Deep cumulus cloud fraction real(r8), intent(in) :: ql_dc_in(pcols) ! In-deep cumulus LWC [kg/kg] @@ -1197,6 +1439,11 @@ subroutine instratus_condensate( lchnk, ncol, k, & real(r8), intent(in) :: landfrac(pcols) ! Land fraction real(r8), intent(in) :: snowh(pcols) ! Snow depth (liquid water equivalent) + real(r8), intent(in) :: rhmini_in(pcols) + real(r8), intent(in) :: rhminl_in(pcols) + real(r8), intent(in) :: rhminl_adj_land_in(pcols) + real(r8), intent(in) :: rhminh_in(pcols) + real(r8), intent(out) :: T_out(pcols) ! Temperature [K] real(r8), intent(out) :: qv_out(pcols) ! Grid-mean water vapor [kg/kg] real(r8), intent(out) :: ql_out(pcols) ! Grid-mean LWC [kg/kg] @@ -1267,6 +1514,11 @@ subroutine instratus_condensate( lchnk, ncol, k, & real(r8) Tmax integer caseid + real(r8) rhmini + real(r8) rhminl + real(r8) rhminl_adj_land + real(r8) rhminh + ! ---------------- ! ! Main Computation ! ! ---------------- ! @@ -1275,11 +1527,14 @@ subroutine instratus_condensate( lchnk, ncol, k, & esat_in(1:ncol), qsat_in(1:ncol)) U0_in(:ncol) = qv0_in(:ncol)/qsat_in(:ncol) if( CAMstfrac ) then - call astG_RHU(U0_in(:),p_in(:),qv0_in(:),landfrac(:),snowh(:),al0_st_nc_in(:),G0_nc_in(:),ncol) + call astG_RHU(U0_in(:),p_in(:),qv0_in(:),landfrac(:),snowh(:),al0_st_nc_in(:),G0_nc_in(:),ncol,& + rhminl_in(:), rhminl_adj_land_in(:), rhminh_in(:)) else - call astG_PDF(U0_in(:),p_in(:),qv0_in(:),landfrac(:),snowh(:),al0_st_nc_in(:),G0_nc_in(:),ncol) + call astG_PDF(U0_in(:),p_in(:),qv0_in(:),landfrac(:),snowh(:),al0_st_nc_in(:),G0_nc_in(:),ncol,& + rhminl_in(:), rhminl_adj_land_in(:), rhminh_in(:)) endif - call aist_vector(qv0_in(:),T0_in(:),p_in(:),qi0_in(:),landfrac(:),snowh(:),ai0_st_nc_in(:),ncol) + call aist_vector(qv0_in(:),T0_in(:),p_in(:),qi0_in(:),ni0_in(:),landfrac(:),snowh(:),ai0_st_nc_in(:),ncol,& + rhmaxi, rhmini_in(:), rhminl_in(:), rhminl_adj_land_in(:), rhminh_in(:)) do i = 1, ncol @@ -1309,6 +1564,11 @@ subroutine instratus_condensate( lchnk, ncol, k, & es = esat_in(i) qs = qsat_in(i) + + rhmini = rhmini_in(i) + rhminl = rhminl_in(i) + rhminl_adj_land = rhminl_adj_land_in(i) + rhminh = rhminh_in(i) idxmod = 0 caseid = -1 @@ -1327,11 +1587,14 @@ subroutine instratus_condensate( lchnk, ncol, k, & U0 = (qv0/qsat0) U0_nc = U0 if( CAMstfrac ) then - call astG_RHU_single(U0_nc,p,qv0,landfrac(i),snowh(i),al0_st_nc,G0_nc) + call astG_RHU_single(U0_nc, p, qv0, landfrac(i), snowh(i), al0_st_nc, G0_nc, & + rhminl_in=rhminl, rhminl_adj_land_in=rhminl_adj_land, rhminh_in=rhminh) else - call astG_PDF_single(U0_nc,p,qv0,landfrac(i),snowh(i),al0_st_nc,G0_nc) + call astG_PDF_single(U0_nc, p, qv0, landfrac(i), snowh(i), al0_st_nc, G0_nc, & + rhminl_in=rhminl, rhminl_adj_land_in=rhminl_adj_land, rhminh_in=rhminh) endif - call aist_single(qv0,T0,p,qi0,landfrac(i),snowh(i),ai0_st_nc) + call aist_single(qv0,T0,p,qi0,landfrac(i),snowh(i),ai0_st_nc,& + rhmaxi, rhmini, rhminl, rhminl_adj_land, rhminh) ai0_st = (1._r8-a_dc-a_sc)*ai0_st_nc al0_st = (1._r8-a_dc-a_sc)*al0_st_nc a0_st = max(ai0_st,al0_st) @@ -1383,9 +1646,11 @@ subroutine instratus_condensate( lchnk, ncol, k, & U = qv/qs U_nc = U if( CAMstfrac ) then - call astG_RHU_single(U_nc,p,qv,landfrac(i),snowh(i),al_st_nc,G_nc) + call astG_RHU_single(U_nc, p, qv, landfrac(i), snowh(i), al_st_nc, G_nc, & + rhminl_in=rhminl, rhminl_adj_land_in=rhminl_adj_land, rhminh_in=rhminh) else - call astG_PDF_single(U_nc,p,qv,landfrac(i),snowh(i),al_st_nc,G_nc) + call astG_PDF_single(U_nc, p, qv, landfrac(i), snowh(i), al_st_nc, G_nc, & + rhminl_in=rhminl, rhminl_adj_land_in=rhminl_adj_land, rhminh_in=rhminh) endif al_st = (1._r8-a_dc-a_sc)*al_st_nc caseid = 0 @@ -1407,6 +1672,7 @@ subroutine instratus_condensate( lchnk, ncol, k, & a_dc, ql_dc, qi_dc, & a_sc, ql_sc, qi_sc, ai0_st, & qlst_max, Tmin, Tmax, landfrac(i), snowh(i), & + rhminl, rhminl_adj_land, rhminh, & T, qv, ql, qi ) idxmod = 1 caseid = 2 @@ -1426,6 +1692,7 @@ subroutine instratus_condensate( lchnk, ncol, k, & a_dc, ql_dc, qi_dc, & a_sc, ql_sc, qi_sc, ai0_st, & qlst_min, Tmin, Tmax, landfrac(i), snowh(i), & + rhminl, rhminl_adj_land, rhminh, & T, qv, ql, qi ) idxmod = 1 caseid = 3 @@ -1446,6 +1713,7 @@ subroutine instratus_condensate( lchnk, ncol, k, & a_dc, ql_dc, qi_dc, & a_sc, ql_sc, qi_sc, ai0_st, & qlst_max, Tmin, Tmax, landfrac(i), snowh(i), & + rhminl, rhminl_adj_land, rhminh, & T, qv, ql, qi ) idxmod = 1 caseid = 4 @@ -1461,6 +1729,7 @@ subroutine instratus_condensate( lchnk, ncol, k, & a_dc, ql_dc, qi_dc, & a_sc, ql_sc, qi_sc, ai0_st, & qlst_min, Tmin, Tmax, landfrac(i), snowh(i), & + rhminl, rhminl_adj_land, rhminh, & T, qv, ql, qi ) idxmod = 1 caseid = 5 @@ -1492,15 +1761,18 @@ subroutine instratus_condensate( lchnk, ncol, k, & qi = qi0 if( idxmod .eq. 1 ) then - call aist_single(qv,T,p,qi,landfrac(i),snowh(i),ai_st_nc) + call aist_single(qv,T,p,qi,landfrac(i),snowh(i),ai_st_nc,& + rhmaxi, rhmini, rhminl, rhminl_adj_land, rhminh) ai_st = (1._r8-a_dc-a_sc)*ai_st_nc call qsat_water(T, p, es, qs) U = (qv/qs) U_nc = U if( CAMstfrac ) then - call astG_RHU_single(U_nc,p,qv,landfrac(i),snowh(i),al_st_nc,G_nc) + call astG_RHU_single(U_nc, p, qv, landfrac(i), snowh(i), al_st_nc, G_nc, & + rhminl_in=rhminl, rhminl_adj_land_in=rhminl_adj_land, rhminh_in=rhminh) else - call astG_PDF_single(U_nc,p,qv,landfrac(i),snowh(i),al_st_nc,G_nc) + call astG_PDF_single(U_nc, p, qv, landfrac(i), snowh(i), al_st_nc, G_nc, & + rhminl_in=rhminl, rhminl_adj_land_in=rhminl_adj_land, rhminh_in=rhminh) endif al_st = (1._r8-a_dc-a_sc)*al_st_nc else @@ -1555,6 +1827,7 @@ subroutine instratus_core( lchnk, icol, k, p, & a_dc, ql_dc, qi_dc, & a_sc, ql_sc, qi_sc, ai_st, & qcst_crit, Tmin, Tmax, landfrac, snowh, & + rhminl, rhminl_adj_land, rhminh, & T, qv, ql, qi ) ! ------------------------------------------------------ ! @@ -1563,10 +1836,6 @@ subroutine instratus_core( lchnk, icol, k, p, & ! is satisfied. ! ! ------------------------------------------------------ ! - use time_manager, only: is_first_step, get_nstep - - implicit none - integer, intent(in) :: lchnk ! Chunk identifier integer, intent(in) :: icol ! Number of atmospheric columns integer, intent(in) :: k ! Layer index @@ -1592,6 +1861,10 @@ subroutine instratus_core( lchnk, icol, k, p, & real(r8), intent(in) :: landfrac ! Land fraction real(r8), intent(in) :: snowh ! Snow depth (liquid water equivalent) + real(r8), intent(in) :: rhminl + real(r8), intent(in) :: rhminl_adj_land + real(r8), intent(in) :: rhminh + real(r8), intent(out) :: T ! Temperature [K] real(r8), intent(out) :: qv ! Grid-mean water vapor [kg/kg] real(r8), intent(out) :: ql ! Grid-mean LWC [kg/kg] @@ -1641,15 +1914,18 @@ subroutine instratus_core( lchnk, icol, k, p, & call funcd_instratus( x1, p, T0, qv0, ql0, qi0, fice0, muQ0, qc_nc0, & a_dc, ql_dc, qi_dc, a_sc, ql_sc, qi_sc, ai_st, & qcst_crit, landfrac, snowh, & + rhminl, rhminl_adj_land, rhminh, & fl, df, qc_nc, fice, al_st ) call funcd_instratus( x2, p, T0, qv0, ql0, qi0, fice0, muQ0, qc_nc0, & a_dc, ql_dc, qi_dc, a_sc, ql_sc, qi_sc, ai_st, & qcst_crit, landfrac, snowh, & + rhminl, rhminl_adj_land, rhminh, & fh, df, qc_nc, fice, al_st ) if((fl > 0._r8 .and. fh > 0._r8) .or. (fl < 0._r8 .and. fh < 0._r8)) then call funcd_instratus( T0, p, T0, qv0, ql0, qi0, fice0, muQ0, qc_nc0, & a_dc, ql_dc, qi_dc, a_sc, ql_sc, qi_sc, ai_st, & qcst_crit, landfrac, snowh, & + rhminl, rhminl_adj_land, rhminh, & fl, df, qc_nc, fice, al_st ) rtsafe = T0 goto 10 @@ -1673,6 +1949,7 @@ subroutine instratus_core( lchnk, icol, k, p, & call funcd_instratus( rtsafe, p, T0, qv0, ql0, qi0, fice0, muQ0, qc_nc0, & a_dc, ql_dc, qi_dc, a_sc, ql_sc, qi_sc, ai_st, & qcst_crit, landfrac, snowh, & + rhminl, rhminl_adj_land, rhminh, & f, df, qc_nc, fice, al_st ) do j = 1, 20 if(((rtsafe-xh)*df-f)*((rtsafe-xl)*df-f) > 0._r8 .or. abs(2.0_r8*f) > abs(dxold*df) ) then @@ -1691,6 +1968,7 @@ subroutine instratus_core( lchnk, icol, k, p, & call funcd_instratus( rtsafe, p, T0, qv0, ql0, qi0, fice0, muQ0, qc_nc0, & a_dc, ql_dc, qi_dc, a_sc, ql_sc, qi_sc, ai_st, & qcst_crit, landfrac, snowh, & + rhminl, rhminl_adj_land, rhminh, & f, df, qc_nc, fice, al_st ) ! Sep.21.2010. Sungsu modified to enhance convergence and guarantee 'qlst_min < qlst < qlst_max'. if( qcst_crit < 0.5_r8 * ( qlst_min + qlst_max ) ) then @@ -1732,6 +2010,7 @@ end subroutine instratus_core subroutine funcd_instratus( T, p, T0, qv0, ql0, qi0, fice0, muQ0, qc_nc0, & a_dc, ql_dc, qi_dc, a_sc, ql_sc, qi_sc, ai_st, & qcst_crit, landfrac, snowh, & + rhminl, rhminl_adj_land, rhminh, & f, fg, qc_nc, fice, al_st ) ! --------------------------------------------------- ! @@ -1764,6 +2043,10 @@ subroutine funcd_instratus( T, p, T0, qv0, ql0, qi0, fice0, muQ0, qc_nc0, & real(r8), intent(in) :: landfrac ! Land fraction real(r8), intent(in) :: snowh ! Snow depth (liquid water equivalent) + real(r8), intent(in) :: rhminl + real(r8), intent(in) :: rhminl_adj_land + real(r8), intent(in) :: rhminh + real(r8), intent(out) :: f ! Value of minimization function at T real(r8), intent(out) :: fg ! Gradient of minimization function real(r8), intent(out) :: qc_nc ! @@ -1802,9 +2085,11 @@ subroutine funcd_instratus( T, p, T0, qv0, ql0, qi0, fice0, muQ0, qc_nc0, & U = (qv/qs) U_nc = U if( CAMstfrac ) then - call astG_RHU_single(U_nc,p,qv,landfrac,snowh,al_st_nc,G_nc) + call astG_RHU_single(U_nc, p, qv, landfrac, snowh, al_st_nc, G_nc, & + rhminl_in=rhminl, rhminl_adj_land_in=rhminl_adj_land, rhminh_in=rhminh) else - call astG_PDF_single(U_nc,p,qv,landfrac,snowh,al_st_nc,G_nc) + call astG_PDF_single(U_nc, p, qv, landfrac, snowh, al_st_nc, G_nc, & + rhminl_in=rhminl, rhminl_adj_land_in=rhminl_adj_land, rhminh_in=rhminh) endif al_st = (1._r8-a_dc-a_sc)*al_st_nc dUdt = -(alpha*dqcncdt+beta) @@ -1832,10 +2117,6 @@ subroutine gridmean_RH( lchnk, icol, k, p, T, qv, ql, qi, & ! verison for MG not for RK. ! ! ------------------------------------------------------------- ! - use time_manager, only: is_first_step, get_nstep - - implicit none - integer, intent(in) :: lchnk ! Chunk identifier integer, intent(in) :: icol ! Number of atmospheric columns integer, intent(in) :: k ! Layer index @@ -2002,875 +2283,6 @@ subroutine positive_moisture( ncol, dt, qvmin, qlmin, qimin, dp, & end subroutine positive_moisture - ! ----------------- ! - ! End of subroutine ! - ! ----------------- ! - - subroutine astG_PDF_single( U, p, qv, landfrac, snowh, a, Ga, orhmin ) - - ! --------------------------------------------------------- ! - ! Compute 'stratus fraction(a)' and Gs=(dU/da) from the ! - ! analytical formulation of triangular PDF. ! - ! Here, 'dV' is the ratio of 'half-width of PDF / qs(p,T)', ! - ! so using constant 'dV' assume that width is proportional ! - ! to the saturation specific humidity. ! - ! dV ~ 0.1. ! - ! cldrh : RH of in-stratus( = 1 if no supersaturation) ! - ! Note that if U > 1, Ga = 1.e10 instead of Ga = 0, that is ! - ! G is discontinuous across U = 1. In fact, it does not ! - ! matter whether Ga = 1.e10 or 0 at a = 1: I derived that ! - ! they will produce the same results. ! - ! --------------------------------------------------------- ! - - implicit none - - real(r8), intent(in) :: U ! Relative humidity - real(r8), intent(in) :: p ! Pressure [Pa] - real(r8), intent(in) :: qv ! Grid-mean water vapor specific humidity [kg/kg] - real(r8), intent(in) :: landfrac ! Land fraction - real(r8), intent(in) :: snowh ! Snow depth (liquid water equivalent) - - real(r8), intent(out) :: a ! Stratus fraction - real(r8), intent(out) :: Ga ! dU/da - real(r8), optional, intent(out) :: orhmin ! Critical RH - - ! Local variables - integer :: i ! Loop indexes - real(r8) dV ! Width of triangular PDF - real(r8) cldrh ! RH of stratus cloud - real(r8) rhmin ! Critical RH - real(r8) rhwght - - ! Statement functions - logical land - land = nint(landfrac) == 1 - - ! ---------- ! - ! Parameters ! - ! ---------- ! - - cldrh = 1.0_r8 - - ! ---------------- ! - ! Main computation ! - ! ---------------- ! - - if( p .ge. premib ) then - - if( land .and. (snowh.le.0.000001_r8) ) then - rhmin = rhminl - rhminl_adj_land - else - rhmin = rhminl - endif - - dV = cldrh - rhmin - - if( U .ge. 1._r8 ) then - a = 1._r8 - Ga = 1.e10_r8 - elseif( U .gt. (cldrh-dV/6._r8) .and. U .lt. 1._r8 ) then - a = 1._r8 - (-3._r8/sqrt(2._r8)*(U-cldrh)/dV)**(2._r8/3._r8) - Ga = dV/sqrt(2._r8)*sqrt(1._r8-a) - elseif( U .gt. (cldrh-dV) .and. U .le. (cldrh-dV/6._r8) ) then - a = 4._r8*(cos((1._r8/3._r8)*(acos((3._r8/2._r8/sqrt(2._r8))* & - (1._r8+(U-cldrh)/dV))-2._r8*3.141592_r8)))**2._r8 - Ga = dV/sqrt(2._r8)*(1._r8/sqrt(a)-sqrt(a)) - elseif( U .le. (cldrh-dV) ) then - a = 0._r8 - Ga = 1.e10_r8 - endif - - if( freeze_dry ) then - a = a *max(0.15_r8,min(1.0_r8,qv/0.0030_r8)) - Ga = Ga/max(0.15_r8,min(1.0_r8,qv/0.0030_r8)) - endif - - elseif( p .lt. premit ) then - - rhmin = rhminh - dV = cldrh - rhmin - - if( U .ge. 1._r8 ) then - a = 1._r8 - Ga = 1.e10_r8 - elseif( U .gt. (cldrh-dV/6._r8) .and. U .lt. 1._r8 ) then - a = 1._r8 - (-3._r8/sqrt(2._r8)*(U-cldrh)/dV)**(2._r8/3._r8) - Ga = dV/sqrt(2._r8)*sqrt(1._r8-a) - elseif( U .gt. (cldrh-dV) .and. U .le. (cldrh-dV/6._r8) ) then - a = 4._r8*(cos((1._r8/3._r8)*(acos((3._r8/2._r8/sqrt(2._r8))* & - (1._r8+(U-cldrh)/dV))-2._r8*3.141592_r8)))**2._r8 - Ga = dV/sqrt(2._r8)*(1._r8/sqrt(a)-sqrt(a)) - elseif( U .le. (cldrh-dV) ) then - a = 0._r8 - Ga = 1.e10_r8 - endif - - else - - rhwght = (premib-(max(p,premit)))/(premib-premit) - - ! if( land .and. (snowh.le.0.000001_r8) ) then - ! rhmin = rhminh*rhwght + (rhminl - rhminl_adj_land)*(1.0_r8-rhwght) - ! else - rhmin = rhminh*rhwght + rhminl*(1.0_r8-rhwght) - ! endif - - dV = cldrh - rhmin - - if( U .ge. 1._r8 ) then - a = 1._r8 - Ga = 1.e10_r8 - elseif( U .gt. (cldrh-dV/6._r8) .and. U .lt. 1._r8 ) then - a = 1._r8 - (-3._r8/sqrt(2._r8)*(U-cldrh)/dV)**(2._r8/3._r8) - Ga = dV/sqrt(2._r8)*sqrt(1._r8-a) - elseif( U .gt. (cldrh-dV) .and. U .le. (cldrh-dV/6._r8) ) then - a = 4._r8*(cos((1._r8/3._r8)*(acos((3._r8/2._r8/sqrt(2._r8))* & - (1._r8+(U-cldrh)/dV))-2._r8*3.141592_r8)))**2._r8 - Ga = dV/sqrt(2._r8)*(1._r8/sqrt(a)-sqrt(a)) - elseif( U .le. (cldrh-dV) ) then - a = 0._r8 - Ga = 1.e10_r8 - endif - - endif - - if (present(orhmin)) orhmin = rhmin - - return - end subroutine astG_PDF_single - - ! ----------------- ! - ! End of subroutine ! - ! ----------------- ! - - subroutine astG_PDF( U_in, p_in, qv_in, landfrac_in, snowh_in, a_out, Ga_out, ncol ) - - ! --------------------------------------------------------- ! - ! Compute 'stratus fraction(a)' and Gs=(dU/da) from the ! - ! analytical formulation of triangular PDF. ! - ! Here, 'dV' is the ratio of 'half-width of PDF / qs(p,T)', ! - ! so using constant 'dV' assume that width is proportional ! - ! to the saturation specific humidity. ! - ! dV ~ 0.1. ! - ! cldrh : RH of in-stratus( = 1 if no supersaturation) ! - ! Note that if U > 1, Ga = 1.e10 instead of Ga = 0, that is ! - ! G is discontinuous across U = 1. In fact, it does not ! - ! matter whether Ga = 1.e10 or 0 at a = 1: I derived that ! - ! they will produce the same results. ! - ! --------------------------------------------------------- ! - - implicit none - - integer, intent(in) :: ncol - real(r8), intent(in) :: U_in(pcols) ! Relative humidity - real(r8), intent(in) :: p_in(pcols) ! Pressure [Pa] - real(r8), intent(in) :: qv_in(pcols) ! Grid-mean water vapor specific humidity [kg/kg] - real(r8), intent(in) :: landfrac_in(pcols) ! Land fraction - real(r8), intent(in) :: snowh_in(pcols) ! Snow depth (liquid water equivalent) - - real(r8), intent(out) :: a_out(pcols) ! Stratus fraction - real(r8), intent(out) :: Ga_out(pcols) ! dU/da - - real(r8) :: U ! Relative humidity - real(r8) :: p ! Pressure [Pa] - real(r8) :: qv ! Grid-mean water vapor specific humidity [kg/kg] - real(r8) :: landfrac ! Land fraction - real(r8) :: snowh ! Snow depth (liquid water equivalent) - - real(r8) :: a ! Stratus fraction - real(r8) :: Ga ! dU/da - - ! Local variables - integer :: i ! Loop indexes - real(r8) dV ! Width of triangular PDF - real(r8) cldrh ! RH of stratus cloud - real(r8) rhmin ! Critical RH - real(r8) rhwght - - ! Statement functions - logical land - land(i) = nint(landfrac_in(i)) == 1 - - ! ---------- ! - ! Parameters ! - ! ---------- ! - - cldrh = 1.0_r8 - - ! ---------------- ! - ! Main computation ! - ! ---------------- ! - - a_out(:) = 0._r8 - Ga_out(:) = 0._r8 - - do i = 1, ncol - - U = U_in(i) - p = p_in(i) - qv = qv_in(i) - landfrac = landfrac_in(i) - snowh = snowh_in(i) - - if( p .ge. premib ) then - - if( land(i) .and. (snowh.le.0.000001_r8) ) then - rhmin = rhminl - rhminl_adj_land - else - rhmin = rhminl - endif - - dV = cldrh - rhmin - - if( U .ge. 1._r8 ) then - a = 1._r8 - Ga = 1.e10_r8 - elseif( U .gt. (cldrh-dV/6._r8) .and. U .lt. 1._r8 ) then - a = 1._r8 - (-3._r8/sqrt(2._r8)*(U-cldrh)/dV)**(2._r8/3._r8) - Ga = dV/sqrt(2._r8)*sqrt(1._r8-a) - elseif( U .gt. (cldrh-dV) .and. U .le. (cldrh-dV/6._r8) ) then - a = 4._r8*(cos((1._r8/3._r8)*(acos((3._r8/2._r8/sqrt(2._r8))* & - (1._r8+(U-cldrh)/dV))-2._r8*3.141592_r8)))**2._r8 - Ga = dV/sqrt(2._r8)*(1._r8/sqrt(a)-sqrt(a)) - elseif( U .le. (cldrh-dV) ) then - a = 0._r8 - Ga = 1.e10_r8 - endif - - if( freeze_dry ) then - a = a *max(0.15_r8,min(1.0_r8,qv/0.0030_r8)) - Ga = Ga/max(0.15_r8,min(1.0_r8,qv/0.0030_r8)) - endif - - elseif( p .lt. premit ) then - - rhmin = rhminh - dV = cldrh - rhmin - - if( U .ge. 1._r8 ) then - a = 1._r8 - Ga = 1.e10_r8 - elseif( U .gt. (cldrh-dV/6._r8) .and. U .lt. 1._r8 ) then - a = 1._r8 - (-3._r8/sqrt(2._r8)*(U-cldrh)/dV)**(2._r8/3._r8) - Ga = dV/sqrt(2._r8)*sqrt(1._r8-a) - elseif( U .gt. (cldrh-dV) .and. U .le. (cldrh-dV/6._r8) ) then - a = 4._r8*(cos((1._r8/3._r8)*(acos((3._r8/2._r8/sqrt(2._r8))* & - (1._r8+(U-cldrh)/dV))-2._r8*3.141592_r8)))**2._r8 - Ga = dV/sqrt(2._r8)*(1._r8/sqrt(a)-sqrt(a)) - elseif( U .le. (cldrh-dV) ) then - a = 0._r8 - Ga = 1.e10_r8 - endif - - else - - rhwght = (premib-(max(p,premit)))/(premib-premit) - - ! if( land(i) .and. (snowh.le.0.000001_r8) ) then - ! rhmin = rhminh*rhwght + (rhminl - rhminl_adj_land)*(1.0_r8-rhwght) - ! else - rhmin = rhminh*rhwght + rhminl*(1.0_r8-rhwght) - ! endif - - dV = cldrh - rhmin - - if( U .ge. 1._r8 ) then - a = 1._r8 - Ga = 1.e10_r8 - elseif( U .gt. (cldrh-dV/6._r8) .and. U .lt. 1._r8 ) then - a = 1._r8 - (-3._r8/sqrt(2._r8)*(U-cldrh)/dV)**(2._r8/3._r8) - Ga = dV/sqrt(2._r8)*sqrt(1._r8-a) - elseif( U .gt. (cldrh-dV) .and. U .le. (cldrh-dV/6._r8) ) then - a = 4._r8*(cos((1._r8/3._r8)*(acos((3._r8/2._r8/sqrt(2._r8))* & - (1._r8+(U-cldrh)/dV))-2._r8*3.141592_r8)))**2._r8 - Ga = dV/sqrt(2._r8)*(1._r8/sqrt(a)-sqrt(a)) - elseif( U .le. (cldrh-dV) ) then - a = 0._r8 - Ga = 1.e10_r8 - endif - - endif - - a_out(i) = a - Ga_out(i) = Ga - - enddo - - return - end subroutine astG_PDF - - ! ----------------- ! - ! End of subroutine ! - ! ----------------- ! - - subroutine astG_RHU_single( U, p, qv, landfrac, snowh, a, Ga, orhmin ) - - ! --------------------------------------------------------- ! - ! Compute 'stratus fraction(a)' and Gs=(dU/da) from the ! - ! CAM35 cloud fraction formula. ! - ! Below is valid only for CAMUW at 1.9x2.5 fv dynamics core ! - ! For the other cases, I should re-define 'rhminl,rhminh' & ! - ! 'premib,premit'. ! - ! Note that if U > 1, Ga = 1.e10 instead of Ga = 0, that is ! - ! G is discontinuous across U = 1. ! - ! --------------------------------------------------------- ! - - implicit none - - real(r8), intent(in) :: U ! Relative humidity - real(r8), intent(in) :: p ! Pressure [Pa] - real(r8), intent(in) :: qv ! Grid-mean water vapor specific humidity [kg/kg] - real(r8), intent(in) :: landfrac ! Land fraction - real(r8), intent(in) :: snowh ! Snow depth (liquid water equivalent) - - real(r8), intent(out) :: a ! Stratus fraction - real(r8), intent(out) :: Ga ! dU/da - real(r8), optional, intent(out) :: orhmin ! Critical RH - - ! Local variables - real(r8) rhmin ! Critical RH - real(r8) rhdif ! Factor for stratus fraction - real(r8) rhwght - - ! Statement functions - logical land - land = nint(landfrac) == 1 - - ! ---------------- ! - ! Main computation ! - ! ---------------- ! - - if( p .ge. premib ) then - - if( land .and. (snowh.le.0.000001_r8) ) then - rhmin = rhminl - rhminl_adj_land - else - rhmin = rhminl - endif - rhdif = (U-rhmin)/(1.0_r8-rhmin) - a = min(1._r8,(max(rhdif,0.0_r8))**2) - if( (U.ge.1._r8) .or. (U.le.rhmin) ) then - Ga = 1.e20_r8 - else - Ga = 0.5_r8*(1._r8-rhmin)*((1._r8-rhmin)/(U-rhmin)) - endif - if( freeze_dry ) then - a = a*max(0.15_r8,min(1.0_r8,qv/0.0030_r8)) - Ga = Ga/max(0.15_r8,min(1.0_r8,qv/0.0030_r8)) - endif - - elseif( p .lt. premit ) then - - rhmin = rhminh - rhdif = (U-rhmin)/(1.0_r8-rhmin) - a = min(1._r8,(max(rhdif,0._r8))**2) - if( (U.ge.1._r8) .or. (U.le.rhmin) ) then - Ga = 1.e20_r8 - else - Ga = 0.5_r8*(1._r8-rhmin)*((1._r8-rhmin)/(U-rhmin)) - endif - - else - - rhwght = (premib-(max(p,premit)))/(premib-premit) - - ! if( land .and. (snowh.le.0.000001_r8) ) then - ! rhmin = rhminh*rhwght + (rhminl - rhminl_adj_land)*(1.0_r8-rhwght) - ! else - rhmin = rhminh*rhwght + rhminl*(1.0_r8-rhwght) - ! endif - - rhdif = (U-rhmin)/(1.0_r8-rhmin) - a = min(1._r8,(max(rhdif,0._r8))**2) - if( (U.ge.1._r8) .or. (U.le.rhmin) ) then - Ga = 1.e10_r8 - else - Ga = 0.5_r8*(1._r8-rhmin)*((1._r8-rhmin)/(U-rhmin)) - endif - - endif - - if (present(orhmin)) orhmin = rhmin - - return - end subroutine astG_RHU_single - - ! ----------------- ! - ! End of subroutine ! - ! ----------------- ! - - subroutine astG_RHU( U_in, p_in, qv_in, landfrac_in, snowh_in, a_out, Ga_out, ncol ) - - ! --------------------------------------------------------- ! - ! Compute 'stratus fraction(a)' and Gs=(dU/da) from the ! - ! CAM35 cloud fraction formula. ! - ! Below is valid only for CAMUW at 1.9x2.5 fv dynamics core ! - ! For the other cases, I should re-define 'rhminl,rhminh' & ! - ! 'premib,premit'. ! - ! Note that if U > 1, Ga = 1.e10 instead of Ga = 0, that is ! - ! G is discontinuous across U = 1. ! - ! --------------------------------------------------------- ! - - implicit none - - integer, intent(in) :: ncol - real(r8), intent(in) :: U_in(pcols) ! Relative humidity - real(r8), intent(in) :: p_in(pcols) ! Pressure [Pa] - real(r8), intent(in) :: qv_in(pcols) ! Grid-mean water vapor specific humidity [kg/kg] - real(r8), intent(in) :: landfrac_in(pcols) ! Land fraction - real(r8), intent(in) :: snowh_in(pcols) ! Snow depth (liquid water equivalent) - - real(r8), intent(out) :: a_out(pcols) ! Stratus fraction - real(r8), intent(out) :: Ga_out(pcols) ! dU/da - - real(r8) :: U ! Relative humidity - real(r8) :: p ! Pressure [Pa] - real(r8) :: qv ! Grid-mean water vapor specific humidity [kg/kg] - real(r8) :: landfrac ! Land fraction - real(r8) :: snowh ! Snow depth (liquid water equivalent) - - real(r8) :: a ! Stratus fraction - real(r8) :: Ga ! dU/da - - ! Local variables - integer i - real(r8) rhmin ! Critical RH - real(r8) rhdif ! Factor for stratus fraction - real(r8) rhwght - - ! Statement functions - logical land - land(i) = nint(landfrac_in(i)) == 1 - - ! ---------------- ! - ! Main computation ! - ! ---------------- ! - - a_out(:) = 0._r8 - Ga_out(:) = 0._r8 - - do i = 1, ncol - - U = U_in(i) - p = p_in(i) - qv = qv_in(i) - landfrac = landfrac_in(i) - snowh = snowh_in(i) - - if( p .ge. premib ) then - - if( land(i) .and. (snowh.le.0.000001_r8) ) then - rhmin = rhminl - rhminl_adj_land - else - rhmin = rhminl - endif - rhdif = (U-rhmin)/(1.0_r8-rhmin) - a = min(1._r8,(max(rhdif,0.0_r8))**2) - if( (U.ge.1._r8) .or. (U.le.rhmin) ) then - Ga = 1.e20_r8 - else - Ga = 0.5_r8*(1._r8-rhmin)*((1._r8-rhmin)/(U-rhmin)) - endif - if( freeze_dry ) then - a = a*max(0.15_r8,min(1.0_r8,qv/0.0030_r8)) - Ga = Ga/max(0.15_r8,min(1.0_r8,qv/0.0030_r8)) - endif - - elseif( p .lt. premit ) then - - rhmin = rhminh - rhdif = (U-rhmin)/(1.0_r8-rhmin) - a = min(1._r8,(max(rhdif,0._r8))**2) - if( (U.ge.1._r8) .or. (U.le.rhmin) ) then - Ga = 1.e20_r8 - else - Ga = 0.5_r8*(1._r8-rhmin)*((1._r8-rhmin)/(U-rhmin)) - endif - - else - - rhwght = (premib-(max(p,premit)))/(premib-premit) - - ! if( land(i) .and. (snowh.le.0.000001_r8) ) then - ! rhmin = rhminh*rhwght + (rhminl - rhminl_adj_land)*(1.0_r8-rhwght) - ! else - rhmin = rhminh*rhwght + rhminl*(1.0_r8-rhwght) - ! endif - - rhdif = (U-rhmin)/(1.0_r8-rhmin) - a = min(1._r8,(max(rhdif,0._r8))**2) - if( (U.ge.1._r8) .or. (U.le.rhmin) ) then - Ga = 1.e10_r8 - else - Ga = 0.5_r8*(1._r8-rhmin)*((1._r8-rhmin)/(U-rhmin)) - endif - - endif - - a_out(i) = a - Ga_out(i) = Ga - - enddo - - return - end subroutine astG_RHU - - ! ----------------- ! - ! End of subroutine ! - ! ----------------- ! - - subroutine aist_single( qv, T, p, qi, landfrac, snowh, aist ) - - ! --------------------------------------------------------- ! - ! Compute non-physical ice stratus fraction ! - ! --------------------------------------------------------- ! - - use physconst, only: rair - - implicit none - - real(r8), intent(in) :: qv ! Grid-mean water vapor[kg/kg] - real(r8), intent(in) :: T ! Temperature - real(r8), intent(in) :: p ! Pressure [Pa] - real(r8), intent(in) :: qi ! Grid-mean ice water content [kg/kg] - real(r8), intent(in) :: landfrac ! Land fraction - real(r8), intent(in) :: snowh ! Snow depth (liquid water equivalent) - - real(r8), intent(out) :: aist ! Non-physical ice stratus fraction ( 0<= aist <= 1 ) - - ! Local variables - real(r8) rhmin ! Critical RH - real(r8) rhwght - - real(r8) a,b,c,as,bs,cs ! Fit parameters - real(r8) Kc ! Constant for ice cloud calc (wood & field) - real(r8) ttmp ! Limited temperature - real(r8) icicval ! Empirical IWC value [ kg/kg ] - real(r8) rho ! Local air density - real(r8) esl ! Liq sat vapor pressure - real(r8) esi ! Ice sat vapor pressure - real(r8) ncf,phi ! Wilson and Ballard parameters - real(r8) es, qs - - real(r8) rhi ! grid box averaged relative humidity over ice - real(r8) minice ! minimum grid box avg ice for having a 'cloud' - real(r8) mincld ! minimum ice cloud fraction threshold - real(r8) icimr ! in cloud ice mixing ratio - ! real(r8) qist_min ! minimum in cloud ice mixing ratio - ! real(r8) qist_max ! maximum in cloud ice mixing ratio - real(r8) rhdif ! working variable for slingo scheme - - - ! Statement functions - logical land - land = nint(landfrac) == 1 - - ! --------- ! - ! Constants ! - ! --------- ! - - ! Wang and Sassen IWC paramters ( Option.1 ) - a = 26.87_r8 - b = 0.569_r8 - c = 0.002892_r8 - ! Schiller parameters ( Option.2 ) - as = -68.4202_r8 - bs = 0.983917_r8 - cs = 2.81795_r8 - ! Wood and Field parameters ( Option.3 ) - Kc = 75._r8 - ! Wilson & Ballard closure ( Option.4. smaller = more ice clouds) - ! Slingo modified (option 5) - minice = 1.e-12_r8 - mincld = 1.e-4_r8 - ! qist_min = 1.e-7_r8 - ! qist_max = 5.e-3_r8 - - ! ---------------- ! - ! Main computation ! - ! ---------------- ! - - call qsat_water(T, p, es, qs) - esl = svp_water(T) - esi = svp_ice(T) - - if( iceopt.lt.3 ) then - if( iceopt.eq.1 ) then - ttmp = max(195._r8,min(T,253._r8)) - 273.16_r8 - icicval = a + b * ttmp + c * ttmp**2._r8 - rho = p/(rair*T) - icicval = icicval * 1.e-6_r8 / rho - else - ttmp = max(190._r8,min(T,273.16_r8)) - icicval = 10._r8 **(as * bs**ttmp + cs) - icicval = icicval * 1.e-6_r8 * 18._r8 / 28.97_r8 - endif - aist = max(0._r8,min(qi/icicval,1._r8)) - elseif( iceopt.eq.3 ) then - aist = 1._r8 - exp(-Kc*qi/(qs*(esi/esl))) - aist = max(0._r8,min(aist,1._r8)) - elseif( iceopt.eq.4) then - if( p .ge. premib ) then - if( land .and. (snowh.le.0.000001_r8) ) then - rhmin = rhminl - rhminl_adj_land - else - rhmin = rhminl - endif - elseif( p .lt. premit ) then - rhmin = rhminh - else - rhwght = (premib-(max(p,premit)))/(premib-premit) - ! if( land .and. (snowh.le.0.000001_r8) ) then - ! rhmin = rhminh*rhwght + (rhminl - rhminl_adj_land)*(1.0_r8-rhwght) - ! else - rhmin = rhminh*rhwght + rhminl*(1.0_r8-rhwght) - ! endif - endif - ncf = qi/((1._r8 - icecrit)*qs) - if( ncf.le.0._r8 ) then - aist = 0._r8 - elseif( ncf.gt.0._r8 .and. ncf.le.1._r8/6._r8 ) then - aist = 0.5_r8*(6._r8 * ncf)**(2._r8/3._r8) - elseif( ncf.gt.1._r8/6._r8 .and. ncf.lt.1._r8 ) then - phi = (acos(3._r8*(1._r8-ncf)/2._r8**(3._r8/2._r8))+4._r8*3.1415927_r8)/3._r8 - aist = (1._r8 - 4._r8 * cos(phi) * cos(phi)) - else - aist = 1._r8 - endif - aist = max(0._r8,min(aist,1._r8)) - elseif (iceopt.eq.5) then -! set rh ice cloud fraction - rhi= (qv+qi)/qs * (esl/esi) - rhdif= (rhi-rhmini) / (rhmaxi - rhmini) - aist = min(1.0_r8, max(rhdif,0._r8)**2) - -! limiter to remove empty cloud and ice with no cloud -! and set icecld fraction to mincld if ice exists - - if (qi.lt.minice) then - aist=0._r8 - else - aist=max(mincld,aist) - endif - -! enforce limits on icimr - if (qi.ge.minice) then - icimr=qi/aist - -!minimum - if (icimr.lt.qist_min) then - aist = max(0._r8,min(1._r8,qi/qist_min)) - endif -!maximum - if (icimr.gt.qist_max) then - aist = max(0._r8,min(1._r8,qi/qist_max)) - endif - - endif - endif - - ! 0.999_r8 is added to prevent infinite 'ql_st' at the end of instratus_condensate - ! computed after updating 'qi_st'. - - aist = max(0._r8,min(aist,0.999_r8)) - - return - end subroutine aist_single - - ! ----------------- ! - ! End of subroutine ! - ! ----------------- ! - - subroutine aist_vector( qv_in, T_in, p_in, qi_in, landfrac_in, snowh_in, aist_out, ncol ) - - ! --------------------------------------------------------- ! - ! Compute non-physical ice stratus fraction ! - ! --------------------------------------------------------- ! - - use physconst, only: rair - - implicit none - - integer, intent(in) :: ncol - real(r8), intent(in) :: qv_in(pcols) ! Grid-mean water vapor[kg/kg] - real(r8), intent(in) :: T_in(pcols) ! Temperature - real(r8), intent(in) :: p_in(pcols) ! Pressure [Pa] - real(r8), intent(in) :: qi_in(pcols) ! Grid-mean ice water content [kg/kg] - real(r8), intent(in) :: landfrac_in(pcols) ! Land fraction - real(r8), intent(in) :: snowh_in(pcols) ! Snow depth (liquid water equivalent) - real(r8), intent(out) :: aist_out(pcols) ! Non-physical ice stratus fraction ( 0<= aist <= 1 ) - - ! Local variables - - real(r8) qv ! Grid-mean water vapor[kg/kg] - real(r8) T ! Temperature - real(r8) p ! Pressure [Pa] - real(r8) qi ! Grid-mean ice water content [kg/kg] - real(r8) landfrac ! Land fraction - real(r8) snowh ! Snow depth (liquid water equivalent) - real(r8) aist ! Non-physical ice stratus fraction ( 0<= aist <= 1 ) - - real(r8) rhmin ! Critical RH - real(r8) rhwght - - real(r8) a,b,c,as,bs,cs ! Fit parameters - real(r8) Kc ! Constant for ice cloud calc (wood & field) - real(r8) ttmp ! Limited temperature - real(r8) icicval ! Empirical IWC value [ kg/kg ] - real(r8) rho ! Local air density - real(r8) esl ! Liq sat vapor pressure - real(r8) esi ! Ice sat vapor pressure - real(r8) ncf,phi ! Wilson and Ballard parameters - real(r8) qs - real(r8) esat_in(pcols) - real(r8) qsat_in(pcols) - - real(r8) rhi ! grid box averaged relative humidity over ice - real(r8) minice ! minimum grid box avg ice for having a 'cloud' - real(r8) mincld ! minimum ice cloud fraction threshold - real(r8) icimr ! in cloud ice mixing ratio - ! real(r8) qist_min ! minimum in cloud ice mixing ratio - ! real(r8) qist_max ! maximum in cloud ice mixing ratio - real(r8) rhdif ! working variable for slingo scheme - - integer i - - - ! Statement functions - logical land - land(i) = nint(landfrac_in(i)) == 1 - - ! --------- ! - ! Constants ! - ! --------- ! - - ! Wang and Sassen IWC paramters ( Option.1 ) - a = 26.87_r8 - b = 0.569_r8 - c = 0.002892_r8 - ! Schiller parameters ( Option.2 ) - as = -68.4202_r8 - bs = 0.983917_r8 - cs = 2.81795_r8 - ! Wood and Field parameters ( Option.3 ) - Kc = 75._r8 - ! Wilson & Ballard closure ( Option.4. smaller = more ice clouds) - ! Slingo modified (option 5) - minice = 1.e-12_r8 - mincld = 1.e-4_r8 - ! qist_min = 1.e-7_r8 - ! qist_max = 5.e-3_r8 - - ! ---------------- ! - ! Main computation ! - ! ---------------- ! - - aist_out(:) = 0._r8 - esat_in(:) = 0._r8 - qsat_in(:) = 0._r8 - - call qsat_water(T_in(1:ncol), p_in(1:ncol), & - esat_in(1:ncol), qsat_in(1:ncol)) - - do i = 1, ncol - - landfrac = landfrac_in(i) - snowh = snowh_in(i) - T = T_in(i) - qv = qv_in(i) - p = p_in(i) - qi = qi_in(i) - qs = qsat_in(i) - esl = svp_water(T) - esi = svp_ice(T) - - if( iceopt.lt.3 ) then - if( iceopt.eq.1 ) then - ttmp = max(195._r8,min(T,253._r8)) - 273.16_r8 - icicval = a + b * ttmp + c * ttmp**2._r8 - rho = p/(rair*T) - icicval = icicval * 1.e-6_r8 / rho - else - ttmp = max(190._r8,min(T,273.16_r8)) - icicval = 10._r8 **(as * bs**ttmp + cs) - icicval = icicval * 1.e-6_r8 * 18._r8 / 28.97_r8 - endif - aist = max(0._r8,min(qi/icicval,1._r8)) - elseif( iceopt.eq.3 ) then - aist = 1._r8 - exp(-Kc*qi/(qs*(esi/esl))) - aist = max(0._r8,min(aist,1._r8)) - elseif( iceopt.eq.4) then - if( p .ge. premib ) then - if( land(i) .and. (snowh.le.0.000001_r8) ) then - rhmin = rhminl - rhminl_adj_land - else - rhmin = rhminl - endif - elseif( p .lt. premit ) then - rhmin = rhminh - else - rhwght = (premib-(max(p,premit)))/(premib-premit) - ! if( land(i) .and. (snowh.le.0.000001_r8) ) then - ! rhmin = rhminh*rhwght + (rhminl - rhminl_adj_land)*(1.0_r8-rhwght) - ! else - rhmin = rhminh*rhwght + rhminl*(1.0_r8-rhwght) - ! endif - endif - ncf = qi/((1._r8 - icecrit)*qs) - if( ncf.le.0._r8 ) then - aist = 0._r8 - elseif( ncf.gt.0._r8 .and. ncf.le.1._r8/6._r8 ) then - aist = 0.5_r8*(6._r8 * ncf)**(2._r8/3._r8) - elseif( ncf.gt.1._r8/6._r8 .and. ncf.lt.1._r8 ) then - phi = (acos(3._r8*(1._r8-ncf)/2._r8**(3._r8/2._r8))+4._r8*3.1415927_r8)/3._r8 - aist = (1._r8 - 4._r8 * cos(phi) * cos(phi)) - else - aist = 1._r8 - endif - aist = max(0._r8,min(aist,1._r8)) - elseif (iceopt.eq.5) then -! set rh ice cloud fraction - rhi= (qv+qi)/qs * (esl/esi) - rhdif= (rhi-rhmini) / (rhmaxi - rhmini) - aist = min(1.0_r8, max(rhdif,0._r8)**2) - -! limiter to remove empty cloud and ice with no cloud -! and set icecld fraction to mincld if ice exists - - if (qi.lt.minice) then - aist=0._r8 - else - aist=max(mincld,aist) - endif - -! enforce limits on icimr - if (qi.ge.minice) then - icimr=qi/aist - -!minimum - if (icimr.lt.qist_min) then - aist = max(0._r8,min(1._r8,qi/qist_min)) - endif -!maximum - if (icimr.gt.qist_max) then - aist = max(0._r8,min(1._r8,qi/qist_max)) - endif - - endif - endif - - ! 0.999_r8 is added to prevent infinite 'ql_st' at the end of instratus_condensate - ! computed after updating 'qi_st'. - - aist = max(0._r8,min(aist,0.999_r8)) - - aist_out(i) = aist - - enddo - - return - end subroutine aist_vector - ! ----------------- ! ! End of subroutine ! ! ----------------- ! diff --git a/models/atm/cam/src/physics/cam/clubb_intr.F90 b/models/atm/cam/src/physics/cam/clubb_intr.F90 index 9d70d3037902..2f5365cbe3ed 100644 --- a/models/atm/cam/src/physics/cam/clubb_intr.F90 +++ b/models/atm/cam/src/physics/cam/clubb_intr.F90 @@ -19,10 +19,11 @@ module clubb_intr use shr_kind_mod, only: r8=>shr_kind_r8 use ppgrid, only: pver, pverp use phys_control, only: phys_getopts - use physconst, only: rair, cpair, gravit, latvap, latice, zvir, rh2o, karman, tms_orocnst, tms_z0fac + use physconst, only: rair, cpair, gravit, latvap, latice, zvir, rh2o, karman, & + tms_orocnst, tms_z0fac use cam_logfile, only: iulog use spmd_utils, only: masterproc - use constituents, only: pcnst + use constituents, only: pcnst, cnst_add use pbl_utils, only: calc_ustar, calc_obklen use mpishorthand @@ -41,39 +42,60 @@ module clubb_intr stats_init_clubb, & #endif stats_end_timestep_clubb, & - clubb_surface + clubb_surface, & + clubb_readnl, & + clubb_init_cnst, & + clubb_implements_cnst -#ifdef CLUBB_SGS +#ifdef CLUBB_SGS ! Both of these utilize CLUBB specific variables in their interface private :: stats_zero, stats_avg #endif + logical, public :: do_cldcool ! ------------ ! ! Private data ! ! ------------ ! integer, parameter :: & - grid_type = 3, & ! The 2 option specifies stretched thermodynamic levels - hydromet_dim = 0 ! The hydromet array in SAM-CLUBB is currently 0 elements + grid_type = 3, & ! The 2 option specifies stretched thermodynamic levels + hydromet_dim = 0 ! The hydromet array in SAM-CLUBB is currently 0 elements real(r8), dimension(0) :: & sclr_tol = 1.e-8_r8 ! Total water in kg/kg character(len=6), parameter :: & - saturation_equation = "flatau" ! Flatau polynomial approximation for SVP + saturation_equation = "flatau" ! Flatau polynomial approximation for SVP real(r8), parameter :: & - theta0 = 300._r8, & ! Reference temperature [K] - ts_nudge = 86400._r8, & ! Time scale for u/v nudging (not used) [s] + theta0 = 300._r8, & ! Reference temperature [K] + ts_nudge = 86400._r8, & ! Time scale for u/v nudging (not used) [s] p0_clubb = 100000._r8 real(r8), parameter :: & - host_dx = 100000._r8, & ! Host model deltax [m] - host_dy = 100000._r8 ! Host model deltay [m] + host_dx = 100000._r8, & ! Host model deltax [m] + host_dy = 100000._r8 ! Host model deltay [m] integer, parameter :: & - sclr_dim = 0 ! Higher-order scalars, set to zero + sclr_dim = 0 ! Higher-order scalars, set to zero + + real(r8), parameter :: & + wp3_const = 1._r8 ! Constant to add to wp3 when moments are advected + + real(r8), parameter :: & + wpthlp_const = 10.0_r8 ! Constant to add to wpthlp when moments are advected + + real(r8), parameter :: & + wprtp_const = 0.01_r8 ! Constant to add to wprtp when moments are advected + + real(r8), parameter :: & + rtpthlp_const = 0.01_r8 ! Constant to add to rtpthlp when moments are advected + + real(r8), parameter :: unset_r8 = huge(1.0_r8) + + real(r8) :: clubb_timestep = unset_r8 ! Default CLUBB timestep, unless overwriten by namelist + real(r8) :: clubb_rnevap_effic = unset_r8 ! Constant parameters logical, parameter, private :: & @@ -83,52 +105,83 @@ module clubb_intr logical :: do_tms logical :: lq(pcnst) + logical :: lq2(pcnst) logical :: prog_modal_aero - + logical :: do_rainturb + logical :: do_expldiff + logical :: clubb_do_adv + logical :: clubb_do_deep + logical :: micro_do_icesupersat + logical :: history_budget + + integer :: history_budget_histfile_num integer :: edsclr_dim ! Number of scalars to transport in CLUBB + integer :: offset ! define physics buffer indicies here integer :: & - wp2_idx, & ! vertical velocity variances - wp3_idx, & ! third moment of vertical velocity - wpthlp_idx, & ! turbulent flux of thetal - wprtp_idx, & ! turbulent flux of total water - rtpthlp_idx, & ! covariance of thetal and rt - rtp2_idx, & ! variance of total water - thlp2_idx, & ! variance of thetal - up2_idx, & ! variance of east-west wind - vp2_idx, & ! variance of north-south wind - upwp_idx, & ! east-west momentum flux - vpwp_idx, & ! north-south momentum flux - thlm_idx, & ! mean thetal - rtm_idx, & ! mean total water mixing ratio - um_idx, & ! mean of east-west wind - vm_idx, & ! mean of north-south wind - cld_idx, & ! Cloud fraction - concld_idx, & ! Convective cloud fraction - ast_idx, & ! Stratiform cloud fraction - alst_idx, & ! Liquid stratiform cloud fraction - aist_idx, & ! Ice stratiform cloud fraction - qlst_idx, & ! Physical in-cloud LWC - qist_idx, & ! Physical in-cloud IWC - dp_frac_idx, & ! deep convection cloud fraction - sh_frac_idx, & ! shallow convection cloud fraction - rel_idx, & ! Rel - kvh_idx, & ! CLUBB eddy diffusivity on thermo levels - kvm_idx, & ! CLUBB eddy diffusivity on mom levels - pblh_idx, & ! PBL pbuf - icwmrdp_idx, & ! In cloud mixing ratio for deep convection - tke_idx, & ! turbulent kinetic energy - tpert_idx, & ! temperature perturbation from PBL - fice_idx, & ! fice_idx index in physics buffer - cmeliq_idx, & ! cmeliq_idx index in physics buffer - relvar_idx, & ! relative cloud water variance - accre_enhan_idx ! optional accretion enhancement factor for MG + wp2_idx, & ! vertical velocity variances + wp3_idx, & ! third moment of vertical velocity + wpthlp_idx, & ! turbulent flux of thetal + wprtp_idx, & ! turbulent flux of total water + rtpthlp_idx, & ! covariance of thetal and rt + rtp2_idx, & ! variance of total water + thlp2_idx, & ! variance of thetal + up2_idx, & ! variance of east-west wind + vp2_idx, & ! variance of north-south wind + upwp_idx, & ! east-west momentum flux + vpwp_idx, & ! north-south momentum flux + thlm_idx, & ! mean thetal + rtm_idx, & ! mean total water mixing ratio + um_idx, & ! mean of east-west wind + vm_idx, & ! mean of north-south wind + cld_idx, & ! Cloud fraction + concld_idx, & ! Convective cloud fraction + ast_idx, & ! Stratiform cloud fraction + alst_idx, & ! Liquid stratiform cloud fraction + aist_idx, & ! Ice stratiform cloud fraction + qlst_idx, & ! Physical in-cloud LWC + qist_idx, & ! Physical in-cloud IWC + dp_frac_idx, & ! deep convection cloud fraction + sh_frac_idx, & ! shallow convection cloud fraction + rel_idx, & ! Rel + kvh_idx, & ! CLUBB eddy diffusivity on thermo levels + kvm_idx, & ! CLUBB eddy diffusivity on mom levels + pblh_idx, & ! PBL pbuf + icwmrdp_idx, & ! In cloud mixing ratio for deep convection + tke_idx, & ! turbulent kinetic energy + tpert_idx, & ! temperature perturbation from PBL + fice_idx, & ! fice_idx index in physics buffer + cmeliq_idx, & ! cmeliq_idx index in physics buffer + relvar_idx, & ! relative cloud water variance + accre_enhan_idx, & ! optional accretion enhancement factor for MG + naai_idx, & ! ice number concentration + prer_evap_idx, & ! rain evaporation rate + qrl_idx, & ! longwave cooling rate + radf_idx + + integer, public :: & + ixthlp2 = 0, & + ixwpthlp = 0, & + ixwprtp = 0, & + ixwp2 = 0, & + ixwp3 = 0, & + ixrtpthlp = 0, & + ixrtp2 = 0, & + ixup2 = 0, & + ixvp2 = 0 + + integer :: cmfmc_sh_idx = 0 ! Output arrays for CLUBB statistics real(r8), allocatable, dimension(:,:,:) :: out_zt, out_zm, out_radzt, out_radzm, out_sfc character(len=16) :: eddy_scheme ! Default set in phys_control.F90 + character(len=16) :: deep_scheme ! Default set in phys_control.F90 + + integer, parameter :: ncnst=9 + character(len=8) :: cnst_names(ncnst) + logical :: do_cnst=.false. contains @@ -153,8 +206,29 @@ subroutine clubb_register_cam( ) use physics_buffer, only: pbuf_add_field, dtype_r8, dyn_time_lvls use ppgrid, only: pver, pverp, pcols - call phys_getopts( eddy_scheme_out = eddy_scheme, & - do_tms_out = do_tms) + call phys_getopts( eddy_scheme_out = eddy_scheme, & + deep_scheme_out = deep_scheme, & + do_tms_out = do_tms, & + history_budget_out = history_budget, & + history_budget_histfile_num_out = history_budget_histfile_num, & + micro_do_icesupersat_out = micro_do_icesupersat) + + if (clubb_do_adv) then + cnst_names =(/'THLP2 ','RTP2 ','RTPTHLP','WPTHLP ','WPRTP ','WP2 ','WP3 ','UP2 ','VP2 '/) + do_cnst=.true. + ! If CLUBB moments are advected, do not output them automatically which is typically done. Some moments + ! need a constant added to them before they are advected, thus this would corrupt the output. + ! Users should refer to the "XXXX_CLUBB" (THLP2_CLUBB for instance) output variables for these moments + call cnst_add(trim(cnst_names(1)),0._r8,0._r8,0._r8,ixthlp2,longname='second moment vertical velocity',cam_outfld=.false.) + call cnst_add(trim(cnst_names(2)),0._r8,0._r8,0._r8,ixrtp2,longname='second moment rtp',cam_outfld=.false.) + call cnst_add(trim(cnst_names(3)),0._r8,0._r8,-999999._r8,ixrtpthlp,longname='covariance rtp thlp',cam_outfld=.false.) + call cnst_add(trim(cnst_names(4)),0._r8,0._r8,-999999._r8,ixwpthlp,longname='CLUBB heat flux',cam_outfld=.false.) + call cnst_add(trim(cnst_names(5)),0._r8,0._r8,-999999._r8,ixwprtp,longname='CLUBB moisture flux',cam_outfld=.false.) + call cnst_add(trim(cnst_names(6)),0._r8,0._r8,0._r8,ixwp2,longname='CLUBB wp2',cam_outfld=.false.) + call cnst_add(trim(cnst_names(7)),0._r8,0._r8,-999999._r8,ixwp3,longname='CLUBB 3rd moment vert velocity',cam_outfld=.false.) + call cnst_add(trim(cnst_names(8)),0._r8,0._r8,0._r8,ixup2,longname='CLUBB 2nd moment u wind',cam_outfld=.false.) + call cnst_add(trim(cnst_names(9)),0._r8,0._r8,0._r8,ixvp2,longname='CLUBB 2nd moment v wind',cam_outfld=.false.) + end if ! put pbuf_add calls here (see macrop_driver.F90 for sample) use indicies defined at top call pbuf_add_field('pblh', 'global', dtype_r8, (/pcols/), pblh_idx) @@ -169,18 +243,20 @@ subroutine clubb_register_cam( ) call pbuf_add_field('QLST', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), qlst_idx) call pbuf_add_field('CONCLD', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), concld_idx) call pbuf_add_field('CLD', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cld_idx) - call pbuf_add_field('FICE', 'physpkg',dtype_r8, (/pcols,pver/), fice_idx) + call pbuf_add_field('FICE', 'physpkg',dtype_r8, (/pcols,pver/), fice_idx) + call pbuf_add_field('RAD_CLUBB', 'global', dtype_r8, (/pcols,pver/), radf_idx) call pbuf_add_field('CMELIQ', 'physpkg',dtype_r8, (/pcols,pver/), cmeliq_idx) - call pbuf_add_field('WP2', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), wp2_idx) - call pbuf_add_field('WP3', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), wp3_idx) - call pbuf_add_field('WPTHLP', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), wpthlp_idx) - call pbuf_add_field('WPRTP', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), wprtp_idx) - call pbuf_add_field('RTPTHLP', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), rtpthlp_idx) - call pbuf_add_field('RTP2', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), rtp2_idx) - call pbuf_add_field('THLP2', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), thlp2_idx) - call pbuf_add_field('UP2', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), up2_idx) - call pbuf_add_field('VP2', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), vp2_idx) + call pbuf_add_field('WP2_nadv', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), wp2_idx) + call pbuf_add_field('WP3_nadv', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), wp3_idx) + call pbuf_add_field('WPTHLP_nadv', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), wpthlp_idx) + call pbuf_add_field('WPRTP_nadv', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), wprtp_idx) + call pbuf_add_field('RTPTHLP_nadv', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), rtpthlp_idx) + call pbuf_add_field('RTP2_nadv', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), rtp2_idx) + call pbuf_add_field('THLP2_nadv', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), thlp2_idx) + call pbuf_add_field('UP2_nadv', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), up2_idx) + call pbuf_add_field('VP2_nadv', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), vp2_idx) + call pbuf_add_field('UPWP', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), upwp_idx) call pbuf_add_field('VPWP', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), vpwp_idx) call pbuf_add_field('THLM', 'global', dtype_r8, (/pcols,pverp,dyn_time_lvls/), thlm_idx) @@ -191,7 +267,163 @@ subroutine clubb_register_cam( ) #endif end subroutine clubb_register_cam + ! =============================================================================== ! + ! ! + ! =============================================================================== ! + +function clubb_implements_cnst(name) + + !----------------------------------------------------------------------------- ! + ! ! + ! Return true if specified constituent is implemented by this package ! + ! ! + !----------------------------------------------------------------------------- ! + + character(len=*), intent(in) :: name ! constituent name + logical :: clubb_implements_cnst ! return value + + !----------------------------------------------------------------------- + + clubb_implements_cnst = (do_cnst .and. any(name == cnst_names)) + +end function clubb_implements_cnst + + + ! =============================================================================== ! + ! ! + ! =============================================================================== ! + +subroutine clubb_init_cnst(name, q, gcid) + +#ifdef CLUBB_SGS + use constants_clubb, only: w_tol_sqd, rt_tol, thl_tol +#endif + + !----------------------------------------------------------------------- ! + ! ! + ! Initialize the state if clubb_do_adv ! + ! ! + !----------------------------------------------------------------------- ! + + character(len=*), intent(in) :: name ! constituent name + real(r8), intent(out) :: q(:,:) ! mass mixing ratio (gcol, plev) + integer, intent(in) :: gcid(:) ! global column id + !----------------------------------------------------------------------- + +#ifdef CLUBB_SGS + if (clubb_do_adv) then + if (trim(name) == trim(cnst_names(1))) q = thl_tol**2 + if (trim(name) == trim(cnst_names(2))) q = rt_tol**2 + if (trim(name) == trim(cnst_names(3))) q = 0.0_r8 + if (trim(name) == trim(cnst_names(4))) q = 0.0_r8 + if (trim(name) == trim(cnst_names(5))) q = 0.0_r8 + if (trim(name) == trim(cnst_names(6))) q = w_tol_sqd + if (trim(name) == trim(cnst_names(7))) q = 0.0_r8 + if (trim(name) == trim(cnst_names(8))) q = w_tol_sqd + if (trim(name) == trim(cnst_names(9))) q = w_tol_sqd + end if +#endif + +end subroutine clubb_init_cnst + + ! =============================================================================== ! + ! ! + ! =============================================================================== ! + + subroutine clubb_readnl(nlfile) + +#ifdef CLUBB_SGS + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use cam_abortutils, only: endrun + use stats_variables, only: l_stats, l_output_rad_files + use mpishorthand + use model_flags, only: l_diffuse_rtm_and_thlm, l_stability_correct_Kh_N2_zm +#endif + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + +#ifdef CLUBB_SGS + logical :: clubb_history, clubb_rad_history, clubb_cloudtop_cooling, clubb_rainevap_turb, & + clubb_stabcorrect, clubb_expldiff ! Stats enabled (T/F) + + integer :: iunit, read_status + + namelist /clubb_his_nl/ clubb_history, clubb_rad_history + namelist /clubbpbl_diff_nl/ clubb_cloudtop_cooling, clubb_rainevap_turb, clubb_expldiff, & + clubb_do_adv, clubb_do_deep, clubb_timestep, clubb_stabcorrect, & + clubb_rnevap_effic + + !----- Begin Code ----- + + ! Determine if we want clubb_history to be output + clubb_history = .false. ! Initialize to false + l_stats = .false. ! Initialize to false + l_output_rad_files = .false. ! Initialize to false + do_cldcool = .false. ! Initialize to false + do_rainturb = .false. ! Initialize to false + do_expldiff = .false. ! Initialize to false + + + ! Read namelist to determine if CLUBB history should be called + if (masterproc) then + iunit = getunit() + open( iunit, file=trim(nlfile), status='old' ) + + call find_group_name(iunit, 'clubb_his_nl', status=read_status) + if (read_status == 0) then + read(unit=iunit, nml=clubb_his_nl, iostat=read_status) + if (read_status /= 0) then + call endrun('clubb_readnl: error reading namelist') + end if + end if + + call find_group_name(iunit, 'clubbpbl_diff_nl', status=read_status) + if (read_status == 0) then + read(unit=iunit, nml=clubbpbl_diff_nl, iostat=read_status) + if (read_status /= 0) then + call endrun('clubb_readnl: error reading namelist') + end if + end if + + close(unit=iunit) + call freeunit(iunit) + end if + +#ifdef SPMD +! Broadcast namelist variables + call mpibcast(clubb_history, 1, mpilog, 0, mpicom) + call mpibcast(clubb_rad_history, 1, mpilog, 0, mpicom) + call mpibcast(clubb_cloudtop_cooling, 1, mpilog, 0, mpicom) + call mpibcast(clubb_rainevap_turb, 1, mpilog, 0, mpicom) + call mpibcast(clubb_expldiff, 1, mpilog, 0, mpicom) + call mpibcast(clubb_do_adv, 1, mpilog, 0, mpicom) + call mpibcast(clubb_do_deep, 1, mpilog, 0, mpicom) + call mpibcast(clubb_timestep, 1, mpir8, 0, mpicom) + call mpibcast(clubb_stabcorrect, 1, mpilog, 0, mpicom) + call mpibcast(clubb_rnevap_effic, 1, mpir8, 0, mpicom) +#endif + + ! Overwrite defaults if they are true + if (clubb_history) l_stats = .true. + if (clubb_rad_history) l_output_rad_files = .true. + if (clubb_cloudtop_cooling) do_cldcool = .true. + if (clubb_rainevap_turb) do_rainturb = .true. + if (clubb_expldiff) do_expldiff = .true. + + if (clubb_stabcorrect .and. clubb_expldiff) then + call endrun('clubb_readnl: clubb_stabcorrect and clubb_expldiff may not both be set to true at the same time') + end if + + if (clubb_stabcorrect) then + l_diffuse_rtm_and_thlm = .true. ! CLUBB flag set to true + l_stability_correct_Kh_N2_zm = .true. ! CLUBB flag set to true + endif + +#endif + end subroutine clubb_readnl + ! =============================================================================== ! ! ! ! =============================================================================== ! @@ -212,33 +444,31 @@ subroutine clubb_ini_cam(pbuf2d) #ifdef CLUBB_SGS ! From CAM libraries - use physics_types, only: physics_state, physics_ptend - use cam_history, only: addfld, add_default, phys_decomp - use ppgrid, only: pver, pverp, pcols + use physics_types, only: physics_state, physics_ptend + use cam_history, only: addfld, add_default, phys_decomp + use ppgrid, only: pver, pverp, pcols use ref_pres, only: pref_mid use hb_diff, only: init_hb_diff use trb_mtn_stress, only: init_tms use rad_constituents, only: rad_cnst_get_info, rad_cnst_get_mode_num_idx, rad_cnst_get_mam_mmr_idx ! From the CLUBB libraries - use clubb_core, only: setup_clubb_core - use clubb_precision, only: time_precision - use error_code, only: set_clubb_debug_level ! Subroutines - use parameter_indices, only: nparams ! Constant - use parameters_tunable, only: read_parameters ! Subroutine - use stats_variables, only: l_stats, l_stats_samp, l_grads, l_output_rad_files, & - zt, zm, sfc, rad_zt, rad_zm - use namelist_utils, only: find_group_name - use units, only: getunit, freeunit - use cam_abortutils, only: endrun - use error_messages, only: handle_errmsg - use time_manager, only: is_first_step - use constants_clubb, only: em_min, w_tol_sqd, rt_tol, thl_tol + use advance_clubb_core_module, only: setup_clubb_core + use clubb_precision, only: time_precision + use error_code, only: set_clubb_debug_level ! Subroutines + use parameter_indices, only: nparams ! Constant + use parameters_tunable, only: read_parameters ! Subroutine + use stats_variables, only: l_stats, l_stats_samp, l_grads, l_output_rad_files, & + stats_zt, stats_zm, stats_sfc, stats_rad_zt, stats_rad_zm + use units, only: getunit, freeunit + use error_messages, only: handle_errmsg + use time_manager, only: is_first_step + use constants_clubb, only: w_tol_sqd, rt_tol, thl_tol ! These are only needed if we're using a passive scalar - use array_index, only: iisclr_rt, iisclr_thl, iisclr_CO2, & ! [kg/kg]/[K]/[1e6 mol/mol] - iiedsclr_rt, iiedsclr_thl, iiedsclr_CO2 ! " " + use array_index, only: iisclr_rt, iisclr_thl, iisclr_CO2, & ! [kg/kg]/[K]/[1e6 mol/mol] + iiedsclr_rt, iiedsclr_thl, iiedsclr_CO2 ! " " use constituents, only: cnst_get_ind use phys_control, only: phys_getopts @@ -255,25 +485,25 @@ subroutine clubb_ini_cam(pbuf2d) real(8), dimension(nparams) :: clubb_params ! These adjustable CLUBB parameters (C1, C2 ...) - logical :: clubb_history, clubb_rad_history ! Stats enabled (T/F) + logical :: clubb_history, clubb_rad_history, clubb_cloudtop_cooling, clubb_rainevap_turb, clubb_expldiff ! Stats enabled (T/F) + + ! The similar name to clubb_history is unfortunate... + logical :: history_amwg, history_clubb character(len=128) :: errstring ! error status for CLUBB init - integer :: err_code, iunit ! Code for when CLUBB fails + integer :: err_code, iunit ! Code for when CLUBB fails integer :: i, j, k, l ! Indices - integer :: read_status ! Length of a string - integer :: ntop_eddy ! Top interface level to which eddy vertical diffusion is applied ( = 1 ) - integer :: nbot_eddy ! Bottom interface level to which eddy vertical diffusion is applied ( = pver ) + integer :: read_status ! Length of a string + integer :: ntop_eddy ! Top interface level to which eddy vertical diffusion is applied ( = 1 ) + integer :: nbot_eddy ! Bottom interface level to which eddy vertical diffusion is applied ( = pver ) integer :: nmodes, nspec, pmam_ncnst, m integer :: ixnumliq integer :: lptr - real(r8) :: zt_g(pverp) ! Height dummy array real(r8) :: zi_g(pverp) ! Height dummy array - - namelist /clubb_his_nl/ clubb_history, clubb_rad_history !----- Begin Code ----- @@ -284,39 +514,40 @@ subroutine clubb_ini_cam(pbuf2d) ! off of pcnst (the total consituents) ! ----------------------------------------------------------------- ! - call phys_getopts(prog_modal_aero_out=prog_modal_aero) + call phys_getopts(prog_modal_aero_out=prog_modal_aero, & + history_amwg_out=history_amwg, & + history_clubb_out=history_clubb) - ! Select variables to apply tendencies back to CAM + ! Select variables to apply tendencies back to CAM - ! Initialize all consituents to true to start - lq(1:pcnst) = .true. - edsclr_dim = pcnst - - if (prog_modal_aero) then - ! Turn off modal aerosols and decrement edsclr_dim accordingly - call rad_cnst_get_info(0, nmodes=nmodes) - - do m = 1, nmodes - call rad_cnst_get_mode_num_idx(m, lptr) - lq(lptr)=.false. - edsclr_dim = edsclr_dim-1 - - call rad_cnst_get_info(0, m, nspec=nspec) - do l = 1, nspec - call rad_cnst_get_mam_mmr_idx(m, l, lptr) - lq(lptr)=.false. - edsclr_dim = edsclr_dim-1 - end do - end do - - - ! In addition, if running with MAM, droplet number is transported - ! in dropmixnuc, therefore we do NOT want CLUBB to apply transport - ! tendencies to avoid double counted. Else, we apply tendencies. - call cnst_get_ind('NUMLIQ',ixnumliq) - lq(ixnumliq) = .false. - edsclr_dim = edsclr_dim-1 - endif + ! Initialize all consituents to true to start + lq(1:pcnst) = .true. + edsclr_dim = pcnst + + if (prog_modal_aero) then + ! Turn off modal aerosols and decrement edsclr_dim accordingly + call rad_cnst_get_info(0, nmodes=nmodes) + + do m = 1, nmodes + call rad_cnst_get_mode_num_idx(m, lptr) + lq(lptr)=.false. + edsclr_dim = edsclr_dim-1 + + call rad_cnst_get_info(0, m, nspec=nspec) + do l = 1, nspec + call rad_cnst_get_mam_mmr_idx(m, l, lptr) + lq(lptr)=.false. + edsclr_dim = edsclr_dim-1 + end do + end do + + ! In addition, if running with MAM, droplet number is transported + ! in dropmixnuc, therefore we do NOT want CLUBB to apply transport + ! tendencies to avoid double counted. Else, we apply tendencies. + call cnst_get_ind('NUMLIQ',ixnumliq) + lq(ixnumliq) = .false. + edsclr_dim = edsclr_dim-1 + endif ! ----------------------------------------------------------------- ! ! Set the debug level. Level 2 has additional computational expense since @@ -329,35 +560,6 @@ subroutine clubb_ini_cam(pbuf2d) ! physics packages (e.g. tke) ! ----------------------------------------------------------------- ! - ! Determine if we want clubb_history to be output - clubb_history = .false. ! Initialize to false - l_stats = .false. ! Initialize to false - l_output_rad_files = .false. ! Initialize to false - - ! Read namelist to determine if CLUBB history should be called - if (masterproc) then - iunit= getunit() - open(unit=iunit,file="atm_in",status='old') - call find_group_name(iunit, 'clubb_his_nl', status=read_status) - if (read_status == 0) then - read(unit=iunit, nml=clubb_his_nl, iostat=read_status) - if (read_status /= 0) then - call endrun('clubb_tend_cam: error reading namelist') - end if - end if - close(unit=iunit) - call freeunit(iunit) - end if - -#ifdef SPMD - ! Broadcast namelist variables - call mpibcast(clubb_history, 1, mpilog, 0, mpicom) - call mpibcast(clubb_rad_history, 1, mpilog, 0, mpicom) -#endif - - ! Overwrite defaults if they are true - if (clubb_history) l_stats = .true. - if (clubb_rad_history) l_output_rad_files = .true. ! Defaults l_stats_samp = .false. @@ -379,6 +581,9 @@ subroutine clubb_ini_cam(pbuf2d) sh_frac_idx = pbuf_get_index('SH_FRAC') ! Shallow convection cloud fraction relvar_idx = pbuf_get_index('RELVAR') ! Relative cloud water variance accre_enhan_idx = pbuf_get_index('ACCRE_ENHAN') ! accretion enhancement for MG + prer_evap_idx = pbuf_get_index('PRER_EVAP') + qrl_idx = pbuf_get_index('QRL') + cmfmc_sh_idx = pbuf_get_index('CMFMC_SH') iisclr_rt = -1 iisclr_thl = -1 @@ -388,20 +593,29 @@ subroutine clubb_ini_cam(pbuf2d) iiedsclr_thl = -1 iiedsclr_CO2 = -1 + ! ----------------------------------------------------------------- ! + ! Define number of tracers for CLUBB to diffuse + ! ----------------------------------------------------------------- ! + + if (do_expldiff) then + offset = 2 ! diffuse temperature and moisture explicitly + edsclr_dim = edsclr_dim + offset + endif + ! ----------------------------------------------------------------- ! ! Setup CLUBB core ! ----------------------------------------------------------------- ! ! Read in parameters for CLUBB. Just read in default values !$OMP PARALLEL - call read_parameters( -99, "", clubb_params ) + call read_parameters( -99, "", clubb_params ) !$OMP END PARALLEL ! Fill in dummy arrays for height. Note that these are overwrote ! at every CLUBB step to physical values. do k=1,pverp - zt_g(k) = ((k-1)*1000._r8)-500._r8 ! this is dummy garbage - zi_g(k) = (k-1)*1000._r8 ! this is dummy garbage + zt_g(k) = ((k-1)*1000._r8)-500._r8 ! this is dummy garbage + zi_g(k) = (k-1)*1000._r8 ! this is dummy garbage enddo ! Set up CLUBB core. Note that some of these inputs are overwrote @@ -416,11 +630,10 @@ subroutine clubb_ini_cam(pbuf2d) l_host_applies_sfc_fluxes, & ! In l_uv_nudge, saturation_equation, & ! In l_implemented, grid_type, zi_g(2), zi_g(1), zi_g(pverp), & ! In - zi_g(1:pverp), zt_g(1:pverp), & ! In - host_dx, host_dy, zi_g(1), & ! In + zi_g(1:pverp), zt_g(1:pverp), zi_g(1), & ! In err_code ) !$OMP END PARALLEL - + ! ----------------------------------------------------------------- ! ! Set-up HB diffusion. Only initialized to diagnose PBL depth ! ! ----------------------------------------------------------------- ! @@ -437,144 +650,187 @@ subroutine clubb_ini_cam(pbuf2d) ! ------------------------------------------------------------------! if ( do_tms) then - call init_tms( r8, tms_orocnst, tms_z0fac, karman, gravit, rair, errstring) - call handle_errmsg(errstring, subname="init_tms") - - call addfld( 'TAUTMSX' ,'N/m2 ', 1, 'A', 'Zonal turbulent mountain surface stress', phys_decomp ) - call addfld( 'TAUTMSY' ,'N/m2 ', 1, 'A', 'Meridional turbulent mountain surface stress', phys_decomp ) - call add_default( 'TAUTMSX ', 1, ' ' ) - call add_default( 'TAUTMSY ', 1, ' ' ) - if (masterproc) then - write(iulog,*)'Using turbulent mountain stress module' - write(iulog,*)' tms_orocnst = ',tms_orocnst - write(iulog,*)' tms_z0fac = ',tms_z0fac - end if + call init_tms( r8, tms_orocnst, tms_z0fac, karman, gravit, rair, errstring) + call handle_errmsg(errstring, subname="init_tms") + + call addfld( 'TAUTMSX' ,'N/m2 ', 1, 'A', 'Zonal turbulent mountain surface stress', phys_decomp ) + call addfld( 'TAUTMSY' ,'N/m2 ', 1, 'A', 'Meridional turbulent mountain surface stress', phys_decomp ) + if (history_amwg) then + call add_default( 'TAUTMSX ', 1, ' ' ) + call add_default( 'TAUTMSY ', 1, ' ' ) + end if + if (masterproc) then + write(iulog,*)'Using turbulent mountain stress module' + write(iulog,*)' tms_orocnst = ',tms_orocnst + write(iulog,*)' tms_z0fac = ',tms_z0fac + end if endif ! ----------------------------------------------------------------- ! ! Add output fields for the history files ! ----------------------------------------------------------------- ! - ! These are default CLUBB output. Not the higher order history budgets - call addfld ('RHO_CLUBB', 'kg/m3', pverp, 'A', 'Air Density', phys_decomp) - call addfld ('UP2_CLUBB', 'm2/s2', pverp, 'A', 'Zonal Velocity Variance', phys_decomp) - call addfld ('VP2_CLUBB', 'm2/s2', pverp, 'A', 'Meridional Velocity Variance', phys_decomp) - call addfld ('WP2_CLUBB', 'm2/s2', pverp, 'A', 'Vertical Velocity Variance', phys_decomp) - call addfld ('UPWP_CLUBB', 'm2/s2', pverp, 'A', 'Zonal Momentum Flux', phys_decomp) - call addfld ('VPWP_CLUBB', 'm2/s2', pverp, 'A', 'Meridional Momentum Flux', phys_decomp) - call addfld ('WP3_CLUBB', 'm3/s3', pverp, 'A', 'Third Moment Vertical Velocity', phys_decomp) - call addfld ('WPTHLP_CLUBB', 'W/m2', pverp, 'A', 'Heat Flux', phys_decomp) - call addfld ('WPRTP_CLUBB', 'W/m2', pverp, 'A', 'Moisture Flux', phys_decomp) - call addfld ('RTP2_CLUBB', 'g^2/kg^2', pverp, 'A', 'Moisture Variance', phys_decomp) - call addfld ('THLP2_CLUBB', 'K^2', pverp, 'A', 'Temperature Variance', phys_decomp) - call addfld ('RTPTHLP_CLUBB', 'K g/kg', pverp, 'A', 'Temp. Moist. Covariance', phys_decomp) - call addfld ('RCM_CLUBB', 'g/kg', pverp, 'A', 'Cloud Water Mixing Ratio', phys_decomp) - call addfld ('WPRCP_CLUBB', 'W/m2', pverp, 'A', 'Liquid Water Flux', phys_decomp) - call addfld ('CLOUDFRAC_CLUBB', 'fraction', pver, 'A', 'Cloud Fraction', phys_decomp) - call addfld ('RCMINLAYER_CLUBB', 'g/kg', pverp, 'A', 'Cloud Water in Layer', phys_decomp) - call addfld ('CLOUDCOVER_CLUBB', 'fraction', pverp, 'A', 'Cloud Cover', phys_decomp) - call addfld ('WPTHVP_CLUBB', 'W/m2', pver, 'A', 'Buoyancy Flux',phys_decomp) - call addfld ('RVMTEND_CLUBB', 'g/kg /s', pver, 'A', 'Water vapor tendency',phys_decomp) - call addfld ('STEND_CLUBB', 'k/s', pver, 'A', 'Temperature tendency',phys_decomp) - call addfld ('RCMTEND_CLUBB', 'g/kg /s', pver, 'A', 'Cloud Liquid Water Tendency',phys_decomp) - call addfld ('RIMTEND_CLUBB', 'g/kg /s', pver, 'A', 'Cloud Ice Tendency',phys_decomp) - call addfld ('UTEND_CLUBB', 'm/s /s', pver, 'A', 'U-wind Tendency',phys_decomp) - call addfld ('VTEND_CLUBB', 'm/s /s', pver, 'A', 'V-wind Tendency',phys_decomp) - call addfld ('ZT_CLUBB', 'm', pverp, 'A', 'Thermodynamic Heights',phys_decomp) - call addfld ('ZM_CLUBB', 'm', pverp, 'A', 'Momentum Heights',phys_decomp) - call addfld ('UM_CLUBB', 'm/s', pverp, 'A', 'Zonal Wind',phys_decomp) - call addfld ('VM_CLUBB', 'm/s', pverp, 'A', 'Meridional Wind',phys_decomp) - call addfld ('THETAL', 'K', pver, 'A', 'Liquid Water Potential Temperature',phys_decomp) - call addfld ('PBLH', 'm', 1, 'A', 'PBL height',phys_decomp) - call addfld ('QT', 'kg/kg', pver, 'A', 'Total water mixing ratio',phys_decomp) - call addfld ('SL', 'J/kg', pver, 'A', 'Liquid water static energy',phys_decomp) - call addfld ('CLDST', 'fraction', pver, 'A', 'Stratus cloud fraction',phys_decomp) - call addfld ('ZMDLF', 'kg/kg/s', pver, 'A', 'Detrained liquid water from ZM convection',phys_decomp) - - call addfld ('CONCLD ', 'fraction', pver, 'A', 'Convective cloud cover',phys_decomp) - call addfld ('CMELIQ ', 'kg/kg/s ', pver, 'A', 'Rate of cond-evap of liq within the cloud',phys_decomp) - - ! Initialize statistics, below are dummy variables - dum1 = 300._r8 - dum2 = 1200._r8 - dum3 = 300._r8 - - if (l_stats) then + if (clubb_do_deep) then + call addfld ('MU_CLUBB','1/m',1,'A','CLUBB value of entrainment',phys_decomp) + endif + + ! These are default CLUBB output. Not the higher order history budgets + call addfld ('RHO_CLUBB', 'kg/m3', pverp, 'A', 'Air Density', phys_decomp) + call addfld ('UP2_CLUBB', 'm2/s2', pverp, 'A', 'Zonal Velocity Variance', phys_decomp) + call addfld ('VP2_CLUBB', 'm2/s2', pverp, 'A', 'Meridional Velocity Variance', phys_decomp) + call addfld ('WP2_CLUBB', 'm2/s2', pverp, 'A', 'Vertical Velocity Variance', phys_decomp) + call addfld ('UPWP_CLUBB', 'm2/s2', pverp, 'A', 'Zonal Momentum Flux', phys_decomp) + call addfld ('VPWP_CLUBB', 'm2/s2', pverp, 'A', 'Meridional Momentum Flux', phys_decomp) + call addfld ('WP3_CLUBB', 'm3/s3', pverp, 'A', 'Third Moment Vertical Velocity', phys_decomp) + call addfld ('WPTHLP_CLUBB', 'W/m2', pverp, 'A', 'Heat Flux', phys_decomp) + call addfld ('WPRTP_CLUBB', 'W/m2', pverp, 'A', 'Moisture Flux', phys_decomp) + call addfld ('RTP2_CLUBB', 'g^2/kg^2', pverp, 'A', 'Moisture Variance', phys_decomp) + call addfld ('THLP2_CLUBB', 'K^2', pverp, 'A', 'Temperature Variance', phys_decomp) + call addfld ('RTPTHLP_CLUBB', 'K g/kg', pverp, 'A', 'Temp. Moist. Covariance', phys_decomp) + call addfld ('RCM_CLUBB', 'g/kg', pverp, 'A', 'Cloud Water Mixing Ratio', phys_decomp) + call addfld ('WPRCP_CLUBB', 'W/m2', pverp, 'A', 'Liquid Water Flux', phys_decomp) + call addfld ('CLOUDFRAC_CLUBB', 'fraction', pver, 'A', 'Cloud Fraction', phys_decomp) + call addfld ('RCMINLAYER_CLUBB', 'g/kg', pverp, 'A', 'Cloud Water in Layer', phys_decomp) + call addfld ('CLOUDCOVER_CLUBB', 'fraction', pverp, 'A', 'Cloud Cover', phys_decomp) + call addfld ('WPTHVP_CLUBB', 'W/m2', pver, 'A', 'Buoyancy Flux',phys_decomp) + call addfld ('RVMTEND_CLUBB', 'g/kg /s', pver, 'A', 'Water vapor tendency',phys_decomp) + call addfld ('STEND_CLUBB', 'k/s', pver, 'A', 'Temperature tendency',phys_decomp) + call addfld ('RCMTEND_CLUBB', 'g/kg /s', pver, 'A', 'Cloud Liquid Water Tendency',phys_decomp) + call addfld ('RIMTEND_CLUBB', 'g/kg /s', pver, 'A', 'Cloud Ice Tendency',phys_decomp) + call addfld ('UTEND_CLUBB', 'm/s /s', pver, 'A', 'U-wind Tendency',phys_decomp) + call addfld ('VTEND_CLUBB', 'm/s /s', pver, 'A', 'V-wind Tendency',phys_decomp) + call addfld ('ZT_CLUBB', 'm', pverp, 'A', 'Thermodynamic Heights',phys_decomp) + call addfld ('ZM_CLUBB', 'm', pverp, 'A', 'Momentum Heights',phys_decomp) + call addfld ('UM_CLUBB', 'm/s', pverp, 'A', 'Zonal Wind',phys_decomp) + call addfld ('VM_CLUBB', 'm/s', pverp, 'A', 'Meridional Wind',phys_decomp) + call addfld ('THETAL', 'K', pver, 'A', 'Liquid Water Potential Temperature',phys_decomp) + call addfld ('PBLH', 'm', 1, 'A', 'PBL height',phys_decomp) + call addfld ('QT', 'kg/kg', pver, 'A', 'Total water mixing ratio',phys_decomp) + call addfld ('SL', 'J/kg', pver, 'A', 'Liquid water static energy',phys_decomp) + call addfld ('CLDST', 'fraction', pver, 'A', 'Stratus cloud fraction',phys_decomp) + call addfld ('ZMDLF', 'kg/kg/s', pver, 'A', 'Detrained liquid water from ZM convection',phys_decomp) + call addfld ('TTENDICE', 'K/s ', pver, 'A', 'T tendency from Ice Saturation Adjustment',phys_decomp) + call addfld ('QVTENDICE', 'kg/kg/s ', pver, 'A', 'Q tendency from Ice Saturation Adjustment',phys_decomp) + call addfld ('QITENDICE', 'kg/kg/s ', pver, 'A', 'CLDICE tendency from Ice Saturation Adjustment',phys_decomp) + call addfld ('NITENDICE', 'kg/kg/s ', pver, 'A', 'NUMICE tendency from Ice Saturation Adjustment',phys_decomp) + call addfld ('DPDLFLIQ ', 'kg/kg/s ', pver, 'A', 'Detrained liquid water from deep convection',phys_decomp) + call addfld ('DPDLFICE ', 'kg/kg/s ', pver, 'A', 'Detrained ice from deep convection',phys_decomp) + call addfld ('DPDLFT ', 'K/s ', pver, 'A', 'T-tendency due to deep convective detrainment',phys_decomp) + call addfld ('RELVAR ', '- ', pver, 'A', 'Relative cloud water variance',phys_decomp) + + + call addfld ('CONCLD ', 'fraction', pver, 'A', 'Convective cloud cover',phys_decomp) + call addfld ('CMELIQ ', 'kg/kg/s ', pver, 'A', 'Rate of cond-evap of liq within the cloud',phys_decomp) + + ! Initialize statistics, below are dummy variables + dum1 = 300._r8 + dum2 = 1200._r8 + dum3 = 300._r8 + + if (l_stats) then - call stats_init_clubb( .true., dum1, dum2, & + call stats_init_clubb( .true., dum1, dum2, & pverp, pverp, pverp, dum3 ) - - allocate(out_zt(pcols,pverp,zt%nn)) - allocate(out_zm(pcols,pverp,zm%nn)) - allocate(out_sfc(pcols,1,sfc%nn)) - - allocate(out_radzt(pcols,pverp,rad_zt%nn)) - allocate(out_radzm(pcols,pverp,rad_zm%nn)) - - endif + + allocate(out_zt(pcols,pverp,stats_zt%num_output_fields)) + allocate(out_zm(pcols,pverp,stats_zm%num_output_fields)) + allocate(out_sfc(pcols,1,stats_sfc%num_output_fields)) + + allocate(out_radzt(pcols,pverp,stats_rad_zt%num_output_fields)) + allocate(out_radzm(pcols,pverp,stats_rad_zm%num_output_fields)) + + endif ! ----------------------------------------------------------------- ! ! Make all of this output default, this is not CLUBB history ! ----------------------------------------------------------------- ! - - call add_default('RHO_CLUBB', 1, ' ') - call add_default('UP2_CLUBB', 1, ' ') - call add_default('VP2_CLUBB', 1, ' ') - call add_default('WP2_CLUBB', 1, ' ') - call add_default('WP3_CLUBB', 1, ' ') - call add_default('UPWP_CLUBB', 1, ' ') - call add_default('VPWP_CLUBB', 1, ' ') - call add_default('WPTHLP_CLUBB', 1, ' ') - call add_default('WPRTP_CLUBB', 1, ' ') - call add_default('RTP2_CLUBB', 1, ' ') - call add_default('THLP2_CLUBB', 1, ' ') - call add_default('RTPTHLP_CLUBB', 1, ' ') - call add_default('RCM_CLUBB', 1, ' ') - call add_default('WPRCP_CLUBB', 1, ' ') - call add_default('CLOUDFRAC_CLUBB', 1, ' ') - call add_default('RCMINLAYER_CLUBB', 1, ' ') - call add_default('CLOUDCOVER_CLUBB', 1, ' ') - call add_default('WPTHVP_CLUBB', 1, ' ') - call add_default('RVMTEND_CLUBB', 1, ' ') - call add_default('STEND_CLUBB', 1, ' ') - call add_default('RCMTEND_CLUBB', 1, ' ') - call add_default('RIMTEND_CLUBB', 1, ' ') - call add_default('UTEND_CLUBB', 1, ' ') - call add_default('VTEND_CLUBB', 1, ' ') - call add_default('ZT_CLUBB', 1, ' ') - call add_default('ZM_CLUBB', 1, ' ') - call add_default('UM_CLUBB', 1, ' ') - call add_default('VM_CLUBB', 1, ' ') - call add_default('PBLH', 1, ' ') - call add_default('SL', 1, ' ') - call add_default('QT', 1, ' ') - call add_default('CONCLD', 1, ' ') - + if (clubb_do_adv .or. history_clubb) then + call add_default('WP2_CLUBB', 1, ' ') + call add_default('WP3_CLUBB', 1, ' ') + call add_default('WPTHLP_CLUBB', 1, ' ') + call add_default('WPRTP_CLUBB', 1, ' ') + call add_default('RTP2_CLUBB', 1, ' ') + call add_default('THLP2_CLUBB', 1, ' ') + call add_default('RTPTHLP_CLUBB', 1, ' ') + call add_default('UP2_CLUBB', 1, ' ') + call add_default('VP2_CLUBB', 1, ' ') + end if + + if (history_clubb) then + + if (clubb_do_deep) then + call add_default('MU_CLUBB', 1, ' ') + endif + + call add_default('RELVAR', 1, ' ') + call add_default('RHO_CLUBB', 1, ' ') + call add_default('UPWP_CLUBB', 1, ' ') + call add_default('VPWP_CLUBB', 1, ' ') + call add_default('RCM_CLUBB', 1, ' ') + call add_default('WPRCP_CLUBB', 1, ' ') + call add_default('CLOUDFRAC_CLUBB', 1, ' ') + call add_default('RCMINLAYER_CLUBB', 1, ' ') + call add_default('CLOUDCOVER_CLUBB', 1, ' ') + call add_default('WPTHVP_CLUBB', 1, ' ') + call add_default('RVMTEND_CLUBB', 1, ' ') + call add_default('STEND_CLUBB', 1, ' ') + call add_default('RCMTEND_CLUBB', 1, ' ') + call add_default('RIMTEND_CLUBB', 1, ' ') + call add_default('UTEND_CLUBB', 1, ' ') + call add_default('VTEND_CLUBB', 1, ' ') + call add_default('ZT_CLUBB', 1, ' ') + call add_default('ZM_CLUBB', 1, ' ') + call add_default('UM_CLUBB', 1, ' ') + call add_default('VM_CLUBB', 1, ' ') + call add_default('SL', 1, ' ') + call add_default('QT', 1, ' ') + call add_default('CONCLD', 1, ' ') + + end if + + if (history_amwg) then + call add_default('PBLH', 1, ' ') + end if + + if (history_budget) then + call add_default('DPDLFLIQ', history_budget_histfile_num, ' ') + call add_default('DPDLFICE', history_budget_histfile_num, ' ') + call add_default('DPDLFT', history_budget_histfile_num, ' ') + call add_default('STEND_CLUBB', history_budget_histfile_num, ' ') + call add_default('RCMTEND_CLUBB', history_budget_histfile_num, ' ') + call add_default('RIMTEND_CLUBB', history_budget_histfile_num, ' ') + call add_default('RVMTEND_CLUBB', history_budget_histfile_num, ' ') + call add_default('UTEND_CLUBB', history_budget_histfile_num, ' ') + call add_default('VTEND_CLUBB', history_budget_histfile_num, ' ') + endif + ! --------------- ! ! First step? ! ! Initialization ! ! --------------- ! - ! Is this the first time step? If so then initialize CLUBB variables as follows - if (is_first_step()) then - - call pbuf_set_field(pbuf2d, wp2_idx, w_tol_sqd) - call pbuf_set_field(pbuf2d, wp3_idx, 0.0_r8) - call pbuf_set_field(pbuf2d, wpthlp_idx, 0.0_r8) - call pbuf_set_field(pbuf2d, wprtp_idx, 0.0_r8) - call pbuf_set_field(pbuf2d, rtpthlp_idx, 0.0_r8) - call pbuf_set_field(pbuf2d, rtp2_idx, rt_tol**2) - call pbuf_set_field(pbuf2d, thlp2_idx, thl_tol**2) - call pbuf_set_field(pbuf2d, up2_idx, w_tol_sqd) - call pbuf_set_field(pbuf2d, vp2_idx, w_tol_sqd) - call pbuf_set_field(pbuf2d, upwp_idx, 0.0_r8) - call pbuf_set_field(pbuf2d, vpwp_idx, 0.0_r8) - call pbuf_set_field(pbuf2d, tke_idx, 0.0_r8) - call pbuf_set_field(pbuf2d, kvh_idx, 0.0_r8) - call pbuf_set_field(pbuf2d, fice_idx, 0.0_r8) + ! Is this the first time step? If so then initialize CLUBB variables as follows + if (is_first_step()) then + + call pbuf_set_field(pbuf2d, wp2_idx, w_tol_sqd) + call pbuf_set_field(pbuf2d, wp3_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, wpthlp_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, wprtp_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, rtpthlp_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, rtp2_idx, rt_tol**2) + call pbuf_set_field(pbuf2d, thlp2_idx, thl_tol**2) + call pbuf_set_field(pbuf2d, up2_idx, w_tol_sqd) + call pbuf_set_field(pbuf2d, vp2_idx, w_tol_sqd) + + call pbuf_set_field(pbuf2d, upwp_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, vpwp_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, tke_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, kvh_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, fice_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, radf_idx, 0.0_r8) - endif + endif ! --------------- ! ! End ! @@ -589,11 +845,11 @@ end subroutine clubb_ini_cam ! ! ! =============================================================================== ! - subroutine clubb_tend_cam( & + subroutine clubb_tend_cam( & state, ptend_all, pbuf, hdtime, & - cmfmc, cmfmc2, cam_in, sgh30, dlf, & - det_s, det_ice) - + cmfmc, cam_in, sgh30, & + macmic_it, cld_macmic_num_steps,dlf, det_s, det_ice) + !------------------------------------------------------------------------------- ! Description: Provide tendencies of shallow convection, turbulence, and ! macrophysics from CLUBB to CAM @@ -605,150 +861,181 @@ subroutine clubb_tend_cam( & ! None !------------------------------------------------------------------------------- - use physics_types, only: physics_state, physics_ptend, & - physics_state_copy, physics_ptend_init, & - physics_ptend_sum, physics_update - - use physics_buffer, only: pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field, & - pbuf_set_field, physics_buffer_desc - - use ppgrid, only: pver, pverp, pcols - use constituents, only: cnst_get_ind - use camsrfexch, only: cam_in_t + use physics_types, only: physics_state, physics_ptend, & + physics_state_copy, physics_ptend_init, & + physics_ptend_sum, physics_update + + use physics_buffer, only: pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field, & + pbuf_set_field, physics_buffer_desc + + use ppgrid, only: pver, pverp, pcols + use constituents, only: cnst_get_ind + use camsrfexch, only: cam_in_t + use ref_pres, only: top_lev => trop_cloud_top_lev + use time_manager, only: is_first_step + use cam_abortutils, only: endrun + use wv_saturation, only: qsat + use micro_mg_cam, only: micro_mg_version #ifdef CLUBB_SGS - use hb_diff, only: pblintd - use scamMOD, only: single_column,scm_clubb_iop_name - use phys_grid, only: get_lat_p - use parameter_indices, only: nparams - use parameters_tunable, only: read_parameters, setup_parameters ! Subroutine - use cldwat2m_macro, only: aist_vector - use clubb_precision,only: time_precision - use cam_history, only: outfld - use clubb_core, only: advance_clubb_core - use grid_class, only: zt2zm, gr, setup_grid, cleanup_grid - use constants_clubb,only: em_min, w_tol_sqd, rt_tol, thl_tol - use model_flags, only: l_use_boussinesq - use stats_variables, only: l_stats, stats_tsamp, stats_tout, zt, & - sfc, zm, rad_zt, rad_zm, l_output_rad_files - use pdf_parameter_module, only: pdf_parameter ! Type - use saturation, only: sat_mixrat_liq - use trb_mtn_stress, only: compute_tms - use stats_subs, only: stats_begin_timestep + use hb_diff, only: pblintd + use scamMOD, only: single_column,scm_clubb_iop_name + use phys_grid, only: get_lat_p + use parameter_indices, only: nparams + use parameters_tunable, only: read_parameters, setup_parameters ! Subroutine + use cldfrc2m, only: aist_vector + use clubb_precision, only: time_precision + use cam_history, only: outfld + use advance_clubb_core_module, only: advance_clubb_core, calculate_thlp2_rad + use grid_class, only: zt2zm, zm2zt, gr, setup_grid, cleanup_grid + use constants_clubb, only: w_tol_sqd, rt_tol, thl_tol + use model_flags, only: l_use_boussinesq + use stats_variables, only: l_stats, stats_tsamp, stats_tout, stats_zt, & + stats_sfc, stats_zm, stats_rad_zt, stats_rad_zm, l_output_rad_files + use pdf_parameter_module, only: pdf_parameter ! Type + use parameters_tunable, only: mu + use saturation, only: sat_mixrat_liq + use trb_mtn_stress, only: compute_tms + use stats_clubb_utilities, only: stats_begin_timestep + use advance_xp2_xpyp_module, only: update_xp2_mc + use macrop_driver, only: ice_macro_tend #endif - implicit none + implicit none - ! --------------- ! - ! Input Auguments ! - ! --------------- ! + ! --------------- ! + ! Input Auguments ! + ! --------------- ! - type(physics_state), intent(in) :: state ! Physics state variables [vary] - type(cam_in_t), intent(in) :: cam_in - real(r8), intent(in) :: hdtime ! Host model timestep [s] - real(r8), intent(in) :: dlf(pcols,pver) ! Detraining cld H20 from deep convection [kg/ks/s] - real(r8), intent(in) :: cmfmc(pcols,pverp) ! convective mass flux--m sub c [kg/m2/s] - real(r8), intent(in) :: cmfmc2(pcols,pverp) ! shallow convective mass flux--m subc [kg/m2/s] - real(r8), intent(in) :: sgh30(pcols) ! std deviation of orography [m] + type(physics_state), intent(in) :: state ! Physics state variables [vary] + type(cam_in_t), intent(in) :: cam_in + real(r8), intent(in) :: hdtime ! Host model timestep [s] + real(r8), intent(in) :: dlf(pcols,pver) ! Detraining cld H20 from deep convection [kg/ks/s] + real(r8), intent(in) :: cmfmc(pcols,pverp) ! convective mass flux--m sub c [kg/m2/s] + real(r8), intent(in) :: sgh30(pcols) ! std deviation of orography [m] + integer, intent(in) :: cld_macmic_num_steps ! number of mac-mic iterations + integer, intent(in) :: macmic_it ! number of mac-mic iterations - ! ---------------------- ! - ! Input-Output Auguments ! - ! ---------------------- ! + ! ---------------------- ! + ! Input-Output Auguments ! + ! ---------------------- ! - type(physics_buffer_desc), pointer :: pbuf(:) + type(physics_buffer_desc), pointer :: pbuf(:) - ! ---------------------- ! - ! Output Auguments ! - ! ---------------------- ! + ! ---------------------- ! + ! Output Auguments ! + ! ---------------------- ! - type(physics_ptend), intent(out) :: ptend_all ! package tendencies + type(physics_ptend), intent(out) :: ptend_all ! package tendencies - ! These two variables are needed for energy check - real(r8), intent(out) :: det_s(pcols) ! Integral of detrained static energy from ice - real(r8), intent(out) :: det_ice(pcols) ! Integral of detrained ice for energy check + ! These two variables are needed for energy check + real(r8), intent(out) :: det_s(pcols) ! Integral of detrained static energy from ice + real(r8), intent(out) :: det_ice(pcols) ! Integral of detrained ice for energy check - ! --------------- ! - ! Local Variables ! - ! --------------- ! + ! --------------- ! + ! Local Variables ! + ! --------------- ! -#if CLUBB_SGS +#ifdef CLUBB_SGS - type(physics_state) :: state1 ! Local copy of state variable - type(physics_ptend) :: ptend_loc ! Local tendency from processes, added up to return as ptend_all + type(physics_state) :: state1 ! Local copy of state variable + type(physics_ptend) :: ptend_loc ! Local tendency from processes, added up to return as ptend_all integer :: i, j, k, t, ixind, nadv integer :: ixcldice, ixcldliq, ixnumliq, ixnumice, ixq integer :: itim_old - integer :: ncol, lchnk ! # of columns, and chunk identifier - integer :: err_code ! Diagnostic, for if some calculation goes amiss. + integer :: ncol, lchnk ! # of columns, and chunk identifier + integer :: err_code ! Diagnostic, for if some calculation goes amiss. integer :: begin_height, end_height integer :: icnt real(r8) :: frac_limit, ic_limit - real(r8) :: dtime ! CLUBB time step [s] - real(r8) :: edsclr_in(pverp,edsclr_dim) ! Scalars to be diffused through CLUBB [units vary] - real(r8) :: wp2_in(pverp) ! vertical velocity variance (CLUBB) [m^2/s^2] - real(r8) :: wp3_in(pverp) ! third moment vertical velocity [m^3/s^3] - real(r8) :: wpthlp_in(pverp) ! turbulent flux of thetal [K m/s] - real(r8) :: wprtp_in(pverp) ! turbulent flux of total water [kg/kg m/s] - real(r8) :: rtpthlp_in(pverp) ! covariance of thetal and qt [kg/kg K] - real(r8) :: rtp2_in(pverp) ! total water variance [kg^2/k^2] - real(r8) :: thlp2_in(pverp) ! thetal variance [K^2] - real(r8) :: up2_in(pverp) ! meridional wind variance [m^2/s^2] - real(r8) :: vp2_in(pverp) ! zonal wind variance [m^2/s^2] - real(r8) :: upwp_in(pverp) ! meridional wind flux [m^2/s^2] - real(r8) :: vpwp_in(pverp) ! zonal wind flux [m^2/s^2] - real(r8) :: thlm_in(pverp) ! liquid water potential temperature (thetal) [K] - real(r8) :: rtm_in(pverp) ! total water mixing ratio [kg/kg] - real(r8) :: um_in(pverp) ! meridional wind [m/s] - real(r8) :: vm_in(pverp) ! zonal wind [m/s] - real(r8) :: rho_in(pverp) ! mid-point density [kg/m^3] - real(r8) :: rcm_out(pverp) ! CLUBB output of liquid water mixing ratio [kg/kg] - real(r8) :: wprcp_out(pverp) ! CLUBB output of flux of liquid water [kg/kg m/s] - real(r8) :: cloud_frac_out(pverp) ! CLUBB output of cloud fraction [fraction] - real(r8) :: rcm_in_layer_out(pverp) ! CLUBB output of in-cloud liq. wat. mix. ratio [kg/kg] - real(r8) :: cloud_cover_out(pverp) ! CLUBB output of in-cloud cloud fraction [fraction] - real(r8) :: rho_ds_zm(pverp) ! Dry, static density on momentum levels [kg/m^3] - real(r8) :: rho_ds_zt(pverp) ! Dry, static density on thermodynamic levels [kg/m^3] - real(r8) :: invrs_rho_ds_zm(pverp) ! Inv. dry, static density on momentum levels [m^3/kg] - real(r8) :: invrs_rho_ds_zt(pverp) ! Inv. dry, static density on thermo. levels [m^3/kg] - real(r8) :: thv_ds_zm(pverp) ! Dry, base-state theta_v on momentum levels [K] - real(r8) :: thv_ds_zt(pverp) ! Dry, base-state theta_v on thermo. levels [K] - real(r8) :: zt_g(pverp) ! Thermodynamic grid of CLUBB [m] - real(r8) :: zi_g(pverp) ! Momentum grid of CLUBB [m] - real(r8) :: zt_out(pcols,pverp) ! output for the thermo CLUBB grid [m] - real(r8) :: zi_out(pcols,pverp) ! output for momentum CLUBB grid [m] - real(r8) :: fcor ! Coriolis forcing [s^-1] - real(r8) :: sfc_elevation ! Elevation of ground [m AMSL] [m] - real(r8) :: ubar ! surface wind [m/s] - real(r8) :: ustar ! surface stress [m/s] - real(r8) :: z0 ! roughness height [m] - real(r8) :: thlm_forcing(pverp) ! theta_l forcing (thermodynamic levels) [K/s] - real(r8) :: rtm_forcing(pverp) ! r_t forcing (thermodynamic levels) [(kg/kg)/s] - real(r8) :: um_forcing(pverp) ! u wind forcing (thermodynamic levels) [m/s/s] - real(r8) :: vm_forcing(pverp) ! v wind forcing (thermodynamic levels) [m/s/s] - real(r8) :: wm_zm(pverp) ! w mean wind component on momentum levels [m/s] - real(r8) :: wm_zt(pverp) ! w mean wind component on thermo. levels [m/s] - real(r8) :: p_in_Pa(pverp) ! Air pressure (thermodynamic levels) [Pa] + real(r8) :: dtime ! CLUBB time step [s] + real(r8) :: edsclr_in(pverp,edsclr_dim) ! Scalars to be diffused through CLUBB [units vary] + real(r8) :: wp2_in(pverp) ! vertical velocity variance (CLUBB) [m^2/s^2] + real(r8) :: wp3_in(pverp) ! third moment vertical velocity [m^3/s^3] + real(r8) :: wpthlp_in(pverp) ! turbulent flux of thetal [K m/s] + real(r8) :: wprtp_in(pverp) ! turbulent flux of total water [kg/kg m/s] + real(r8) :: rtpthlp_in(pverp) ! covariance of thetal and qt [kg/kg K] + real(r8) :: rtp2_in(pverp) ! total water variance [kg^2/k^2] + real(r8) :: thlp2_in(pverp) ! thetal variance [K^2] + real(r8) :: up2_in(pverp) ! meridional wind variance [m^2/s^2] + real(r8) :: vp2_in(pverp) ! zonal wind variance [m^2/s^2] + real(r8) :: upwp_in(pverp) ! meridional wind flux [m^2/s^2] + real(r8) :: vpwp_in(pverp) ! zonal wind flux [m^2/s^2] + real(r8) :: thlm_in(pverp) ! liquid water potential temperature (thetal) [K] + real(r8) :: rtm_in(pverp) ! total water mixing ratio [kg/kg] + real(r8) :: rvm_in(pverp) ! water vapor mixing ratio [kg/kg] + real(r8) :: um_in(pverp) ! meridional wind [m/s] + real(r8) :: vm_in(pverp) ! zonal wind [m/s] + real(r8) :: rho_in(pverp) ! mid-point density [kg/m^3] + real(r8) :: pre_in(pverp) ! input for precip evaporation + real(r8) :: rtp2_mc_out(pverp) ! total water tendency from rain evap + real(r8) :: thlp2_mc_out(pverp) ! thetal tendency from rain evap + real(r8) :: wprtp_mc_out(pverp) + real(r8) :: wpthlp_mc_out(pverp) + real(r8) :: rtpthlp_mc_out(pverp) + real(r8) :: rcm_out(pverp) ! CLUBB output of liquid water mixing ratio [kg/kg] + real(r8) :: rcm_out_zm(pverp) + real(r8) :: wprcp_out(pverp) ! CLUBB output of flux of liquid water [kg/kg m/s] + real(r8) :: cloud_frac_out(pverp) ! CLUBB output of cloud fraction [fraction] + real(r8) :: rcm_in_layer_out(pverp) ! CLUBB output of in-cloud liq. wat. mix. ratio [kg/kg] + real(r8) :: cloud_cover_out(pverp) ! CLUBB output of in-cloud cloud fraction [fraction] + real(r8) :: thlprcp_out(pverp) + real(r8) :: rho_ds_zm(pverp) ! Dry, static density on momentum levels [kg/m^3] + real(r8) :: rho_ds_zt(pverp) ! Dry, static density on thermodynamic levels [kg/m^3] + real(r8) :: invrs_rho_ds_zm(pverp) ! Inv. dry, static density on momentum levels [m^3/kg] + real(r8) :: invrs_rho_ds_zt(pverp) ! Inv. dry, static density on thermo. levels [m^3/kg] + real(r8) :: thv_ds_zm(pverp) ! Dry, base-state theta_v on momentum levels [K] + real(r8) :: thv_ds_zt(pverp) ! Dry, base-state theta_v on thermo. levels [K] + real(r8) :: rfrzm(pverp) + real(r8) :: radf(pverp) + real(r8) :: wprtp_forcing(pverp) + real(r8) :: wpthlp_forcing(pverp) + real(r8) :: rtp2_forcing(pverp) + real(r8) :: thlp2_forcing(pverp) + real(r8) :: rtpthlp_forcing(pverp) + real(r8) :: ice_supersat_frac(pverp) + real(r8) :: zt_g(pverp) ! Thermodynamic grid of CLUBB [m] + real(r8) :: zi_g(pverp) ! Momentum grid of CLUBB [m] + real(r8) :: zt_out(pcols,pverp) ! output for the thermo CLUBB grid [m] + real(r8) :: zi_out(pcols,pverp) ! output for momentum CLUBB grid [m] + real(r8) :: fcor ! Coriolis forcing [s^-1] + real(r8) :: sfc_elevation ! Elevation of ground [m AMSL] + real(r8) :: ubar ! surface wind [m/s] + real(r8) :: ustar ! surface stress [m/s] + real(r8) :: z0 ! roughness height [m] + real(r8) :: thlm_forcing(pverp) ! theta_l forcing (thermodynamic levels) [K/s] + real(r8) :: rtm_forcing(pverp) ! r_t forcing (thermodynamic levels) [(kg/kg)/s] + real(r8) :: um_forcing(pverp) ! u wind forcing (thermodynamic levels) [m/s/s] + real(r8) :: vm_forcing(pverp) ! v wind forcing (thermodynamic levels) [m/s/s] + real(r8) :: wm_zm(pverp) ! w mean wind component on momentum levels [m/s] + real(r8) :: wm_zt(pverp) ! w mean wind component on thermo. levels [m/s] + real(r8) :: p_in_Pa(pverp) ! Air pressure (thermodynamic levels) [Pa] real(r8) :: rho_zt(pverp) ! Air density on thermo levels [kt/m^3] - real(r8) :: rho_zm(pverp) ! Air density on momentum levels [kg/m^3] - real(r8) :: exner(pverp) ! Exner function (thermodynamic levels) [-] - real(r8) :: wpthlp_sfc ! w' theta_l' at surface [(m K)/s] - real(r8) :: wprtp_sfc ! w' r_t' at surface [(kg m)/( kg s)] - real(r8) :: upwp_sfc ! u'w' at surface [m^2/s^2] - real(r8) :: vpwp_sfc ! v'w' at surface [m^2/s^2] - real(r8) :: sclrm_forcing(pverp,sclr_dim) ! Passive scalar forcing [{units vary}/s] - real(r8) :: wpsclrp_sfc(sclr_dim) ! Scalar flux at surface [{units vary} m/s] - real(r8) :: edsclrm_forcing(pverp,edsclr_dim)! Eddy passive scalar forcing [{units vary}/s] - real(r8) :: wpedsclrp_sfc(edsclr_dim) ! Eddy-scalar flux at surface [{units vary} m/s] - real(r8) :: sclrm(pverp,sclr_dim) ! Passive scalar mean (thermo. levels) [units vary] - real(r8) :: wpsclrp(pverp,sclr_dim) ! w'sclr' (momentum levels) [{units vary} m/s] - real(r8) :: sclrp2(pverp,sclr_dim) ! sclr'^2 (momentum levels) [{units vary}^2] - real(r8) :: sclrprtp(pverp,sclr_dim) ! sclr'rt' (momentum levels) [{units vary} (kg/kg)] - real(r8) :: sclrpthlp(pverp,sclr_dim) ! sclr'thlp' (momentum levels) [{units vary} (K)] + real(r8) :: rho_zm(pverp) ! Air density on momentum levels [kg/m^3] + real(r8) :: exner(pverp) ! Exner function (thermodynamic levels) [-] + real(r8) :: wpthlp_sfc ! w' theta_l' at surface [(m K)/s] + real(r8) :: wprtp_sfc ! w' r_t' at surface [(kg m)/( kg s)] + real(r8) :: upwp_sfc ! u'w' at surface [m^2/s^2] + real(r8) :: vpwp_sfc ! v'w' at surface [m^2/s^2] + real(r8) :: sclrm_forcing(pverp,sclr_dim) ! Passive scalar forcing [{units vary}/s] + real(r8) :: wpsclrp_sfc(sclr_dim) ! Scalar flux at surface [{units vary} m/s] + real(r8) :: edsclrm_forcing(pverp,edsclr_dim)! Eddy passive scalar forcing [{units vary}/s] + real(r8) :: wpedsclrp_sfc(edsclr_dim) ! Eddy-scalar flux at surface [{units vary} m/s] + real(r8) :: sclrm(pverp,sclr_dim) ! Passive scalar mean (thermo. levels) [units vary] + real(r8) :: wpsclrp(pverp,sclr_dim) ! w'sclr' (momentum levels) [{units vary} m/s] + real(r8) :: sclrp2(pverp,sclr_dim) ! sclr'^2 (momentum levels) [{units vary}^2] + real(r8) :: sclrprtp(pverp,sclr_dim) ! sclr'rt' (momentum levels) [{units vary} (kg/kg)] + real(r8) :: sclrpthlp(pverp,sclr_dim) ! sclr'thlp' (momentum levels) [{units vary} (K)] + real(r8) :: hydromet(pverp,hydromet_dim) + real(r8) :: wphydrometp(pverp,hydromet_dim) + real(r8) :: wp2hmp(pverp,hydromet_dim) + real(r8) :: rtphmp_zt(pverp,hydromet_dim) + real(r8) :: thlphmp_zt (pverp,hydromet_dim) real(r8) :: bflx22 ! Variable for buoyancy flux for pbl [K m/s] real(r8) :: C_10 ! transfer coefficient [-] real(r8) :: khzm_out(pverp) ! eddy diffusivity on momentum grids [m^2/s] @@ -761,6 +1048,10 @@ subroutine clubb_tend_cam( & real(r8) :: minqn ! minimum total cloud liquid + ice threshold [kg/kg] real(r8) :: tempqn ! temporary total cloud liquid + ice [kg/kg] real(r8) :: cldthresh ! threshold to determin cloud fraction [kg/kg] + real(r8) :: relvarmax + real(r8) :: qmin + real(r8) :: varmu(pcols) + real(r8) :: varmu2 ! Variables below are needed to compute energy integrals for conservation real(r8) :: ke_a(pcols), ke_b(pcols), te_a(pcols), te_b(pcols) @@ -770,90 +1061,127 @@ subroutine clubb_tend_cam( & real(r8) :: exner_clubb(pcols,pverp) ! Exner function consistent with CLUBB [-] real(r8) :: wpthlp_output(pcols,pverp) ! Heat flux output variable [W/m2] real(r8) :: wprtp_output(pcols,pverp) ! Total water flux output variable [W/m2] + real(r8) :: wp3_output(pcols,pverp) ! wp3 output [m^3/s^3] + real(r8) :: rtpthlp_output(pcols,pverp) ! rtpthlp ouptut [K kg/kg] real(r8) :: qt_output(pcols,pver) ! Total water mixing ratio for output [kg/kg] real(r8) :: thetal_output(pcols,pver) ! Liquid water potential temperature output [K] real(r8) :: sl_output(pcols,pver) ! Liquid water static energy [J/kg] real(r8) :: ustar2(pcols) ! Surface stress for PBL height [m2/s2] - real(r8) :: rho(pcols,pverp) ! Midpoint density in CAM [kg/m^3] - real(r8) :: thv(pcols,pver) ! virtual potential temperature [K] - real(r8) :: edsclr_out(pverp,edsclr_dim) ! Scalars to be diffused through CLUBB [units vary] - real(r8) :: rcm(pcols,pverp) ! CLUBB cloud water mixing ratio [kg/kg] - real(r8) :: cloud_frac(pcols,pverp) ! CLUBB cloud fraction [fraction] - real(r8) :: rcm_in_layer(pcols,pverp) ! CLUBB in-cloud liquid water mixing ratio [kg/kg] - real(r8) :: cloud_cover(pcols,pverp) ! CLUBB in-cloud cloud fraction [fraction] - real(r8) :: wprcp(pcols,pverp) ! CLUBB liquid water flux [m/s kg/kg] - real(r8) :: wpthvp(pcols,pverp) ! CLUBB buoyancy flux [W/m^2] + real(r8) :: rho(pcols,pverp) ! Midpoint density in CAM [kg/m^3] + real(r8) :: thv(pcols,pver) ! virtual potential temperature [K] + real(r8) :: edsclr_out(pverp,edsclr_dim) ! Scalars to be diffused through CLUBB [units vary] + real(r8) :: rcm(pcols,pverp) ! CLUBB cloud water mixing ratio [kg/kg] + real(r8) :: cloud_frac(pcols,pverp) ! CLUBB cloud fraction [fraction] + real(r8) :: rcm_in_layer(pcols,pverp) ! CLUBB in-cloud liquid water mixing ratio [kg/kg] + real(r8) :: cloud_cover(pcols,pverp) ! CLUBB in-cloud cloud fraction [fraction] + real(r8) :: wprcp(pcols,pverp) ! CLUBB liquid water flux [m/s kg/kg] + real(r8) :: wpthvp(pcols,pverp) ! CLUBB buoyancy flux [W/m^2] + real(r8) :: rvm(pcols,pverp) real(r8) :: dlf2(pcols,pver) ! Detraining cld H20 from shallow convection [kg/kg/day] - real(r8) :: eps ! Rv/Rd [-] - real(r8) :: dum1 ! dummy variable [units vary] - real(r8) :: obklen(pcols) ! Obukov length [m] - real(r8) :: kbfs(pcols) ! Kinematic Surface heat flux [K m/s] - real(r8) :: th(pcols,pver) ! potential temperature [K] - real(r8) :: dummy2(pcols) ! dummy variable [units vary] - real(r8) :: dummy3(pcols) ! dummy variable [units vary] - real(r8) :: kinheat(pcols) ! Kinematic Surface heat flux [K m/s] - real(r8) :: ksrftms(pcols) ! Turbulent mountain stress surface drag [kg/s/m2] - real(r8) :: tautmsx(pcols) ! U component of turbulent mountain stress [N/m2] - real(r8) :: tautmsy(pcols) ! V component of turbulent mountain stress [N/m2] - real(r8) :: rrho ! Inverse of air density [1/kg/m^3] + real(r8) :: eps ! Rv/Rd [-] + real(r8) :: dum1 ! dummy variable [units vary] + real(r8) :: obklen(pcols) ! Obukov length [m] + real(r8) :: kbfs(pcols) ! Kinematic Surface heat flux [K m/s] + real(r8) :: th(pcols,pver) ! potential temperature [K] + real(r8) :: dummy2(pcols) ! dummy variable [units vary] + real(r8) :: dummy3(pcols) ! dummy variable [units vary] + real(r8) :: kinheat(pcols) ! Kinematic Surface heat flux [K m/s] + real(r8) :: ksrftms(pcols) ! Turbulent mountain stress surface drag [kg/s/m2] + real(r8) :: tautmsx(pcols) ! U component of turbulent mountain stress [N/m2] + real(r8) :: tautmsy(pcols) ! V component of turbulent mountain stress [N/m2] + real(r8) :: rrho ! Inverse of air density [1/kg/m^3] real(r8) :: kinwat(pcols) ! Kinematic water vapor flux [m/s] + real(r8) :: latsub + real(r8) :: qrl_clubb(pverp) + real(r8) :: qrl_zm(pverp) + real(r8) :: thlp2_rad_out(pverp) + real(r8) :: apply_const + + integer :: ktop(pcols,pver) + integer :: ncvfin(pcols) + real(r8) :: chs(pcols,pverp) + real(r8) :: lwp_CL(pver) + real(r8) :: opt_depth_CL(pver) + real(r8) :: radinvfrac_CL(pver) + real(r8) :: radf_CL(pver) + real(r8) :: radf_out(pver) + real(r8) :: es(pcols,pver) + real(r8) :: qs(pcols,pver) + real(r8) :: gam(pcols,pver) + real(r8) :: bfact, orgparam, delpavg + character(len=6) :: choice_radf - real(kind=time_precision) :: time_elapsed ! time keep track of stats [s] - real(r8), dimension(nparams) :: clubb_params ! These adjustable CLUBB parameters (C1, C2 ...) - real(r8), dimension(sclr_dim) :: sclr_tol ! Tolerance on passive scalar [units vary] - type(pdf_parameter), dimension(pverp) :: pdf_params ! PDF parameters [units vary] - character(len=200) :: temp1, sub ! Strings needed for CLUBB output - - ! --------------- ! - ! Pointers ! - ! --------------- ! - - real(r8), pointer, dimension(:,:) :: wp2 ! vertical velocity variance [m^2/s^2] - real(r8), pointer, dimension(:,:) :: wp3 ! third moment of vertical velocity [m^3/s^3] - real(r8), pointer, dimension(:,:) :: wpthlp ! turbulent flux of thetal [m/s K] - real(r8), pointer, dimension(:,:) :: wprtp ! turbulent flux of moisture [m/s kg/kg] - real(r8), pointer, dimension(:,:) :: rtpthlp ! covariance of thetal and qt [kg/kg K] - real(r8), pointer, dimension(:,:) :: rtp2 ! moisture variance [kg^2/kg^2] - real(r8), pointer, dimension(:,:) :: thlp2 ! temperature variance [K^2] - real(r8), pointer, dimension(:,:) :: up2 ! east-west wind variance [m^2/s^2] - real(r8), pointer, dimension(:,:) :: vp2 ! north-south wind variance [m^2/s^2] - real(r8), pointer, dimension(:,:) :: upwp ! east-west momentum flux [m^2/s^2] - real(r8), pointer, dimension(:,:) :: vpwp ! north-south momentum flux [m^2/s^2] - real(r8), pointer, dimension(:,:) :: thlm ! mean temperature [K] - real(r8), pointer, dimension(:,:) :: rtm ! mean moisture mixing ratio [kg/kg] - real(r8), pointer, dimension(:,:) :: um ! mean east-west wind [m/s] - real(r8), pointer, dimension(:,:) :: vm ! mean north-south wind [m/s] - real(r8), pointer, dimension(:,:) :: cld ! cloud fraction [fraction] - real(r8), pointer, dimension(:,:) :: concld ! convective cloud fraction [fraction] - real(r8), pointer, dimension(:,:) :: ast ! stratiform cloud fraction [fraction] - real(r8), pointer, dimension(:,:) :: alst ! liquid stratiform cloud fraction [fraction] - real(r8), pointer, dimension(:,:) :: aist ! ice stratiform cloud fraction [fraction] - real(r8), pointer, dimension(:,:) :: qlst ! Physical in-stratus LWC [kg/kg] - real(r8), pointer, dimension(:,:) :: qist ! Physical in-stratus IWC [kg/kg] - real(r8), pointer, dimension(:,:) :: deepcu ! deep convection cloud fraction [fraction] - real(r8), pointer, dimension(:,:) :: shalcu ! shallow convection cloud fraction [fraction] + integer :: time_elapsed ! time keep track of stats [s] + real(r8), dimension(nparams) :: clubb_params ! These adjustable CLUBB parameters (C1, C2 ...) + real(r8), dimension(sclr_dim) :: sclr_tol ! Tolerance on passive scalar [units vary] + type(pdf_parameter), dimension(pverp) :: pdf_params ! PDF parameters [units vary] + character(len=200) :: temp1, sub ! Strings needed for CLUBB output + logical :: l_Lscale_plume_centered, l_use_ice_latent + + + ! --------------- ! + ! Pointers ! + ! --------------- ! + + real(r8), pointer, dimension(:,:) :: wp2 ! vertical velocity variance [m^2/s^2] + real(r8), pointer, dimension(:,:) :: wp3 ! third moment of vertical velocity [m^3/s^3] + real(r8), pointer, dimension(:,:) :: wpthlp ! turbulent flux of thetal [m/s K] + real(r8), pointer, dimension(:,:) :: wprtp ! turbulent flux of moisture [m/s kg/kg] + real(r8), pointer, dimension(:,:) :: rtpthlp ! covariance of thetal and qt [kg/kg K] + real(r8), pointer, dimension(:,:) :: rtp2 ! moisture variance [kg^2/kg^2] + real(r8), pointer, dimension(:,:) :: thlp2 ! temperature variance [K^2] + real(r8), pointer, dimension(:,:) :: up2 ! east-west wind variance [m^2/s^2] + real(r8), pointer, dimension(:,:) :: vp2 ! north-south wind variance [m^2/s^2] + + real(r8), pointer, dimension(:,:) :: upwp ! east-west momentum flux [m^2/s^2] + real(r8), pointer, dimension(:,:) :: vpwp ! north-south momentum flux [m^2/s^2] + real(r8), pointer, dimension(:,:) :: thlm ! mean temperature [K] + real(r8), pointer, dimension(:,:) :: rtm ! mean moisture mixing ratio [kg/kg] + real(r8), pointer, dimension(:,:) :: um ! mean east-west wind [m/s] + real(r8), pointer, dimension(:,:) :: vm ! mean north-south wind [m/s] + real(r8), pointer, dimension(:,:) :: cld ! cloud fraction [fraction] + real(r8), pointer, dimension(:,:) :: concld ! convective cloud fraction [fraction] + real(r8), pointer, dimension(:,:) :: ast ! stratiform cloud fraction [fraction] + real(r8), pointer, dimension(:,:) :: alst ! liquid stratiform cloud fraction [fraction] + real(r8), pointer, dimension(:,:) :: aist ! ice stratiform cloud fraction [fraction] + real(r8), pointer, dimension(:,:) :: qlst ! Physical in-stratus LWC [kg/kg] + real(r8), pointer, dimension(:,:) :: qist ! Physical in-stratus IWC [kg/kg] + real(r8), pointer, dimension(:,:) :: deepcu ! deep convection cloud fraction [fraction] + real(r8), pointer, dimension(:,:) :: shalcu ! shallow convection cloud fraction [fraction] real(r8), pointer, dimension(:,:) :: khzt ! eddy diffusivity on thermo levels [m^2/s] real(r8), pointer, dimension(:,:) :: khzm ! eddy diffusivity on momentum levels [m^2/s] - real(r8), pointer, dimension(:,:) :: pblh ! planetary boundary layer height [m] + real(r8), pointer, dimension(:) :: pblh ! planetary boundary layer height [m] real(r8), pointer, dimension(:,:) :: tke ! turbulent kinetic energy [m^2/s^2] real(r8), pointer, dimension(:,:) :: dp_icwmr ! deep convection in cloud mixing ratio [kg/kg] real(r8), pointer, dimension(:,:) :: relvar ! relative cloud water variance [-] real(r8), pointer, dimension(:,:) :: accre_enhan ! accretion enhancement factor [-] real(r8), pointer, dimension(:,:) :: cmeliq + real(r8), pointer, dimension(:,:) :: cmfmc_sh ! Shallow convective mass flux--m subc (pcols,pverp) [kg/m2/s/] + + real(r8), pointer, dimension(:,:) :: naai + real(r8), pointer, dimension(:,:) :: prer_evap + real(r8), pointer, dimension(:,:) :: qrl + real(r8), pointer, dimension(:,:) :: radf_clubb + real(r8) stend(pcols,pver) + real(r8) qvtend(pcols,pver) + real(r8) qitend(pcols,pver) + real(r8) initend(pcols,pver) logical :: lqice(pcnst) + + integer :: ixorg intrinsic :: selected_real_kind, max #endif det_s(:) = 0.0_r8 det_ice(:) = 0.0_r8 -#if CLUBB_SGS +#ifdef CLUBB_SGS !-----------------------------------------------------------------------------------------------! !-----------------------------------------------------------------------------------------------! !-----------------------------------------------------------------------------------------------! - ! MAIN COMPUTATION BEGINS HERE ! + ! MAIN COMPUTATION BEGINS HERE ! !-----------------------------------------------------------------------------------------------! !-----------------------------------------------------------------------------------------------! !-----------------------------------------------------------------------------------------------! @@ -861,6 +1189,12 @@ subroutine clubb_tend_cam( & frac_limit = 0.01_r8 ic_limit = 1.e-12_r8 + if (clubb_do_adv) then + apply_const = 1._r8 ! Initialize to one, only if CLUBB's moments are advected + else + apply_const = 0._r8 ! Never want this if CLUBB's moments are not advected + endif + ! Get indicees for cloud and ice mass and cloud and ice number call cnst_get_ind('Q',ixq) @@ -870,11 +1204,19 @@ subroutine clubb_tend_cam( & call cnst_get_ind('NUMICE',ixnumice) ! Initialize physics tendency arrays, copy the state to state1 array to use in this routine - - call physics_ptend_init(ptend_loc,state%psetcols, 'clubb', ls=.true., lu=.true., lv=.true., lq=lq) + + if (.not. micro_do_icesupersat) then + call physics_ptend_init(ptend_loc,state%psetcols, 'clubb', ls=.true., lu=.true., lv=.true., lq=lq) + endif call physics_state_copy(state,state1) + if (micro_do_icesupersat) then + naai_idx = pbuf_get_index('NAAI') + call pbuf_get_field(pbuf, naai_idx, naai) + call physics_ptend_init(ptend_all, state%psetcols, 'clubb') + endif + ! Determine number of columns and which chunk computation is to be performed on ncol = state%ncol @@ -895,14 +1237,17 @@ subroutine clubb_tend_cam( & call pbuf_get_field(pbuf, thlp2_idx, thlp2, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) call pbuf_get_field(pbuf, up2_idx, up2, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) call pbuf_get_field(pbuf, vp2_idx, vp2, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) + call pbuf_get_field(pbuf, upwp_idx, upwp, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) call pbuf_get_field(pbuf, vpwp_idx, vpwp, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) call pbuf_get_field(pbuf, thlm_idx, thlm, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) call pbuf_get_field(pbuf, rtm_idx, rtm, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) call pbuf_get_field(pbuf, um_idx, um, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) call pbuf_get_field(pbuf, vm_idx, vm, start=(/1,1,itim_old/), kount=(/pcols,pverp,1/)) - + call pbuf_get_field(pbuf, tke_idx, tke) + call pbuf_get_field(pbuf, qrl_idx, qrl) + call pbuf_get_field(pbuf, radf_idx, radf_clubb) call pbuf_get_field(pbuf, cld_idx, cld, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) call pbuf_get_field(pbuf, concld_idx, concld, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) @@ -912,6 +1257,7 @@ subroutine clubb_tend_cam( & call pbuf_get_field(pbuf, qlst_idx, qlst, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) call pbuf_get_field(pbuf, qist_idx, qist, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, prer_evap_idx, prer_evap) call pbuf_get_field(pbuf, accre_enhan_idx, accre_enhan) call pbuf_get_field(pbuf, cmeliq_idx, cmeliq) call pbuf_get_field(pbuf, relvar_idx, relvar) @@ -921,13 +1267,103 @@ subroutine clubb_tend_cam( & call pbuf_get_field(pbuf, kvh_idx, khzm) call pbuf_get_field(pbuf, pblh_idx, pblh) call pbuf_get_field(pbuf, icwmrdp_idx, dp_icwmr) + call pbuf_get_field(pbuf, cmfmc_sh_idx, cmfmc_sh) + + ! Intialize the apply_const variable (note special logic is due to eularian backstepping) + if (clubb_do_adv .and. (is_first_step() .or. all(wpthlp(1:ncol,1:pver) .eq. 0._r8))) then + apply_const = 0._r8 ! On first time through do not remove constant + ! from moments since it has not been added yet + endif + + if (micro_do_icesupersat) then - ! Determine CLUBB time step based on host model time step - ! Current algorithm is to always allow at least 4 CLUBB timesteps per host model - ! timestep. However, a maximum timestep of 300 s and a minimum timestep of 60 s - ! is imposed. - dtime=max(min((1.0_r8*hdtime)/4.0_r8,300.0_r8),60.0_r8) + ! -------------------------------------- ! + ! Ice Saturation Adjustment Computation ! + ! -------------------------------------- ! + lq2(:) = .FALSE. + lq2(1) = .TRUE. + lq2(ixcldice) = .TRUE. + lq2(ixnumice) = .TRUE. + + latsub = latvap + latice + + call physics_ptend_init(ptend_loc, state%psetcols, 'iceadj', ls=.true., lq=lq2 ) + + stend(:ncol,:)=0._r8 + qvtend(:ncol,:)=0._r8 + qitend(:ncol,:)=0._r8 + initend(:ncol,:)=0._r8 + + call ice_macro_tend(naai(:ncol,top_lev:pver),state1%t(:ncol,top_lev:pver), & + state1%pmid(:ncol,top_lev:pver),state1%q(:ncol,top_lev:pver,1),state1%q(:ncol,top_lev:pver,ixcldice),& + state1%q(:ncol,top_lev:pver,ixnumice),latsub,hdtime,& + stend(:ncol,top_lev:pver),qvtend(:ncol,top_lev:pver),qitend(:ncol,top_lev:pver),& + initend(:ncol,top_lev:pver)) + + ! update local copy of state with the tendencies + ptend_loc%q(:ncol,top_lev:pver,1)=qvtend(:ncol,top_lev:pver) + ptend_loc%q(:ncol,top_lev:pver,ixcldice)=qitend(:ncol,top_lev:pver) + ptend_loc%q(:ncol,top_lev:pver,ixnumice)=initend(:ncol,top_lev:pver) + ptend_loc%s(:ncol,top_lev:pver)=stend(:ncol,top_lev:pver) + + ! Add the ice tendency to the output tendency + call physics_ptend_sum(ptend_loc, ptend_all, ncol) + + ! ptend_loc is reset to zero by this call + call physics_update(state1, ptend_loc, hdtime) + + !Write output for tendencies: + ! oufld: QVTENDICE,QITENDICE,NITENDICE + call outfld( 'TTENDICE', stend/cpair, pcols, lchnk ) + call outfld( 'QVTENDICE', qvtend, pcols, lchnk ) + call outfld( 'QITENDICE', qitend, pcols, lchnk ) + call outfld( 'NITENDICE', initend, pcols, lchnk ) + + endif + + ! Determine CLUBB time step and make it sub-step friendly + ! For now we want CLUBB time step to be 5 min since that is + ! what has been scientifically validated. However, there are certain + ! instances when a 5 min time step will not be possible (based on + ! host model time step or on macro-micro sub-stepping + + dtime = clubb_timestep + + ! Now check to see if dtime is greater than the host model + ! (or sub stepped) time step. If it is, then simply + ! set it equal to the host (or sub step) time step. + ! This section is mostly to deal with small host model + ! time steps (or small sub-steps) + + if (dtime .gt. hdtime) then + dtime = hdtime + endif + + ! Now check to see if CLUBB time step divides evenly into + ! the host model time step. If not, force it to divide evenly. + ! We also want it to be 5 minutes or less. This section is + ! mainly for host model time steps that are not evenly divisible + ! by 5 minutes + + if (mod(hdtime,dtime) .ne. 0) then + dtime = hdtime/2._r8 + do while (dtime .gt. 300._r8) + dtime = dtime/2._r8 + end do + endif + + ! If resulting host model time step and CLUBB time step do not divide evenly + ! into each other, have model throw a fit. + + if (mod(hdtime,dtime) .ne. 0) then + call endrun('clubb_tend_cam: CLUBB time step and HOST time step NOT compatible') + endif + + ! determine number of timesteps CLUBB core should be advanced, + ! host time step divided by CLUBB time step + nadv = max(hdtime/dtime,1._r8) + ! Initialize forcings for transported scalars to zero sclrm_forcing(:,:) = 0._r8 @@ -939,10 +1375,6 @@ subroutine clubb_tend_cam( & where(state1%q(:ncol,:pver,3) .gt. minqn) & newfice(:ncol,:pver) = state1%q(:ncol,:pver,3)/(state1%q(:ncol,:pver,2)+state1%q(:ncol,:pver,3)) - ! determine number of timesteps CLUBB core should be advanced, - ! host time step divided by CLUBB time step - nadv = max(hdtime/dtime,1._r8) - ! Compute exner function consistent with CLUBB's definition, which uses a constant ! surface pressure. CAM's exner (in state does not). Therefore, for consistent ! treatment with CLUBB code, anytime exner is needed to treat CLUBB variables @@ -960,18 +1392,59 @@ subroutine clubb_tend_cam( & do k=1,pver ! loop over levels do i=1,ncol ! loop over columns - rtm(i,k) = state1%q(i,k,ixq)+state1%q(i,k,ixcldliq) - um(i,k) = state1%u(i,k) - vm(i,k) = state1%v(i,k) - thlm(i,k) = state1%t(i,k)*exner_clubb(i,k)-(latvap/cpair)*state1%q(i,k,ixcldliq) - + rtm(i,k) = state1%q(i,k,ixq)+state1%q(i,k,ixcldliq) + rvm(i,k) = state1%q(i,k,ixq) + um(i,k) = state1%u(i,k) + vm(i,k) = state1%v(i,k) + thlm(i,k) = state1%t(i,k)*exner_clubb(i,k)-(latvap/cpair)*state1%q(i,k,ixcldliq) + + if (clubb_do_adv) then + if (macmic_it .eq. 1) then + + ! Note that some of the moments below can be positive or negative. + ! Remove a constant that was added to prevent dynamics from clipping + ! them to prevent dynamics from making them positive. + thlp2(i,k) = state1%q(i,k,ixthlp2) + rtp2(i,k) = state1%q(i,k,ixrtp2) + rtpthlp(i,k) = state1%q(i,k,ixrtpthlp) - (rtpthlp_const*apply_const) + wpthlp(i,k) = state1%q(i,k,ixwpthlp) - (wpthlp_const*apply_const) + wprtp(i,k) = state1%q(i,k,ixwprtp) - (wprtp_const*apply_const) + wp2(i,k) = state1%q(i,k,ixwp2) + wp3(i,k) = state1%q(i,k,ixwp3) - (wp3_const*apply_const) + up2(i,k) = state1%q(i,k,ixup2) + vp2(i,k) = state1%q(i,k,ixvp2) + endif + endif + enddo enddo + + if (clubb_do_adv) then + ! If not last step of macmic loop then set apply_const back to + ! zero to prevent output from being corrupted. + if (macmic_it .eq. cld_macmic_num_steps) then + apply_const = 1._r8 + else + apply_const = 0._r8 + endif + endif rtm(1:ncol,pverp) = rtm(1:ncol,pver) um(1:ncol,pverp) = state1%u(1:ncol,pver) vm(1:ncol,pverp) = state1%v(1:ncol,pver) thlm(1:ncol,pverp) = thlm(1:ncol,pver) + + if (clubb_do_adv) then + thlp2(1:ncol,pverp)=thlp2(1:ncol,pver) + rtp2(1:ncol,pverp)=rtp2(1:ncol,pver) + rtpthlp(1:ncol,pverp)=rtpthlp(1:ncol,pver) + wpthlp(1:ncol,pverp)=wpthlp(1:ncol,pver) + wprtp(1:ncol,pverp)=wprtp(1:ncol,pver) + wp2(1:ncol,pverp)=wp2(1:ncol,pver) + wp3(1:ncol,pverp)=wp3(1:ncol,pver) + up2(1:ncol,pverp)=up2(1:ncol,pver) + vp2(1:ncol,pverp)=vp2(1:ncol,pver) + endif ! Compute integrals of static energy, kinetic energy, water vapor, and liquid water ! for the computation of total energy before CLUBB is called. This is for an @@ -992,24 +1465,28 @@ subroutine clubb_tend_cam( & ! Compute virtual potential temperature, which is needed for CLUBB do k=1,pver - do i=1,ncol + do i=1,ncol thv(i,k) = state1%t(i,k)*exner_clubb(i,k)*(1._r8+zvir*state1%q(i,k,ixq)& -state1%q(i,k,ixcldliq)) enddo enddo ! ------------------------------------------------- ! - ! Begin module to compute turbulent mountain stress ! + ! Begin module to compute turbulent mountain stress ! ! ------------------------------------------------- ! call compute_tms( pcols, pver, ncol, & state1%u, state1%v, state1%t, state1%pmid, & - state1%exner, state1%zm, sgh30, ksrftms, & - tautmsx, tautmsy, cam_in%landfrac ) - + state1%exner, state1%zm, sgh30, ksrftms, & + tautmsx, tautmsy, cam_in%landfrac ) + + if (micro_do_icesupersat) then + call physics_ptend_init(ptend_loc,state%psetcols, 'clubb', ls=.true., lu=.true., lv=.true., lq=lq) + endif + + ! ------------------------------------------------- ! + ! End module to compute turbulent mountain stress ! ! ------------------------------------------------- ! - ! End module to compute turbulent mountain stress ! - ! ------------------------------------------------- ! ! Loop over all columns in lchnk to advance CLUBB core do i=1,ncol ! loop over columns @@ -1031,7 +1508,7 @@ subroutine clubb_tend_cam( & ! Define the CLUBB thermodynamic grid (in units of m) do k=1,pver zt_g(k+1) = state1%zm(i,pver-k+1)-state1%zi(i,pver+1) - dz_g(k) = state1%zi(i,k)-state1%zi(i,k+1) ! compute thickness + dz_g(k) = state1%zi(i,k)-state1%zi(i,k+1) ! compute thickness enddo ! Thermodynamic ghost point is below surface @@ -1049,6 +1526,9 @@ subroutine clubb_tend_cam( & invrs_rho_ds_zt(k+1) = 1._r8/(rho_ds_zt(k+1)) ! Inverse ds rho at thermo rho(i,k+1) = rho_ds_zt(k+1) ! rho on thermo thv_ds_zt(k+1) = thv(i,pver-k+1) ! thetav on thermo + rfrzm(k+1) = state1%q(i,pver-k+1,ixcldice) + radf(k+1) = radf_clubb(i,pver-k+1) + qrl_clubb(k+1) = qrl(i,pver-k+1)/(cpair*state1%pdel(i,pver-k+1)) enddo ! Below computes the same stuff for the ghost point. May or may @@ -1060,6 +1540,9 @@ subroutine clubb_tend_cam( & rho_zt(:) = rho(i,:) p_in_Pa(1) = p_in_Pa(2) exner(1) = exner(2) + rfrzm(1) = rfrzm(2) + radf(1) = radf(2) + qrl_clubb(1) = qrl_clubb(2) ! Compute mean w wind on thermo grid, convert from omega to w wm_zt(1) = 0._r8 @@ -1067,19 +1550,13 @@ subroutine clubb_tend_cam( & wm_zt(k+1) = -1._r8*state1%omega(i,pver-k+1)/(rho(i,k+1)*gravit) enddo - ! Surface fluxes provided by host model - wpthlp_sfc = cam_in%shf(i)/(cpair*rho(i,1)) ! Sensible heat flux - wprtp_sfc = cam_in%lhf(i)/(latvap*rho(i,1)) ! Latent heat flux - upwp_sfc = cam_in%wsx(i)/rho(i,1) ! Surface meridional momentum flux - vpwp_sfc = cam_in%wsy(i)/rho(i,1) ! Surface zonal momentum flux - - ! ------------------------------------------------- ! - ! Begin case specific code for SCAM cases. ! - ! This section of code block NOT called in ! - ! global simulations ! - ! ------------------------------------------------- ! + ! ------------------------------------------------- ! + ! Begin case specific code for SCAM cases. ! + ! This section of code block NOT called in ! + ! global simulations ! + ! ------------------------------------------------- ! - if (single_column) then + if (single_column) then ! Initialize zo if variable ustar is used @@ -1099,28 +1576,16 @@ subroutine clubb_tend_cam( & ! Define ustar (based on case, if not variable) ustar = 0.25_r8 ! Initialize ustar in case no case - if(trim(scm_clubb_iop_name) .eq. 'DYCOMSrf01_4day') then - ustar = 0.25_r8 - endif - - if(trim(scm_clubb_iop_name) .eq. 'DYCOMSrf02_06hr') then - ustar = 0.25_r8 - endif - if(trim(scm_clubb_iop_name) .eq. 'BOMEX_5day') then ustar = 0.28_r8 endif if(trim(scm_clubb_iop_name) .eq. 'ATEX_48hr') then - ustar = 0.30_r8 - wpthlp_sfc = 3.0_r8/(cpair*rho(i,1)) - wprtp_sfc = 110.0_r8/(latvap*rho(i,1)) + ustar = 0.30_r8 endif if(trim(scm_clubb_iop_name) .eq. 'RICO_3day') then - ustar = 0.28_r8 - wpthlp_sfc = 9.5_r8/(cpair*rho(i,1)) - wprtp_sfc = 138.0_r8/(latvap*rho(i,1)) + ustar = 0.28_r8 endif if(trim(scm_clubb_iop_name) .eq. 'arm97' .or. trim(scm_clubb_iop_name) .eq. 'gate' .or. & @@ -1131,283 +1596,488 @@ subroutine clubb_tend_cam( & ustar = diag_ustar(zt_g(2),bflx22,ubar,zo) endif - if(trim(scm_clubb_iop_name) .eq. 'gate') then - C_10 = 0.0013_r8 - wpthlp_sfc = -C_10*ubar*(thlm(1,pver)-300.5_r8*(1000._r8/1015._r8)**(rair/cpair)) - wprtp_sfc = -C_10*ubar*(rtm(1,pver)-0.0198293_r8) - endif - ! Compute the surface momentum fluxes, if this is a SCAM simulation upwp_sfc = -um(i,pver)*ustar**2/ubar vpwp_sfc = -vm(i,pver)*ustar**2/ubar - endif + endif - ! ------------------------------------------------- ! - ! End case specific code for SCAM cases ! - ! ------------------------------------------------- ! - - ! ------------------------------------------------- ! - ! Apply TMS ! - ! ------------------------------------------------- ! + ! Define surface sources for transported variables for diffusion, will + ! be zero as these tendencies are done in clubb_surface + do ixind=1,edsclr_dim + wpedsclrp_sfc(ixind) = 0._r8 + enddo + + ! Define forcings from CAM to CLUBB as zero for momentum and thermo, + ! forcings already applied through CAM + thlm_forcing(1:pverp) = 0._r8 + rtm_forcing(1:pverp) = 0._r8 + um_forcing(1:pverp) = 0._r8 + vm_forcing(1:pverp) = 0._r8 + + wprtp_forcing(1:pverp) = 0._r8 + wpthlp_forcing(1:pverp) = 0._r8 + rtp2_forcing(1:pverp) = 0._r8 + thlp2_forcing(1:pverp) = 0._r8 + rtpthlp_forcing(1:pverp) = 0._r8 + + ice_supersat_frac(1:pverp) = 0._r8 + + ! Set stats output and increment equal to CLUBB and host dt + stats_tsamp = dtime + stats_tout = hdtime + + ! Heights need to be set at each timestep. Therefore, recall + ! setup_grid and setup_parameters for this. + + ! Read in parameters for CLUBB. Just read in default values + call read_parameters( -99, "", clubb_params ) + + ! Set-up CLUBB core at each CLUBB call because heights can change + call setup_grid(pverp, sfc_elevation, l_implemented, grid_type, & + zi_g(2), zi_g(1), zi_g(pverp), zi_g(1:pverp), zt_g(1:pverp), & + begin_height, end_height) + + call setup_parameters(zi_g(2), clubb_params, pverp, grid_type, & + zi_g(begin_height:end_height), zt_g(begin_height:end_height), err_code) + + ! Compute some inputs from the thermodynamic grid + ! to the momentum grid + rho_ds_zm = zt2zm(rho_ds_zt) + rho_zm = zt2zm(rho_zt) + invrs_rho_ds_zm = zt2zm(invrs_rho_ds_zt) + thv_ds_zm = zt2zm(thv_ds_zt) + wm_zm = zt2zm(wm_zt) - upwp_sfc = upwp_sfc-((ksrftms(i)*state1%u(i,pver))/rho(i,1)) - vpwp_sfc = vpwp_sfc-((ksrftms(i)*state1%v(i,pver))/rho(i,1)) - - ! Define surface sources for transported variables for diffusion, will - ! be zero as these tendencies are done in clubb_surface - do ixind=1,edsclr_dim - wpedsclrp_sfc(ixind) = 0._r8 - enddo - - ! Define forcings from CAM to CLUBB as zero for momentum and thermo, - ! forcings already applied through CAM - thlm_forcing(1:pverp) = 0._r8 - rtm_forcing(1:pverp) = 0._r8 - um_forcing(1:pverp) = 0._r8 - vm_forcing(1:pverp) = 0._r8 - - ! Set stats output and increment equal to CLUBB and host dt - stats_tsamp = dtime - stats_tout = hdtime - - ! Heights need to be set at each timestep. Therefore, recall - ! setup_grid and setup_parameters for this. - - ! Read in parameters for CLUBB. Just read in default values - call read_parameters( -99, "", clubb_params ) - - ! Set-up CLUBB core at each CLUBB call because heights can change - call setup_grid(pverp, sfc_elevation, l_implemented, grid_type, & - zi_g(2), zi_g(1), zi_g(pverp), zi_g(1:pverp), zt_g(1:pverp), & - begin_height, end_height) - - call setup_parameters(zi_g(2), clubb_params, pverp, grid_type, & - zi_g(begin_height:end_height), zt_g(begin_height:end_height), err_code) - - ! Compute some inputs from the thermodynamic grid - ! to the momentum grid - rho_ds_zm = zt2zm(rho_ds_zt) - rho_zm = zt2zm(rho_zt) - invrs_rho_ds_zm = zt2zm(invrs_rho_ds_zt) - thv_ds_zm = zt2zm(thv_ds_zt) - wm_zm = zt2zm(wm_zt) + ! Surface fluxes provided by host model + wpthlp_sfc = cam_in%shf(i)/(cpair*rho_ds_zm(1)) ! Sensible heat flux + wprtp_sfc = cam_in%lhf(i)/(latvap*rho_ds_zm(1)) ! Latent heat flux + upwp_sfc = cam_in%wsx(i)/rho_ds_zm(1) ! Surface meridional momentum flux + vpwp_sfc = cam_in%wsy(i)/rho_ds_zm(1) ! Surface zonal momentum flux + + ! ------------------------------------------------- ! + ! Apply TMS ! + ! ------------------------------------------------- ! + + upwp_sfc = upwp_sfc-((ksrftms(i)*state1%u(i,pver))/rho_ds_zm(1)) + vpwp_sfc = vpwp_sfc-((ksrftms(i)*state1%v(i,pver))/rho_ds_zm(1)) + + ! Need to flip arrays around for CLUBB core + do k=1,pverp + um_in(k) = um(i,pverp-k+1) + vm_in(k) = vm(i,pverp-k+1) + upwp_in(k) = upwp(i,pverp-k+1) + vpwp_in(k) = vpwp(i,pverp-k+1) + up2_in(k) = up2(i,pverp-k+1) + vp2_in(k) = vp2(i,pverp-k+1) + wp2_in(k) = wp2(i,pverp-k+1) + wp3_in(k) = wp3(i,pverp-k+1) + rtp2_in(k) = rtp2(i,pverp-k+1) + thlp2_in(k) = thlp2(i,pverp-k+1) + thlm_in(k) = thlm(i,pverp-k+1) + rtm_in(k) = rtm(i,pverp-k+1) + rvm_in(k) = rvm(i,pverp-k+1) + wprtp_in(k) = wprtp(i,pverp-k+1) + wpthlp_in(k) = wpthlp(i,pverp-k+1) + rtpthlp_in(k) = rtpthlp(i,pverp-k+1) - ! Need to flip arrays around for CLUBB core - do k=1,pverp - um_in(k) = um(i,pverp-k+1) - vm_in(k) = vm(i,pverp-k+1) - upwp_in(k) = upwp(i,pverp-k+1) - vpwp_in(k) = vpwp(i,pverp-k+1) - up2_in(k) = up2(i,pverp-k+1) - vp2_in(k) = vp2(i,pverp-k+1) - wp2_in(k) = wp2(i,pverp-k+1) - wp3_in(k) = wp3(i,pverp-k+1) - rtp2_in(k) = rtp2(i,pverp-k+1) - thlp2_in(k) = thlp2(i,pverp-k+1) - thlm_in(k) = thlm(i,pverp-k+1) - rtm_in(k) = rtm(i,pverp-k+1) - wprtp_in(k) = wprtp(i,pverp-k+1) - wpthlp_in(k) = wpthlp(i,pverp-k+1) - rtpthlp_in(k) = rtpthlp(i,pverp-k+1) - - ! Initialize these to prevent crashing behavior - rcm_out(k) = 0._r8 - wprcp_out(k) = 0._r8 - cloud_frac_out(k) = 0._r8 - rcm_in_layer_out(k) = 0._r8 - cloud_cover_out(k) = 0._r8 - edsclr_in(k,:) = 0._r8 - edsclr_out(k,:) = 0._r8 - khzm_out(k) = 0._r8 - khzt_out(k) = 0._r8 - - ! higher order scalar stuff, put to zero - sclrm(k,:) = 0._r8 - wpsclrp(k,:) = 0._r8 - sclrp2(k,:) = 0._r8 - sclrprtp(k,:) = 0._r8 - sclrpthlp(k,:) = 0._r8 - wpsclrp_sfc(:) = 0._r8 - - enddo + if (k .ne. 1) then + pre_in(k) = prer_evap(i,pverp-k+1) + endif + + ! Initialize these to prevent crashing behavior + rcm_out(k) = 0._r8 + wprcp_out(k) = 0._r8 + cloud_frac_out(k) = 0._r8 + rcm_in_layer_out(k) = 0._r8 + cloud_cover_out(k) = 0._r8 + edsclr_in(k,:) = 0._r8 + edsclr_out(k,:) = 0._r8 + khzm_out(k) = 0._r8 + khzt_out(k) = 0._r8 + + ! higher order scalar stuff, put to zero + sclrm(k,:) = 0._r8 + wpsclrp(k,:) = 0._r8 + sclrp2(k,:) = 0._r8 + sclrprtp(k,:) = 0._r8 + sclrpthlp(k,:) = 0._r8 + wpsclrp_sfc(:) = 0._r8 + hydromet(k,:) = 0._r8 + wphydrometp(k,:) = 0._r8 + wp2hmp(k,:) = 0._r8 + rtphmp_zt(k,:) = 0._r8 + thlphmp_zt(k,:) = 0._r8 + + enddo + + pre_in(1) = pre_in(2) + + if (clubb_do_adv) then + if (macmic_it .eq. 1) then + wp2_in=zt2zm(wp2_in) + wpthlp_in=zt2zm(wpthlp_in) + wprtp_in=zt2zm(wprtp_in) + up2_in=zt2zm(up2_in) + vp2_in=zt2zm(vp2_in) + thlp2_in=zt2zm(thlp2_in) + rtp2_in=zt2zm(rtp2_in) + rtpthlp_in=zt2zm(rtpthlp_in) + + do k=1,pverp + thlp2_in(k)=max(thl_tol**2,thlp2_in(k)) + rtp2_in(k)=max(rt_tol**2,rtp2_in(k)) + wp2_in(k)=max(w_tol_sqd,wp2_in(k)) + up2_in(k)=max(w_tol_sqd,up2_in(k)) + vp2_in(k)=max(w_tol_sqd,vp2_in(k)) + enddo + endif + endif + + ! Do the same for tracers + icnt=0 + do ixind=1,pcnst + if (lq(ixind)) then + icnt=icnt+1 + do k=1,pver + edsclr_in(k+1,icnt) = state1%q(i,pver-k+1,ixind) + enddo + edsclr_in(1,icnt) = edsclr_in(2,icnt) + end if + enddo + + if (do_expldiff) then + do k=1,pver + edsclr_in(k+1,icnt+1) = thlm(i,pver-k+1) + edsclr_in(k+1,icnt+2) = rtm(i,pver-k+1) + enddo + + edsclr_in(1,icnt+1) = edsclr_in(2,icnt+1) + edsclr_in(1,icnt+2) = edsclr_in(2,icnt+2) + endif - ! Do the same for tracers - icnt=0 - do ixind=1,pcnst - if (lq(ixind)) then - icnt=icnt+1 - do k=1,pver - edsclr_in(k+1,icnt) = state1%q(i,pver-k+1,ixind) - enddo - edsclr_in(1,icnt) = edsclr_in(2,icnt) - end if - enddo - - rho_in(:) = rho(i,:) + rho_in(:) = rho(i,:) + + ! --------------------------------------------------------- ! + ! Compute cloud-top radiative cooling contribution to CLUBB ! + ! --------------------------------------------------------- ! + + ! Sandbox version of code to take into account meso organization + + if (clubb_do_deep) then + orgparam = 0._r8 + delpavg = 0._r8 + + do k = 1, pver + if (abs(prer_evap(i,k)) .gt. 0._r8) then + orgparam = orgparam + (abs(prer_evap(i,k)) * 1000._r8 * 1000._r8 * 2._r8 ) * state1%pdel(i,k) + delpavg = delpavg + state1%pdel(i,k) + endif + enddo + + if (delpavg .gt. 0._r8) then + orgparam = orgparam/delpavg + endif + + ! Now compute new entrainment rate based on organization + varmu2 = mu / (1._r8 + orgparam * 100._r8) + varmu(i) = varmu2 + + endif - do t=1,nadv ! do needed number of "sub" timesteps for each CAM step - - ! Increment the statistics then being stats timestep - if (l_stats) then - time_elapsed = time_elapsed+dtime - call stats_begin_timestep(time_elapsed) - endif + ! --------------------------------------------------------- ! + ! End cloud-top radiative cooling contribution to CLUBB ! + ! --------------------------------------------------------- ! + + do t=1,nadv ! do needed number of "sub" timesteps for each CAM step + + ! Increment the statistics then being stats timestep + if (l_stats) then + time_elapsed = time_elapsed+dtime + call stats_begin_timestep(time_elapsed, 1, 1) + endif + + ! Advance CLUBB CORE one timestep in the future + call advance_clubb_core & + ( l_implemented, dtime, fcor, sfc_elevation, hydromet_dim, & + thlm_forcing, rtm_forcing, um_forcing, vm_forcing, & + sclrm_forcing, edsclrm_forcing, wprtp_forcing, & + wpthlp_forcing, rtp2_forcing, thlp2_forcing, & + rtpthlp_forcing, wm_zm, wm_zt, & + wpthlp_sfc, wprtp_sfc, upwp_sfc, vpwp_sfc, & + wpsclrp_sfc, wpedsclrp_sfc, & + p_in_Pa, rho_zm, rho_in, exner, & + rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & + invrs_rho_ds_zt, thv_ds_zm, thv_ds_zt, hydromet, & + rfrzm, radf, do_expldiff, & +#ifdef CLUBBND_CAM + varmu2, & +#endif + wphydrometp, wp2hmp, rtphmp_zt, thlphmp_zt, & + host_dx, host_dy, & + um_in, vm_in, upwp_in, & + vpwp_in, up2_in, vp2_in, & + thlm_in, rtm_in, wprtp_in, wpthlp_in, & + wp2_in, wp3_in, rtp2_in, & + thlp2_in, rtpthlp_in, & + sclrm, sclrp2, sclrprtp, sclrpthlp, & + wpsclrp, edsclr_in, err_code, & + rcm_out, wprcp_out, cloud_frac_out, ice_supersat_frac, & + rcm_in_layer_out, cloud_cover_out, & + khzm_out, khzt_out, qclvar_out, thlprcp_out, & + pdf_params) + + if (do_rainturb) then + rvm_in = rtm_in - rcm_out + call update_xp2_mc(pverp, dtime, cloud_frac_out, & + rcm_out, rvm_in, thlm_in, wm_zt, exner, pre_in, pdf_params, & + rtp2_mc_out, thlp2_mc_out, & + wprtp_mc_out, wpthlp_mc_out, & + rtpthlp_mc_out) + + if (clubb_do_deep) then + dum1 = 1._r8 + else + dum1 = (1._r8 - cam_in%landfrac(i)) + end if + + ! update turbulent moments based on rain evaporation + rtp2_in = rtp2_in + clubb_rnevap_effic * dum1 * rtp2_mc_out * dtime + thlp2_in = thlp2_in + clubb_rnevap_effic * dum1 * thlp2_mc_out * dtime + if (.not. clubb_do_deep) then + wprtp_in = wprtp_in + clubb_rnevap_effic * dum1 * wprtp_mc_out * dtime + wpthlp_in = wpthlp_in + clubb_rnevap_effic * dum1 * wpthlp_mc_out * dtime + endif +! rtpthlp_in = rtpthlp_in + rtpthlp_mc_out * dtime + endif + + if (do_cldcool) then + + rcm_out_zm = zt2zm(rcm_out) + qrl_zm = zt2zm(qrl_clubb) + thlp2_rad_out(:) = 0._r8 + call calculate_thlp2_rad(pverp, rcm_out_zm, thlprcp_out, qrl_zm, thlp2_rad_out) + thlp2_in = thlp2_in + thlp2_rad_out * dtime + thlp2_in = max(thl_tol**2,thlp2_in) + endif - ! Advance CLUBB CORE one timestep in the future - call advance_clubb_core & - ( l_implemented, dtime, fcor, sfc_elevation, & - thlm_forcing, rtm_forcing, um_forcing, vm_forcing, & - sclrm_forcing, edsclrm_forcing,& - wm_zm, wm_zt, & - wpthlp_sfc, wprtp_sfc, upwp_sfc, vpwp_sfc, & - wpsclrp_sfc, wpedsclrp_sfc, & - p_in_Pa, rho_zm, rho_in, exner, & - rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & - invrs_rho_ds_zt, thv_ds_zm, thv_ds_zt, & - um_in, vm_in, upwp_in, & - vpwp_in, up2_in, vp2_in, & - thlm_in, rtm_in, wprtp_in, wpthlp_in, & - wp2_in, wp3_in, rtp2_in, & - thlp2_in, rtpthlp_in, & - sclrm, sclrp2, sclrprtp, sclrpthlp, & - wpsclrp, edsclr_in, err_code, & - rcm_out, wprcp_out, cloud_frac_out, & - rcm_in_layer_out, cloud_cover_out, & - khzm_out, khzt_out, qclvar_out, & - pdf_params) - - ! Check to see if stats should be output, here stats are read into - ! output arrays to make them conformable to CAM output - if (l_stats) call stats_end_timestep_clubb(lchnk,i,out_zt,out_zm,& - out_radzt,out_radzm,out_sfc) - - enddo ! end time loop - - call cleanup_grid() + ! Check to see if stats should be output, here stats are read into + ! output arrays to make them conformable to CAM output + if (l_stats) call stats_end_timestep_clubb(lchnk,i,out_zt,out_zm,& + out_radzt,out_radzm,out_sfc) + + enddo ! end time loop + + if (clubb_do_adv) then + if (macmic_it .eq. cld_macmic_num_steps) then + wp2_in=zm2zt(wp2_in) + wpthlp_in=zm2zt(wpthlp_in) + wprtp_in=zm2zt(wprtp_in) + up2_in=zm2zt(up2_in) + vp2_in=zm2zt(vp2_in) + thlp2_in=zm2zt(thlp2_in) + rtp2_in=zm2zt(rtp2_in) + rtpthlp_in=zm2zt(rtpthlp_in) + + do k=1,pverp + thlp2_in(k)=max(thl_tol**2,thlp2_in(k)) + rtp2_in(k)=max(rt_tol**2,rtp2_in(k)) + wp2_in(k)=max(w_tol_sqd,wp2_in(k)) + up2_in(k)=max(w_tol_sqd,up2_in(k)) + vp2_in(k)=max(w_tol_sqd,vp2_in(k)) + enddo + endif + endif + + call cleanup_grid() - ! Arrays need to be "flipped" to CAM grid - do k=1,pverp + ! Arrays need to be "flipped" to CAM grid + do k=1,pverp - um(i,k) = um_in(pverp-k+1) - vm(i,k) = vm_in(pverp-k+1) - upwp(i,k) = upwp_in(pverp-k+1) - vpwp(i,k) = vpwp_in(pverp-k+1) - up2(i,k) = up2_in(pverp-k+1) - vp2(i,k) = vp2_in(pverp-k+1) - thlm(i,k) = thlm_in(pverp-k+1) - rtm(i,k) = rtm_in(pverp-k+1) - wprtp(i,k) = wprtp_in(pverp-k+1) - wpthlp(i,k) = wpthlp_in(pverp-k+1) - wp2(i,k) = wp2_in(pverp-k+1) - wp3(i,k) = wp3_in(pverp-k+1) - rtp2(i,k) = rtp2_in(pverp-k+1) - thlp2(i,k) = thlp2_in(pverp-k+1) - rtpthlp(i,k) = rtpthlp_in(pverp-k+1) - rcm(i,k) = rcm_out(pverp-k+1) - wprcp(i,k) = wprcp_out(pverp-k+1) - cloud_frac(i,k) = min(cloud_frac_out(pverp-k+1),1._r8) - rcm_in_layer(i,k) = rcm_in_layer_out(pverp-k+1) - cloud_cover(i,k) = min(cloud_cover_out(pverp-k+1),1._r8) - zt_out(i,k) = zt_g(pverp-k+1) - zi_out(i,k) = zi_g(pverp-k+1) - khzm(i,k) = khzm_out(pverp-k+1) - khzt(i,k) = khzt_out(pverp-k+1) - qclvar(i,k) = min(1._r8,qclvar_out(pverp-k+1)) + um(i,k) = um_in(pverp-k+1) + vm(i,k) = vm_in(pverp-k+1) + upwp(i,k) = upwp_in(pverp-k+1) + vpwp(i,k) = vpwp_in(pverp-k+1) + up2(i,k) = up2_in(pverp-k+1) + vp2(i,k) = vp2_in(pverp-k+1) + thlm(i,k) = thlm_in(pverp-k+1) + rtm(i,k) = rtm_in(pverp-k+1) + wprtp(i,k) = wprtp_in(pverp-k+1) + wpthlp(i,k) = wpthlp_in(pverp-k+1) + wp2(i,k) = wp2_in(pverp-k+1) + wp3(i,k) = wp3_in(pverp-k+1) + rtp2(i,k) = rtp2_in(pverp-k+1) + thlp2(i,k) = thlp2_in(pverp-k+1) + rtpthlp(i,k) = rtpthlp_in(pverp-k+1) + rcm(i,k) = rcm_out(pverp-k+1) + wprcp(i,k) = wprcp_out(pverp-k+1) + cloud_frac(i,k) = min(cloud_frac_out(pverp-k+1),1._r8) + rcm_in_layer(i,k) = rcm_in_layer_out(pverp-k+1) + cloud_cover(i,k) = min(cloud_cover_out(pverp-k+1),1._r8) + zt_out(i,k) = zt_g(pverp-k+1) + zi_out(i,k) = zi_g(pverp-k+1) + khzm(i,k) = khzm_out(pverp-k+1) + khzt(i,k) = khzt_out(pverp-k+1) + qclvar(i,k) = min(1._r8,qclvar_out(pverp-k+1)) - do ixind=1,edsclr_dim - edsclr_out(k,ixind) = edsclr_in(pverp-k+1,ixind) - enddo - - enddo + do ixind=1,edsclr_dim + edsclr_out(k,ixind) = edsclr_in(pverp-k+1,ixind) + enddo - zi_out(i,1) = 0._r8 + enddo - ! Compute integrals for static energy, kinetic energy, water vapor, and liquid water - ! after CLUBB is called. This is for energy conservation purposes. - se_a = 0._r8 - ke_a = 0._r8 - wv_a = 0._r8 - wl_a = 0._r8 - do k=1,pver - clubb_s(k) = cpair*((thlm(i,k)+(latvap/cpair)*rcm(i,k))/exner_clubb(i,k))+ & - gravit*state1%zm(i,k)+state1%phis(i) - se_a(i) = se_a(i) + clubb_s(k)*state1%pdel(i,k)/gravit - ke_a(i) = ke_a(i) + 0.5_r8*(um(i,k)**2+vm(i,k)**2)*state1%pdel(i,k)/gravit - wv_a(i) = wv_a(i) + (rtm(i,k)-rcm(i,k))*state1%pdel(i,k)/gravit - wl_a(i) = wl_a(i) + (rcm(i,k))*state1%pdel(i,k)/gravit - enddo + ! Fill up arrays needed for McICA. Note we do not want the ghost point, + ! thus why the second loop is needed. - ! Based on these integrals, compute the total energy before and after CLUBB call - do k=1,pver - te_a(i) = se_a(i) + ke_a(i) + (latvap+latice)*wv_a(i)+latice*wl_a(i) - te_b(i) = se_b(i) + ke_b(i) + (latvap+latice)*wv_b(i)+latice*wl_b(i) - enddo + zi_out(i,1) = 0._r8 - ! Take into account the surface fluxes of heat and moisture - te_b(i) = te_b(i)+(cam_in%shf(i)+(cam_in%lhf(i)/latvap)*(latvap+latice))*hdtime + ! Compute integrals for static energy, kinetic energy, water vapor, and liquid water + ! after CLUBB is called. This is for energy conservation purposes. + se_a = 0._r8 + ke_a = 0._r8 + wv_a = 0._r8 + wl_a = 0._r8 + do k=1,pver + clubb_s(k) = cpair*((thlm(i,k)+(latvap/cpair)*rcm(i,k))/exner_clubb(i,k))+ & + gravit*state1%zm(i,k)+state1%phis(i) + se_a(i) = se_a(i) + clubb_s(k)*state1%pdel(i,k)/gravit + ke_a(i) = ke_a(i) + 0.5_r8*(um(i,k)**2+vm(i,k)**2)*state1%pdel(i,k)/gravit + wv_a(i) = wv_a(i) + (rtm(i,k)-rcm(i,k))*state1%pdel(i,k)/gravit + wl_a(i) = wl_a(i) + (rcm(i,k))*state1%pdel(i,k)/gravit + enddo - ! Compute the disbalance of total energy - se_dis = (te_a(i) - te_b(i))/(state1%ps(i)-state1%pint(i,1)) + ! Based on these integrals, compute the total energy before and after CLUBB call + do k=1,pver + te_a(i) = se_a(i) + ke_a(i) + (latvap+latice)*wv_a(i)+latice*wl_a(i) + te_b(i) = se_b(i) + ke_b(i) + (latvap+latice)*wv_b(i)+latice*wl_b(i) + enddo + + ! Take into account the surface fluxes of heat and moisture + te_b(i) = te_b(i)+(cam_in%shf(i)+(cam_in%lhf(i)/latvap)*(latvap+latice))*hdtime - ! Fix the total energy coming out of CLUBB so it achieves enery conservation. - ! Apply this fixer throughout the column evenly. - do k=1,pver - clubb_s(k) = clubb_s(k) - se_dis*gravit - enddo - - ! Now compute the tendencies of CLUBB to CAM, note that pverp is the ghost point - ! for all variables and therefore is never called in this loop - do k=1,pver + ! Compute the disbalance of total energy + se_dis = (te_a(i) - te_b(i))/(state1%ps(i)-state1%pint(i,1)) + + ! Fix the total energy coming out of CLUBB so it achieves enery conservation. + ! Apply this fixer throughout the column evenly. + do k=1,pver + clubb_s(k) = clubb_s(k) - se_dis*gravit + enddo + + ! Now compute the tendencies of CLUBB to CAM, note that pverp is the ghost point + ! for all variables and therefore is never called in this loop + do k=1,pver - ptend_loc%u(i,k) = (um(i,k)-state1%u(i,k))/hdtime ! east-west wind - ptend_loc%v(i,k) = (vm(i,k)-state1%v(i,k))/hdtime ! north-south wind - ptend_loc%q(i,k,ixq) = (rtm(i,k)-rcm(i,k)-state1%q(i,k,ixq))/hdtime ! water vapor - ptend_loc%q(i,k,ixcldliq) = (rcm(i,k)-state1%q(i,k,ixcldliq))/hdtime ! Tendency of liquid water - ptend_loc%s(i,k) = (clubb_s(k)-state1%s(i,k))/hdtime ! Tendency of static energy - - ! Apply tendencies to ice mixing ratio, liquid and ice number, and aerosol constituents. - ! Loading up this array doesn't mean the tendencies are applied. - ! edsclr_out is compressed with just the constituents being used, ptend and state are not compressed - - icnt=0 - do ixind=1,pcnst - if (lq(ixind)) then - icnt=icnt+1 - if ((ixind /= ixq) .and. (ixind /= ixcldliq)) then - ptend_loc%q(i,k,ixind) = (edsclr_out(k,icnt)-state1%q(i,k,ixind))/hdtime ! transported constituents - end if - end if - enddo + ptend_loc%u(i,k) = (um(i,k)-state1%u(i,k))/hdtime ! east-west wind + ptend_loc%v(i,k) = (vm(i,k)-state1%v(i,k))/hdtime ! north-south wind + ptend_loc%q(i,k,ixq) = (rtm(i,k)-rcm(i,k)-state1%q(i,k,ixq))/hdtime ! water vapor + ptend_loc%q(i,k,ixcldliq) = (rcm(i,k)-state1%q(i,k,ixcldliq))/hdtime ! Tendency of liquid water + ptend_loc%s(i,k) = (clubb_s(k)-state1%s(i,k))/hdtime ! Tendency of static energy + + if (clubb_do_adv) then + if (macmic_it .eq. cld_macmic_num_steps) then + + ! Here add a constant to moments which can be either positive or + ! negative. This is to prevent clipping when dynamics tries to + ! make all constituents positive + wp3(i,k) = wp3(i,k) + wp3_const + rtpthlp(i,k) = rtpthlp(i,k) + rtpthlp_const + wpthlp(i,k) = wpthlp(i,k) + wpthlp_const + wprtp(i,k) = wprtp(i,k) + wprtp_const + + ptend_loc%q(i,k,ixthlp2)=(thlp2(i,k)-state1%q(i,k,ixthlp2))/hdtime ! THLP Variance + ptend_loc%q(i,k,ixrtp2)=(rtp2(i,k)-state1%q(i,k,ixrtp2))/hdtime ! RTP Variance + ptend_loc%q(i,k,ixrtpthlp)=(rtpthlp(i,k)-state1%q(i,k,ixrtpthlp))/hdtime ! RTP THLP covariance + ptend_loc%q(i,k,ixwpthlp)=(wpthlp(i,k)-state1%q(i,k,ixwpthlp))/hdtime ! WPTHLP + ptend_loc%q(i,k,ixwprtp)=(wprtp(i,k)-state1%q(i,k,ixwprtp))/hdtime ! WPRTP + ptend_loc%q(i,k,ixwp2)=(wp2(i,k)-state1%q(i,k,ixwp2))/hdtime ! WP2 + ptend_loc%q(i,k,ixwp3)=(wp3(i,k)-state1%q(i,k,ixwp3))/hdtime ! WP3 + ptend_loc%q(i,k,ixup2)=(up2(i,k)-state1%q(i,k,ixup2))/hdtime ! UP2 + ptend_loc%q(i,k,ixvp2)=(vp2(i,k)-state1%q(i,k,ixvp2))/hdtime ! VP2 + else + ptend_loc%q(i,k,ixthlp2)=0._r8 + ptend_loc%q(i,k,ixrtp2)=0._r8 + ptend_loc%q(i,k,ixrtpthlp)=0._r8 + ptend_loc%q(i,k,ixwpthlp)=0._r8 + ptend_loc%q(i,k,ixwprtp)=0._r8 + ptend_loc%q(i,k,ixwp2)=0._r8 + ptend_loc%q(i,k,ixwp3)=0._r8 + ptend_loc%q(i,k,ixup2)=0._r8 + ptend_loc%q(i,k,ixvp2)=0._r8 + endif - enddo + endif + + ! Apply tendencies to ice mixing ratio, liquid and ice number, and aerosol constituents. + ! Loading up this array doesn't mean the tendencies are applied. + ! edsclr_out is compressed with just the constituents being used, ptend and state are not compressed + + icnt=0 + do ixind=1,pcnst + if (lq(ixind)) then + icnt=icnt+1 + if ((ixind /= ixq) .and. (ixind /= ixcldliq) .and.& + (ixind /= ixthlp2) .and. (ixind /= ixrtp2) .and.& + (ixind /= ixrtpthlp) .and. (ixind /= ixwpthlp) .and.& + (ixind /= ixwprtp) .and. (ixind /= ixwp2) .and.& + (ixind /= ixwp3) .and. (ixind /= ixup2) .and. (ixind /= ixvp2) ) then + ptend_loc%q(i,k,ixind) = (edsclr_out(k,icnt)-state1%q(i,k,ixind))/hdtime ! transported constituents + end if + end if + enddo + + enddo enddo ! end column loop + + ! Add constant to ghost point so that output is not corrupted + if (clubb_do_adv) then + if (macmic_it .eq. cld_macmic_num_steps) then + wp3(:,pverp) = wp3(:,pverp) + wp3_const + rtpthlp(:,pverp) = rtpthlp(:,pverp) + rtpthlp_const + wpthlp(:,pverp) = wpthlp(:,pverp) + wpthlp_const + wprtp(:,pverp) = wprtp(:,pverp) + wprtp_const + endif + endif cmeliq(:,:) = ptend_loc%q(:,:,ixcldliq) ! ------------------------------------------------- ! ! End column computation of CLUBB, begin to apply ! - ! and compute output, etc ! + ! and compute output, etc ! ! ------------------------------------------------- ! ! Output CLUBB tendencies - call outfld( 'RVMTEND_CLUBB', ptend_loc%q(:,:,ixq)*1000._r8, pcols, lchnk) - call outfld( 'RCMTEND_CLUBB', ptend_loc%q(:,:,ixcldliq)*1000._r8, pcols, lchnk) - call outfld( 'RIMTEND_CLUBB', ptend_loc%q(:,:,ixcldice)*1000._r8, pcols, lchnk) + call outfld( 'RVMTEND_CLUBB', ptend_loc%q(:,:,ixq), pcols, lchnk) + call outfld( 'RCMTEND_CLUBB', ptend_loc%q(:,:,ixcldliq), pcols, lchnk) + call outfld( 'RIMTEND_CLUBB', ptend_loc%q(:,:,ixcldice), pcols, lchnk) call outfld( 'STEND_CLUBB', ptend_loc%s,pcols, lchnk) call outfld( 'UTEND_CLUBB', ptend_loc%u,pcols, lchnk) - call outfld( 'VTEND_CLUBB', ptend_loc%v,pcols, lchnk) + call outfld( 'VTEND_CLUBB', ptend_loc%v,pcols, lchnk) + + if (clubb_do_deep) call outfld( 'MU_CLUBB', varmu ,pcols, lchnk) call outfld( 'CMELIQ', cmeliq, pcols, lchnk) ! Update physics tendencies - call physics_ptend_init(ptend_all, state%psetcols, 'clubb') + if (.not. micro_do_icesupersat) then + call physics_ptend_init(ptend_all, state%psetcols, 'clubb') + endif call physics_ptend_sum(ptend_loc,ptend_all,ncol) call physics_update(state1,ptend_loc,hdtime) + + ! ------------------------------------------------------------ ! + ! ------------------------------------------------------------ ! + ! ------------------------------------------------------------ ! + ! The rest of the code deals with diagnosing variables ! + ! for microphysics/radiation computation and macrophysics ! + ! ------------------------------------------------------------ ! + ! ------------------------------------------------------------ ! + ! ------------------------------------------------------------ ! + ! --------------------------------------------------------------------------------- ! - ! COMPUTE THE ICE CLOUD DETRAINMENT ! + ! COMPUTE THE ICE CLOUD DETRAINMENT ! ! Detrainment of convective condensate into the environment or stratiform cloud ! ! --------------------------------------------------------------------------------- ! @@ -1424,67 +2094,69 @@ subroutine clubb_tend_cam( & do k=1,pver do i=1,ncol - if( state1%t(i,k) > 268.15_r8 ) then - dum1 = 0.0_r8 - elseif ( state1%t(i,k) < 238.15_r8 ) then - dum1 = 1.0_r8 - else - dum1 = ( 268.15_r8 - state1%t(i,k) ) / 30._r8 - endif + if( state1%t(i,k) > 268.15_r8 ) then + dum1 = 0.0_r8 + elseif ( state1%t(i,k) < 238.15_r8 ) then + dum1 = 1.0_r8 + else + dum1 = ( 268.15_r8 - state1%t(i,k) ) / 30._r8 + endif - ptend_loc%q(i,k,ixcldliq) = dlf(i,k) * ( 1._r8 - dum1 ) - ptend_loc%q(i,k,ixcldice) = dlf(i,k) * dum1 - ptend_loc%q(i,k,ixnumliq) = 3._r8 * ( max(0._r8, ( dlf(i,k) - dlf2(i,k) )) * ( 1._r8 - dum1 ) ) & - / (4._r8*3.14_r8* 8.e-6_r8**3*997._r8) + & ! Deep Convection - 3._r8 * ( dlf2(i,k) * ( 1._r8 - dum1 ) ) & - / (4._r8*3.14_r8*10.e-6_r8**3*997._r8) ! Shallow Convection - ptend_loc%q(i,k,ixnumice) = 3._r8 * ( max(0._r8, ( dlf(i,k) - dlf2(i,k) )) * dum1 ) & - / (4._r8*3.14_r8*25.e-6_r8**3*500._r8) + & ! Deep Convection - 3._r8 * ( dlf2(i,k) * dum1 ) & - / (4._r8*3.14_r8*50.e-6_r8**3*500._r8) ! Shallow Convection - ptend_loc%s(i,k) = dlf(i,k) * dum1 * latice - - ! Only rliq is saved from deep convection, which is the reserved liquid. We need to keep - ! track of the integrals of ice and static energy that is effected from conversion to ice - ! so that the energy checker doesn't complain. - det_s(i) = det_s(i) + ptend_loc%s(i,k)*state1%pdel(i,k)/gravit - det_ice(i) = det_ice(i) - ptend_loc%q(i,k,ixcldice)*state1%pdel(i,k)/gravit - + ptend_loc%q(i,k,ixcldliq) = dlf(i,k) * ( 1._r8 - dum1 ) + ptend_loc%q(i,k,ixcldice) = dlf(i,k) * dum1 + ptend_loc%q(i,k,ixnumliq) = 3._r8 * ( max(0._r8, ( dlf(i,k) - dlf2(i,k) )) * ( 1._r8 - dum1 ) ) & + / (4._r8*3.14_r8* 8.e-6_r8**3*997._r8) + & ! Deep Convection + 3._r8 * ( dlf2(i,k) * ( 1._r8 - dum1 ) ) & + / (4._r8*3.14_r8*10.e-6_r8**3*997._r8) ! Shallow Convection + ptend_loc%q(i,k,ixnumice) = 3._r8 * ( max(0._r8, ( dlf(i,k) - dlf2(i,k) )) * dum1 ) & + / (4._r8*3.14_r8*25.e-6_r8**3*500._r8) + & ! Deep Convection + 3._r8 * ( dlf2(i,k) * dum1 ) & + / (4._r8*3.14_r8*50.e-6_r8**3*500._r8) ! Shallow Convection + ptend_loc%s(i,k) = dlf(i,k) * dum1 * latice + + ! Only rliq is saved from deep convection, which is the reserved liquid. We need to keep + ! track of the integrals of ice and static energy that is effected from conversion to ice + ! so that the energy checker doesn't complain. + det_s(i) = det_s(i) + ptend_loc%s(i,k)*state1%pdel(i,k)/gravit + det_ice(i) = det_ice(i) - ptend_loc%q(i,k,ixcldice)*state1%pdel(i,k)/gravit + enddo enddo det_ice(:ncol) = det_ice(:ncol)/1000._r8 ! divide by density of water + + call outfld( 'DPDLFLIQ', ptend_loc%q(:,:,ixcldliq), pcols, lchnk) + call outfld( 'DPDLFICE', ptend_loc%q(:,:,ixcldice), pcols, lchnk) + call outfld( 'DPDLFT', ptend_loc%s(:,:)/cpair, pcols, lchnk) call physics_ptend_sum(ptend_loc,ptend_all,ncol) call physics_update(state1,ptend_loc,hdtime) - ! ------------------------------------------------------------ ! - ! ------------------------------------------------------------ ! - ! ------------------------------------------------------------ ! - ! The rest of the code deals with diagnosing variables ! - ! for microphysics/radiation computation and macrophysics ! - ! ------------------------------------------------------------ ! - ! ------------------------------------------------------------ ! - ! ------------------------------------------------------------ ! - ! ------------------------------------------------- ! - ! Diagnose relative cloud water variance ! + ! Diagnose relative cloud water variance ! ! ------------------------------------------------- ! + if (deep_scheme .eq. 'CLUBB_SGS') then + relvarmax = 2.0_r8 + else + relvarmax = 10.0_r8 + endif - relvar(:,:) = 1.0_r8 ! default - - where (rcm(:ncol,:pver) /= 0 .and. qclvar(:ncol,:pver) /= 0) & - relvar(:ncol,:pver) = min(1.0_r8,max(0.001_r8,rcm(:ncol,:pver)**2/qclvar(:ncol,:pver))) + relvar(:,:) = relvarmax ! default + + if (deep_scheme .ne. 'CLUBB_SGS') then + where (rcm(:ncol,:pver) /= 0 .and. qclvar(:ncol,:pver) /= 0) & + relvar(:ncol,:pver) = min(relvarmax,max(0.001_r8,rcm(:ncol,:pver)**2/qclvar(:ncol,:pver))) + endif ! ------------------------------------------------- ! - ! Optional Accretion enhancement factor ! + ! Optional Accretion enhancement factor ! ! ------------------------------------------------- ! - - accre_enhan(:ncol,:pver) = 1._r8+0.65_r8*(1.0_r8/relvar(:ncol,:pver)) + + accre_enhan(:ncol,:pver) = 1._r8 ! ------------------------------------------------- ! - ! Diagnose some output variables ! + ! Diagnose some output variables ! ! ------------------------------------------------- ! ! density @@ -1494,35 +2166,35 @@ subroutine clubb_tend_cam( & eps = rair/rh2o wpthvp(:,:) = 0.0_r8 do k=1,pver - do i=1,ncol - ! buoyancy flux - wpthvp(i,k) = wpthlp(i,k)+((1._r8-eps)/eps)*theta0*wprtp(i,k)+((latvap/cpair)* & - state1%exner(i,k)-(1._r8/eps)*theta0)*wprcp(i,k) - - ! total water mixing ratio - qt_output(i,k) = state1%q(i,k,ixq)+state1%q(i,k,ixcldliq)+state1%q(i,k,ixcldice) - ! liquid water potential temperature - thetal_output(i,k) = (state1%t(i,k)*state1%exner(i,k))-(latvap/cpair)*state1%q(i,k,ixcldliq) - ! liquid water static energy - sl_output(i,k) = cpair*state1%t(i,k)+gravit*state1%zm(i,k)-latvap*state1%q(i,k,ixcldliq) - enddo + do i=1,ncol + ! buoyancy flux + wpthvp(i,k) = (wpthlp(i,k)-(apply_const*wpthlp_const))+((1._r8-eps)/eps)*theta0* & + (wprtp(i,k)-(apply_const*wprtp_const))+((latvap/cpair)* & + state1%exner(i,k)-(1._r8/eps)*theta0)*wprcp(i,k) + + ! total water mixing ratio + qt_output(i,k) = state1%q(i,k,ixq)+state1%q(i,k,ixcldliq)+state1%q(i,k,ixcldice) + ! liquid water potential temperature + thetal_output(i,k) = (state1%t(i,k)*state1%exner(i,k))-(latvap/cpair)*state1%q(i,k,ixcldliq) + ! liquid water static energy + sl_output(i,k) = cpair*state1%t(i,k)+gravit*state1%zm(i,k)-latvap*state1%q(i,k,ixcldliq) + enddo enddo do k=1,pverp - do i=1,ncol - ! liquid water potential temperature flux - wpthlp_output(i,k) = wpthlp(i,k)*rho(i,k)*cpair - ! total water mixig ratio flux - wprtp_output(i,k) = wprtp(i,k)*rho(i,k)*latvap - ! turbulent kinetic energy - tke(i,k) = 0.5_r8*(up2(i,k)+vp2(i,k)+wp2(i,k)) - enddo + do i=1,ncol + wpthlp_output(i,k) = (wpthlp(i,k)-(apply_const*wpthlp_const))*rho(i,k)*cpair ! liquid water potential temperature flux + wprtp_output(i,k) = (wprtp(i,k)-(apply_const*wprtp_const))*rho(i,k)*latvap ! total water mixig ratio flux + rtpthlp_output(i,k) = rtpthlp(i,k)-(apply_const*rtpthlp_const) ! rtpthlp output + wp3_output(i,k) = wp3(i,k) - (apply_const*wp3_const) ! wp3 output + tke(i,k) = 0.5_r8*(up2(i,k)+vp2(i,k)+wp2(i,k)) ! turbulent kinetic energy + enddo enddo ! --------------------------------------------------------------------------------- ! ! Diagnose some quantities that are computed in macrop_tend here. ! ! These are inputs required for the microphysics calculation. ! - ! ! + ! ! ! FIRST PART COMPUTES THE STRATIFORM CLOUD FRACTION FROM CLUBB CLOUD FRACTION ! ! --------------------------------------------------------------------------------- ! @@ -1531,69 +2203,70 @@ subroutine clubb_tend_cam( & qlst(:,:) = 0.0_r8 do k=1,pver - do i=1,ncol - alst(i,k) = cloud_frac(i,k) - qlst(i,k) = rcm(i,k)/max(0.01_r8,alst(i,k)) ! Incloud stratus condensate mixing ratio - enddo + do i=1,ncol + alst(i,k) = cloud_frac(i,k) + qlst(i,k) = rcm(i,k)/max(0.01_r8,alst(i,k)) ! Incloud stratus condensate mixing ratio + enddo enddo ! --------------------------------------------------------------------------------- ! - ! THIS PART COMPUTES CONVECTIVE AND DEEP CONVECTIVE CLOUD FRACTION ! + ! THIS PART COMPUTES CONVECTIVE AND DEEP CONVECTIVE CLOUD FRACTION ! ! --------------------------------------------------------------------------------- ! deepcu(:,pver) = 0.0_r8 shalcu(:,pver) = 0.0_r8 do k=1,pver-1 - do i=1,ncol - ! diagnose the deep convective cloud fraction, as done in macrophysics based on the - ! deep convective mass flux, read in from pbuf. Since shallow convection is never - ! called, the shallow convective mass flux will ALWAYS be zero, ensuring that this cloud - ! fraction is purely from deep convection scheme. - deepcu(i,k) = max(0.0_r8,min(0.1_r8*log(1.0_r8+500.0_r8*(cmfmc(i,k+1)-cmfmc2(i,k+1))),0.6_r8)) - shalcu(i,k) = 0._r8 + do i=1,ncol + ! diagnose the deep convective cloud fraction, as done in macrophysics based on the + ! deep convective mass flux, read in from pbuf. Since shallow convection is never + ! called, the shallow convective mass flux will ALWAYS be zero, ensuring that this cloud + ! fraction is purely from deep convection scheme. + deepcu(i,k) = max(0.0_r8,min(0.1_r8*log(1.0_r8+500.0_r8*(cmfmc(i,k+1)-cmfmc_sh(i,k+1))),0.6_r8)) + shalcu(i,k) = 0._r8 - if (deepcu(i,k) <= frac_limit .or. dp_icwmr(i,k) < ic_limit) then - deepcu(i,k) = 0._r8 - endif + if (deepcu(i,k) <= frac_limit .or. dp_icwmr(i,k) < ic_limit) then + deepcu(i,k) = 0._r8 + endif - ! using the deep convective cloud fraction, and CLUBB cloud fraction (variable - ! "cloud_frac"), compute the convective cloud fraction. This follows the formulation - ! found in macrophysics code. Assumes that convective cloud is all nonstratiform cloud - ! from CLUBB plus the deep convective cloud fraction - concld(i,k) = min(cloud_frac(i,k)-alst(i,k)+deepcu(i,k),0.80_r8) - enddo + ! using the deep convective cloud fraction, and CLUBB cloud fraction (variable + ! "cloud_frac"), compute the convective cloud fraction. This follows the formulation + ! found in macrophysics code. Assumes that convective cloud is all nonstratiform cloud + ! from CLUBB plus the deep convective cloud fraction + concld(i,k) = min(cloud_frac(i,k)-alst(i,k)+deepcu(i,k),0.80_r8) + enddo enddo if (single_column) then - if (trim(scm_clubb_iop_name) .eq. 'ATEX_48hr' .or. trim(scm_clubb_iop_name) .eq. 'BOMEX_5day' .or. & - trim(scm_clubb_iop_name) .eq. 'DYCOMSrf01_4day' .or. & - trim(scm_clubb_iop_name) .eq. 'DYCOMSrf02_06hr' .or. & - trim(scm_clubb_iop_name) .eq. 'RICO_3day' .or. & - trim(scm_clubb_iop_name) .eq. 'ARM_CC') then + if (trim(scm_clubb_iop_name) .eq. 'ATEX_48hr' .or. & + trim(scm_clubb_iop_name) .eq. 'BOMEX_5day' .or. & + trim(scm_clubb_iop_name) .eq. 'DYCOMSrf01_4day' .or. & + trim(scm_clubb_iop_name) .eq. 'DYCOMSrf02_06hr' .or. & + trim(scm_clubb_iop_name) .eq. 'RICO_3day' .or. & + trim(scm_clubb_iop_name) .eq. 'ARM_CC') then - deepcu(:,:) = 0.0_r8 - concld(:,:) = 0.0_r8 + deepcu(:,:) = 0.0_r8 + concld(:,:) = 0.0_r8 - endif + endif endif ! --------------------------------------------------------------------------------- ! - ! COMPUTE THE ICE CLOUD FRACTION PORTION ! + ! COMPUTE THE ICE CLOUD FRACTION PORTION ! ! use the aist_vector function to compute the ice cloud fraction ! ! --------------------------------------------------------------------------------- ! - do k=1,pver + do k=1,pver call aist_vector(state1%q(:,k,ixq),state1%t(:,k),state1%pmid(:,k),state1%q(:,k,ixcldice), & - cam_in%landfrac(:),cam_in%snowhland(:),aist(:,k),ncol) - enddo + state1%q(:,k,ixnumice),cam_in%landfrac(:),cam_in%snowhland(:),aist(:,k),ncol) + enddo ! --------------------------------------------------------------------------------- ! - ! THIS PART COMPUTES THE LIQUID STRATUS FRACTION ! - ! ! + ! THIS PART COMPUTES THE LIQUID STRATUS FRACTION ! + ! ! ! For now leave the computation of ice stratus fraction from macrop_driver intact ! ! because CLUBB does nothing with ice. Here I simply overwrite the liquid stratus ! - ! fraction that was coded in macrop_driver ! + ! fraction that was coded in macrop_driver ! ! --------------------------------------------------------------------------------- ! ! Recompute net stratus fraction using maximum over-lapping assumption, as done @@ -1602,58 +2275,54 @@ subroutine clubb_tend_cam( & cldthresh=1.e-18_r8 do k=1,pver - do i=1,ncol - ast(i,k) = 0._r8 ! init AST - - if (newfice(i,k) .le. 0.5_r8 .and. state1%q(i,k,2) .gt. cldthresh) then - ast(i,k) = alst(i,k) - else if ((newfice(i,k) .gt. 0.5_r8 .and. state1%q(i,k,3) .gt. cldthresh) .or. & - (newfice(i,k) .le. 0.5_r8 .and. state1%q(i,k,2) .lt. cldthresh & - .and. state1%q(i,k,3) .gt. cldthresh)) then - ast(i,k) = aist(i,k) - end if - - qist(i,k) = state1%q(i,k,ixcldice)/max(0.01_r8,aist(i,k)) - enddo + do i=1,ncol + + ast(i,k) = max(alst(i,k),aist(i,k)) + + qist(i,k) = state1%q(i,k,ixcldice)/max(0.01_r8,aist(i,k)) + enddo enddo ! Probably need to add deepcu cloud fraction to the cloud fraction array, else would just ! be outputting the shallow convective cloud fraction do k=1,pver - do i=1,ncol - cloud_frac(i,k) = min(ast(i,k)+deepcu(i,k),1.0_r8) - enddo + do i=1,ncol + cloud_frac(i,k) = min(ast(i,k)+deepcu(i,k),1.0_r8) + enddo enddo ! --------------------------------------------------------------------------------- ! - ! DIAGNOSE THE PBL DEPTH ! + ! DIAGNOSE THE PBL DEPTH ! ! this is needed for aerosol code ! - ! --------------------------------------------------------------------------------- ! + ! --------------------------------------------------------------------------------- ! do i=1,ncol - do k=1,pver - th(i,k) = state1%t(i,k)*state1%exner(i,k) - thv(i,k) = th(i,k)*(1.0_r8+zvir*state1%q(i,k,ixq)) - enddo + do k=1,pver + th(i,k) = state1%t(i,k)*state1%exner(i,k) + thv(i,k) = th(i,k)*(1.0_r8+zvir*state1%q(i,k,ixq)) + enddo enddo ! diagnose surface friction and obukhov length (inputs to diagnose PBL depth) do i=1,ncol - call calc_ustar( state1%t(i,pver), state1%pmid(i,pver), cam_in%wsx(i), cam_in%wsy(i), & - rrho, ustar2(i) ) - call calc_obklen( th(i,pver), thv(i,pver), cam_in%lhf(i)/latvap, cam_in%shf(i), rrho, ustar2(i), & - kinheat(i), kinwat(i), kbfs(i), obklen(i) ) + rrho = (1._r8/gravit)*(state1%pdel(i,pver)/dz_g(pver)) + call calc_ustar( state1%t(i,pver), state1%pmid(i,pver), cam_in%wsx(i), cam_in%wsy(i), & + rrho, ustar2(i) ) + call calc_obklen( th(i,pver), thv(i,pver), cam_in%lhf(i)/latvap, cam_in%shf(i), rrho, ustar2(i), & + kinheat(i), kinwat(i), kbfs(i), obklen(i) ) enddo dummy2(:) = 0._r8 dummy3(:) = 0._r8 + + where (kbfs .eq. -0.0_r8) kbfs = 0.0_r8 ! Compute PBL depth according to Holtslag-Boville Scheme call pblintd(ncol, thv, state1%zm, state1%u, state1%v, & - ustar2, obklen, kinheat, pblh, dummy2, & - state1%zi, cloud_frac(:,1:pver), 1._r8-cam_in%landfrac, dummy3) - + ustar2, obklen, kbfs, pblh, dummy2, & + state1%zi, cloud_frac(:,1:pver), 1._r8-cam_in%landfrac, dummy3) + ! Output the PBL depth call outfld('PBLH', pblh, pcols, lchnk) @@ -1665,66 +2334,68 @@ subroutine clubb_tend_cam( & ! --------------------------------------------------------------------------------- ! ! Output calls of variables goes here - call outfld( 'RHO_CLUBB', rho, pcols, lchnk ) - call outfld( 'WP2_CLUBB', wp2, pcols, lchnk ) - call outfld( 'UP2_CLUBB', up2, pcols, lchnk ) - call outfld( 'VP2_CLUBB', vp2, pcols, lchnk ) - call outfld( 'WP3_CLUBB', wp3, pcols, lchnk ) - call outfld( 'UPWP_CLUBB', upwp, pcols, lchnk ) - call outfld( 'VPWP_CLUBB', vpwp, pcols, lchnk ) - call outfld( 'WPTHLP_CLUBB', wpthlp_output, pcols, lchnk ) - call outfld( 'WPRTP_CLUBB', wprtp_output, pcols, lchnk ) - call outfld( 'RTP2_CLUBB', rtp2*1000._r8, pcols, lchnk ) - call outfld( 'THLP2_CLUBB', thlp2, pcols, lchnk ) - call outfld( 'RTPTHLP_CLUBB', rtpthlp*1000._r8, pcols, lchnk ) - call outfld( 'RCM_CLUBB', rcm*1000._r8, pcols, lchnk ) - call outfld( 'WPRCP_CLUBB', wprcp*latvap, pcols, lchnk ) - call outfld( 'CLOUDFRAC_CLUBB', alst, pcols, lchnk ) - call outfld( 'RCMINLAYER_CLUBB', rcm_in_layer*1000._r8, pcols, lchnk ) - call outfld( 'CLOUDCOVER_CLUBB', cloud_frac, pcols, lchnk ) - call outfld( 'WPTHVP_CLUBB', wpthvp*cpair, pcols, lchnk ) - call outfld( 'ZT_CLUBB', 1._r8*zt_out, pcols, lchnk ) - call outfld( 'ZM_CLUBB', 1._r8*zi_out, pcols, lchnk ) - call outfld( 'UM_CLUBB', um, pcols, lchnk ) - call outfld( 'VM_CLUBB', vm, pcols, lchnk ) - call outfld( 'THETAL', thetal_output, pcols, lchnk ) - call outfld( 'QT', qt_output, pcols, lchnk ) - call outfld( 'SL', sl_output, pcols, lchnk ) + call outfld( 'RELVAR', relvar, pcols, lchnk ) + call outfld( 'RHO_CLUBB', rho, pcols, lchnk ) + call outfld( 'WP2_CLUBB', wp2, pcols, lchnk ) + call outfld( 'UP2_CLUBB', up2, pcols, lchnk ) + call outfld( 'VP2_CLUBB', vp2, pcols, lchnk ) + call outfld( 'WP3_CLUBB', wp3_output, pcols, lchnk ) + call outfld( 'UPWP_CLUBB', upwp, pcols, lchnk ) + call outfld( 'VPWP_CLUBB', vpwp, pcols, lchnk ) + call outfld( 'WPTHLP_CLUBB', wpthlp_output, pcols, lchnk ) + call outfld( 'WPRTP_CLUBB', wprtp_output, pcols, lchnk ) + call outfld( 'RTP2_CLUBB', rtp2*1000._r8, pcols, lchnk ) + call outfld( 'THLP2_CLUBB', thlp2, pcols, lchnk ) + call outfld( 'RTPTHLP_CLUBB', rtpthlp_output*1000._r8, pcols, lchnk ) + call outfld( 'RCM_CLUBB', rcm*1000._r8, pcols, lchnk ) + call outfld( 'WPRCP_CLUBB', wprcp*latvap, pcols, lchnk ) + call outfld( 'CLOUDFRAC_CLUBB', alst, pcols, lchnk ) + call outfld( 'RCMINLAYER_CLUBB', rcm_in_layer*1000._r8, pcols, lchnk ) + call outfld( 'CLOUDCOVER_CLUBB', cloud_frac, pcols, lchnk ) + call outfld( 'WPTHVP_CLUBB', wpthvp*cpair, pcols, lchnk ) + call outfld( 'ZT_CLUBB', 1._r8*zt_out, pcols, lchnk ) + call outfld( 'ZM_CLUBB', 1._r8*zi_out, pcols, lchnk ) + call outfld( 'UM_CLUBB', um, pcols, lchnk ) + call outfld( 'VM_CLUBB', vm, pcols, lchnk ) + call outfld( 'THETAL', thetal_output, pcols, lchnk ) + call outfld( 'QT', qt_output, pcols, lchnk ) + call outfld( 'SL', sl_output, pcols, lchnk ) + call outfld( 'CONCLD', concld, pcols, lchnk ) ! Output CLUBB history here if (l_stats) then - do i=1,zt%nn + do i=1,stats_zt%num_output_fields - temp1 = trim(zt%f%var(i)%name) - sub = temp1 - if (len(temp1) .gt. 16) sub = temp1(1:16) - - call outfld(trim(sub), out_zt(:,:,i), pcols, lchnk ) - enddo + temp1 = trim(stats_zt%file%var(i)%name) + sub = temp1 + if (len(temp1) .gt. 16) sub = temp1(1:16) - do i=1,zm%nn + call outfld(trim(sub), out_zt(:,:,i), pcols, lchnk ) + enddo - temp1 = trim(zm%f%var(i)%name) - sub = temp1 - if (len(temp1) .gt. 16) sub = temp1(1:16) + do i=1,stats_zm%num_output_fields - call outfld(trim(sub),out_zm(:,:,i), pcols, lchnk) - enddo + temp1 = trim(stats_zm%file%var(i)%name) + sub = temp1 + if (len(temp1) .gt. 16) sub = temp1(1:16) + + call outfld(trim(sub),out_zm(:,:,i), pcols, lchnk) + enddo - if (l_output_rad_files) then - do i=1,rad_zt%nn - call outfld(trim(rad_zt%f%var(i)%name), out_radzt(:,:,i), pcols, lchnk) - enddo + if (l_output_rad_files) then + do i=1,stats_rad_zt%num_output_fields + call outfld(trim(stats_rad_zt%file%var(i)%name), out_radzt(:,:,i), pcols, lchnk) + enddo - do i=1,rad_zm%nn - call outfld(trim(rad_zm%f%var(i)%name), out_radzm(:,:,i), pcols, lchnk) - enddo - endif + do i=1,stats_rad_zm%num_output_fields + call outfld(trim(stats_rad_zm%file%var(i)%name), out_radzm(:,:,i), pcols, lchnk) + enddo + endif - do i=1,sfc%nn - call outfld(trim(sfc%f%var(i)%name), out_sfc(:,:,i), pcols, lchnk) - enddo + do i=1,stats_sfc%num_output_fields + call outfld(trim(stats_sfc%file%var(i)%name), out_sfc(:,:,i), pcols, lchnk) + enddo endif @@ -1736,8 +2407,7 @@ end subroutine clubb_tend_cam ! ! ! =============================================================================== ! - subroutine clubb_surface ( & - state, ptend, ztodt, cam_in, ustar, obklen) + subroutine clubb_surface (state, ptend, ztodt, cam_in, ustar, obklen) !------------------------------------------------------------------------------- ! Description: Provide the obukov length and the surface friction velocity @@ -1753,10 +2423,10 @@ subroutine clubb_surface ( & ! None !------------------------------------------------------------------------------- - use physics_types, only: physics_state, physics_ptend, physics_ptend_init - use physconst, only: gravit, zvir, latvap - use ppgrid, only: pver, pcols - use constituents, only: pcnst, cnst_get_ind + use physics_types, only: physics_state, physics_ptend, physics_ptend_init + use physconst, only: gravit, zvir, latvap + use ppgrid, only: pver, pcols + use constituents, only: pcnst, cnst_get_ind use camsrfexch, only: cam_in_t implicit none @@ -1765,18 +2435,18 @@ subroutine clubb_surface ( & ! Input Auguments ! ! --------------- ! - type(physics_state), intent(in) :: state ! Physics state variables + type(physics_state), intent(in) :: state ! Physics state variables type(cam_in_t), intent(in) :: cam_in - real(r8), intent(in) :: ztodt ! 2 delta-t [ s ] + real(r8), intent(in) :: ztodt ! 2 delta-t [ s ] ! ---------------- ! ! Output Auguments ! ! ---------------- ! - type(physics_ptend), intent(out) :: ptend ! Individual parameterization tendencies - real(r8), intent(out) :: obklen(pcols) ! Obukhov length [ m ] - real(r8), intent(out) :: ustar(pcols) ! Surface friction velocity [ m/s ] + type(physics_ptend), intent(out) :: ptend ! Individual parameterization tendencies + real(r8), intent(out) :: obklen(pcols) ! Obukhov length [ m ] + real(r8), intent(out) :: ustar(pcols) ! Surface friction velocity [ m/s ] #ifdef CLUBB_SGS @@ -1784,19 +2454,19 @@ subroutine clubb_surface ( & ! Local Variables ! ! --------------- ! - integer :: i ! indicees - integer :: ncol ! # of atmospheric columns + integer :: i ! indicees + integer :: ncol ! # of atmospheric columns real(r8) :: th(pcols) ! surface potential temperature real(r8) :: thv(pcols) ! surface virtual potential temperature - real(r8) :: kinheat ! kinematic surface heat flux - real(r8) :: kinwat ! kinematic surface vapor flux - real(r8) :: kbfs ! kinematic surface buoyancy flux + real(r8) :: kinheat ! kinematic surface heat flux + real(r8) :: kinwat ! kinematic surface vapor flux + real(r8) :: kbfs ! kinematic surface buoyancy flux real(r8) :: tmp1(pcols) real(r8) :: rztodt ! 1./ztodt integer :: m integer :: ixq - real(r8) :: rrho ! Inverse air density + real(r8) :: rrho ! Inverse air density logical :: lq(pcnst) @@ -1820,20 +2490,21 @@ subroutine clubb_surface ( & ! Compute the surface friction velocity and obukov length do i = 1, ncol - th(i) = state%t(i,pver)*state%exner(i,pver) ! diagnose potential temperature - thv(i) = th(i)*(1._r8+zvir*state%q(i,pver,ixq)) ! diagnose virtual potential temperature + th(i) = state%t(i,pver)*state%exner(i,pver) ! diagnose potential temperature + thv(i) = th(i)*(1._r8+zvir*state%q(i,pver,ixq)) ! diagnose virtual potential temperature enddo do i = 1, ncol - call calc_ustar( state%t(i,pver), state%pmid(i,pver), cam_in%wsx(i), cam_in%wsy(i), & - rrho, ustar(i) ) - call calc_obklen( th(i), thv(i), cam_in%lhf(i)/latvap, cam_in%shf(i), rrho, ustar(i), & - kinheat, kinwat, kbfs, obklen(i) ) + call calc_ustar( state%t(i,pver), state%pmid(i,pver), cam_in%wsx(i), cam_in%wsy(i), & + rrho, ustar(i) ) + call calc_obklen( th(i), thv(i), cam_in%lhf(i)/latvap, cam_in%shf(i), rrho, ustar(i), & + kinheat, kinwat, kbfs, obklen(i) ) enddo - rztodt = 1._r8/ztodt + rztodt = 1._r8/ztodt ptend%q(:ncol,:pver,:) = state%q(:ncol,:pver,:) - tmp1(:ncol) = ztodt * gravit * state%rpdel(:ncol,pver) + tmp1(:ncol) = ztodt * gravit * state%rpdel(:ncol,pver) + do m = 2, pcnst ptend%q(:ncol,pver,m) = ptend%q(:ncol,pver,m) + tmp1(:ncol) * cam_in%cflx(:ncol,m) enddo @@ -1897,22 +2568,22 @@ real(r8) function diag_ustar( z, bflx, wnd, z0 ) ustar = wnd*klnz if (abs(bflx) > 1.e-6_r8) then - do iterate=1,4 - - if (ustar > 1.e-6_r8) then - lmo = -ustar**3 / ( vonk * bflx ) - zeta = z/lmo - if (zeta > 0._r8) then - ustar = vonk*wnd /(lnz + am*zeta) - else - x = sqrt( sqrt( 1.0_r8 - bm*zeta ) ) - psi1 = 2._r8*log( 1.0_r8+x ) + log( 1.0_r8+x*x ) - 2._r8*atan( x ) + c1 - ustar = wnd*vonk/(lnz - psi1) - end if + do iterate=1,4 + + if (ustar > 1.e-6_r8) then + lmo = -ustar**3 / ( vonk * bflx ) + zeta = z/lmo + if (zeta > 0._r8) then + ustar = vonk*wnd /(lnz + am*zeta) + else + x = sqrt( sqrt( 1.0_r8 - bm*zeta ) ) + psi1 = 2._r8*log( 1.0_r8+x ) + log( 1.0_r8+x*x ) - 2._r8*atan( x ) + c1 + ustar = wnd*vonk/(lnz - psi1) + end if - endif + endif - end do + end do end if @@ -1929,7 +2600,7 @@ end function diag_ustar ! =============================================================================== ! #ifdef CLUBB_SGS - + subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & nnzp, nnrad_zt,nnrad_zm, delt ) ! @@ -1942,7 +2613,7 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & use stats_variables, only: & - zt, & ! Variables + stats_zt, & ! Variables ztscr01, & ztscr02, & ztscr03, & @@ -1966,7 +2637,7 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & ztscr21 use stats_variables, only: & - zm, & + stats_zm, & zmscr01, & zmscr02, & zmscr03, & @@ -1984,9 +2655,9 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & zmscr15, & zmscr16, & zmscr17, & - rad_zt, & - rad_zm, & - sfc, & + stats_rad_zt, & + stats_rad_zm, & + stats_sfc, & l_stats, & l_output_rad_files, & stats_tsamp, & @@ -1999,18 +2670,18 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & l_netcdf, & l_grads - use clubb_precision, only: time_precision ! - use stats_zm, only: nvarmax_zm, stats_init_zm ! - use stats_zt, only: nvarmax_zt, stats_init_zt ! - use stats_rad_zt, only: nvarmax_rad_zt, stats_init_rad_zt ! - use stats_rad_zm, only: nvarmax_rad_zm, stats_init_rad_zm ! - use stats_sfc, only: nvarmax_sfc, stats_init_sfc ! - use error_code, only: clubb_at_least_debug_level ! - use constants_clubb, only: fstderr, var_length ! - use cam_history, only: addfld, phys_decomp - use namelist_utils,only: find_group_name - use units,only: getunit, freeunit - use cam_abortutils,only: endrun + use clubb_precision, only: time_precision ! + use stats_zm_module, only: nvarmax_zm, stats_init_zm ! + use stats_zt_module, only: nvarmax_zt, stats_init_zt ! + use stats_rad_zt_module, only: nvarmax_rad_zt, stats_init_rad_zt ! + use stats_rad_zm_module, only: nvarmax_rad_zm, stats_init_rad_zm ! + use stats_sfc_module, only: nvarmax_sfc, stats_init_sfc ! + use error_code, only: clubb_at_least_debug_level ! + use constants_clubb, only: fstderr, var_length ! + use cam_history, only: addfld, phys_decomp + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use cam_abortutils, only: endrun implicit none @@ -2026,28 +2697,18 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & integer, intent(in) :: nnrad_zt ! Grid points in the radiation grid [count] integer, intent(in) :: nnrad_zm ! Grid points in the radiation grid [count] - real(kind=time_precision), intent(in) :: & - delt ! Timestep (dtmain in CLUBB) [s] + real(kind=time_precision), intent(in) :: delt ! Timestep (dtmain in CLUBB) [s] ! Local Variables ! Namelist Variables - character(len=var_length), dimension(nvarmax_zt) :: & - clubb_vars_zt ! Variables on the thermodynamic levels - - character(len=var_length), dimension(nvarmax_zm) :: & - clubb_vars_zm ! Variables on the momentum levels - - character(len=var_length), dimension(nvarmax_rad_zt) :: & - clubb_vars_rad_zt ! Variables on the radiation levels - - character(len=var_length), dimension(nvarmax_rad_zm) :: & - clubb_vars_rad_zm ! Variables on the radiation levels - - character(len=var_length), dimension(nvarmax_sfc) :: & - clubb_vars_sfc ! Variables at the model surface + character(len=var_length), dimension(nvarmax_zt) :: clubb_vars_zt ! Variables on the thermodynamic levels + character(len=var_length), dimension(nvarmax_zm) :: clubb_vars_zm ! Variables on the momentum levels + character(len=var_length), dimension(nvarmax_rad_zt) :: clubb_vars_rad_zt ! Variables on the radiation levels + character(len=var_length), dimension(nvarmax_rad_zm) :: clubb_vars_rad_zm ! Variables on the radiation levels + character(len=var_length), dimension(nvarmax_sfc) :: clubb_vars_sfc ! Variables at the model surface namelist /clubb_stats_nl/ & clubb_vars_zt, & @@ -2075,9 +2736,9 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & stats_tout = stats_tout_in if ( .not. l_stats ) then - l_stats_samp = .false. - l_stats_last = .false. - return + l_stats_samp = .false. + l_stats_last = .false. + return end if ! Initialize namelist variables @@ -2090,26 +2751,26 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & ! Read variables to compute from the namelist if (masterproc) then - iunit= getunit() - open(unit=iunit,file="atm_in",status='old') - call find_group_name(iunit, 'clubb_stats_nl', status=read_status) - if (read_status == 0) then - read(unit=iunit, nml=clubb_stats_nl, iostat=read_status) - if (read_status /= 0) then - call endrun('clubb_tend_cam: error reading namelist') - end if - end if - close(unit=iunit) - call freeunit(iunit) + iunit= getunit() + open(unit=iunit,file="atm_in",status='old') + call find_group_name(iunit, 'clubb_stats_nl', status=read_status) + if (read_status == 0) then + read(unit=iunit, nml=clubb_stats_nl, iostat=read_status) + if (read_status /= 0) then + call endrun('stats_init_clubb: error reading namelist') + end if + end if + close(unit=iunit) + call freeunit(iunit) end if #ifdef SPMD - ! Broadcast namelist variables - call mpibcast(clubb_vars_zt, var_length*nvarmax_zt, mpichar, 0, mpicom) - call mpibcast(clubb_vars_zm, var_length*nvarmax_zm, mpichar, 0, mpicom) - call mpibcast(clubb_vars_rad_zt, var_length*nvarmax_rad_zt, mpichar, 0, mpicom) - call mpibcast(clubb_vars_rad_zm, var_length*nvarmax_rad_zm, mpichar, 0, mpicom) - call mpibcast(clubb_vars_sfc, var_length*nvarmax_sfc, mpichar, 0, mpicom) + ! Broadcast namelist variables + call mpibcast(clubb_vars_zt, var_length*nvarmax_zt, mpichar, 0, mpicom) + call mpibcast(clubb_vars_zm, var_length*nvarmax_zm, mpichar, 0, mpicom) + call mpibcast(clubb_vars_rad_zt, var_length*nvarmax_rad_zt, mpichar, 0, mpicom) + call mpibcast(clubb_vars_rad_zm, var_length*nvarmax_rad_zm, mpichar, 0, mpicom) + call mpibcast(clubb_vars_sfc, var_length*nvarmax_sfc, mpichar, 0, mpicom) #endif ! Hardcode these for use in CAM-CLUBB, don't want either @@ -2120,70 +2781,70 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & ! The model time step length, delt (which is dtmain), should multiply ! evenly into the statistical sampling time step length, stats_tsamp. - if ( abs( stats_tsamp/delt - floor(stats_tsamp/delt) ) & - > 1.e-8_r8 ) then - l_error = .true. ! This will cause the run to stop. - write(fstderr,*) 'Error: stats_tsamp should be an even multiple of ', & - 'delt (which is dtmain). Check the appropriate ', & - 'model.in file.' - write(fstderr,*) 'stats_tsamp = ', stats_tsamp - write(fstderr,*) 'delt = ', delt + if ( abs( stats_tsamp/delt - floor(stats_tsamp/delt) ) > 1.e-8_r8 ) then + l_error = .true. ! This will cause the run to stop. + write(fstderr,*) 'Error: stats_tsamp should be an even multiple of ', & + 'delt (which is dtmain). Check the appropriate ', & + 'model.in file.' + write(fstderr,*) 'stats_tsamp = ', stats_tsamp + write(fstderr,*) 'delt = ', delt endif ! Initialize zt (mass points) i = 1 - do while ( ichar(clubb_vars_zt(i)(1:1)) /= 0 & - .and. len_trim(clubb_vars_zt(i)) /= 0 & - .and. i <= nvarmax_zt ) + do while ( ichar(clubb_vars_zt(i)(1:1)) /= 0 .and. & + len_trim(clubb_vars_zt(i)) /= 0 .and. & + i <= nvarmax_zt ) i = i + 1 enddo ntot = i - 1 if ( ntot == nvarmax_zt ) then - write(fstderr,*) "There are more statistical variables listed in ", & - "clubb_vars_zt than allowed for by nvarmax_zt." - write(fstderr,*) "Check the number of variables listed for clubb_vars_zt ", & - "in the stats namelist, or change nvarmax_zt." - write(fstderr,*) "nvarmax_zt = ", nvarmax_zt - stop "stats_init_clubb: number of zt statistical variables exceeds limit" + write(fstderr,*) "There are more statistical variables listed in ", & + "clubb_vars_zt than allowed for by nvarmax_zt." + write(fstderr,*) "Check the number of variables listed for clubb_vars_zt ", & + "in the stats namelist, or change nvarmax_zt." + write(fstderr,*) "nvarmax_zt = ", nvarmax_zt + call endrun ("stats_init_clubb: number of zt statistical variables exceeds limit") endif - zt%nn = ntot - zt%kk = nnzp + stats_zt%num_output_fields = ntot + stats_zt%kk = nnzp - allocate( zt%z( zt%kk ) ) + allocate( stats_zt%z( stats_zt%kk ) ) - allocate( zt%x( 1, 1, zt%kk, zt%nn ) ) - allocate( zt%n( 1, 1, zt%kk, zt%nn ) ) - allocate( zt%l_in_update( 1, 1, zt%kk, zt%nn ) ) - call stats_zero( zt%kk, zt%nn, zt%x, zt%n, zt%l_in_update ) + allocate( stats_zt%accum_field_values( 1, 1, stats_zt%kk, stats_zt%num_output_fields ) ) + allocate( stats_zt%accum_num_samples( 1, 1, stats_zt%kk, stats_zt%num_output_fields ) ) + allocate( stats_zt%l_in_update( 1, 1, stats_zt%kk, stats_zt%num_output_fields ) ) + call stats_zero( stats_zt%kk, stats_zt%num_output_fields, stats_zt%accum_field_values, & + stats_zt%accum_num_samples, stats_zt%l_in_update ) - allocate( zt%f%var( zt%nn ) ) - allocate( zt%f%z( zt%kk ) ) + allocate( stats_zt%file%var( stats_zt%num_output_fields ) ) + allocate( stats_zt%file%z( stats_zt%kk ) ) ! Allocate scratch space - allocate( ztscr01(zt%kk) ) - allocate( ztscr02(zt%kk) ) - allocate( ztscr03(zt%kk) ) - allocate( ztscr04(zt%kk) ) - allocate( ztscr05(zt%kk) ) - allocate( ztscr06(zt%kk) ) - allocate( ztscr07(zt%kk) ) - allocate( ztscr08(zt%kk) ) - allocate( ztscr09(zt%kk) ) - allocate( ztscr10(zt%kk) ) - allocate( ztscr11(zt%kk) ) - allocate( ztscr12(zt%kk) ) - allocate( ztscr13(zt%kk) ) - allocate( ztscr14(zt%kk) ) - allocate( ztscr15(zt%kk) ) - allocate( ztscr16(zt%kk) ) - allocate( ztscr17(zt%kk) ) - allocate( ztscr18(zt%kk) ) - allocate( ztscr19(zt%kk) ) - allocate( ztscr20(zt%kk) ) - allocate( ztscr21(zt%kk) ) + allocate( ztscr01(stats_zt%kk) ) + allocate( ztscr02(stats_zt%kk) ) + allocate( ztscr03(stats_zt%kk) ) + allocate( ztscr04(stats_zt%kk) ) + allocate( ztscr05(stats_zt%kk) ) + allocate( ztscr06(stats_zt%kk) ) + allocate( ztscr07(stats_zt%kk) ) + allocate( ztscr08(stats_zt%kk) ) + allocate( ztscr09(stats_zt%kk) ) + allocate( ztscr10(stats_zt%kk) ) + allocate( ztscr11(stats_zt%kk) ) + allocate( ztscr12(stats_zt%kk) ) + allocate( ztscr13(stats_zt%kk) ) + allocate( ztscr14(stats_zt%kk) ) + allocate( ztscr15(stats_zt%kk) ) + allocate( ztscr16(stats_zt%kk) ) + allocate( ztscr17(stats_zt%kk) ) + allocate( ztscr18(stats_zt%kk) ) + allocate( ztscr19(stats_zt%kk) ) + allocate( ztscr20(stats_zt%kk) ) + allocate( ztscr21(stats_zt%kk) ) ztscr01 = 0.0_r8 ztscr02 = 0.0_r8 @@ -2214,54 +2875,54 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & ! Initialize zm (momentum points) i = 1 - do while ( ichar(clubb_vars_zm(i)(1:1)) /= 0 & - .and. len_trim(clubb_vars_zm(i)) /= 0 & - .and. i <= nvarmax_zm ) - i = i + 1 + do while ( ichar(clubb_vars_zm(i)(1:1)) /= 0 .and. & + len_trim(clubb_vars_zm(i)) /= 0 .and. & + i <= nvarmax_zm ) + i = i + 1 end do ntot = i - 1 if ( ntot == nvarmax_zm ) then - write(fstderr,*) "There are more statistical variables listed in ", & - "clubb_vars_zm than allowed for by nvarmax_zm." - write(fstderr,*) "Check the number of variables listed for clubb_vars_zm ", & - "in the stats namelist, or change nvarmax_zm." - write(fstderr,*) "nvarmax_zm = ", nvarmax_zm - stop "stats_init_clubb: number of zm statistical variables exceeds limit" + write(fstderr,*) "There are more statistical variables listed in ", & + "clubb_vars_zm than allowed for by nvarmax_zm." + write(fstderr,*) "Check the number of variables listed for clubb_vars_zm ", & + "in the stats namelist, or change nvarmax_zm." + write(fstderr,*) "nvarmax_zm = ", nvarmax_zm + call endrun ("stats_init_clubb: number of zm statistical variables exceeds limit") endif - zm%nn = ntot - zm%kk = nnzp - - allocate( zm%z( zm%kk ) ) + stats_zm%num_output_fields = ntot + stats_zm%kk = nnzp - allocate( zm%x( 1, 1, zm%kk, zm%nn ) ) - allocate( zm%n( 1, 1, zm%kk, zm%nn ) ) - allocate( zm%l_in_update( 1, 1, zm%kk, zm%nn ) ) + allocate( stats_zm%z( stats_zm%kk ) ) - call stats_zero( zm%kk, zm%nn, zm%x, zm%n, zm%l_in_update ) + allocate( stats_zm%accum_field_values( 1, 1, stats_zm%kk, stats_zm%num_output_fields ) ) + allocate( stats_zm%accum_num_samples( 1, 1, stats_zm%kk, stats_zm%num_output_fields ) ) + allocate( stats_zm%l_in_update( 1, 1, stats_zm%kk, stats_zm%num_output_fields ) ) + call stats_zero( stats_zm%kk, stats_zm%num_output_fields, stats_zm%accum_field_values, & + stats_zm%accum_num_samples, stats_zm%l_in_update ) - allocate( zm%f%var( zm%nn ) ) - allocate( zm%f%z( zm%kk ) ) + allocate( stats_zm%file%var( stats_zm%num_output_fields ) ) + allocate( stats_zm%file%z( stats_zm%kk ) ) ! Allocate scratch space - allocate( zmscr01(zm%kk) ) - allocate( zmscr02(zm%kk) ) - allocate( zmscr03(zm%kk) ) - allocate( zmscr04(zm%kk) ) - allocate( zmscr05(zm%kk) ) - allocate( zmscr06(zm%kk) ) - allocate( zmscr07(zm%kk) ) - allocate( zmscr08(zm%kk) ) - allocate( zmscr09(zm%kk) ) - allocate( zmscr10(zm%kk) ) - allocate( zmscr11(zm%kk) ) - allocate( zmscr12(zm%kk) ) - allocate( zmscr13(zm%kk) ) - allocate( zmscr14(zm%kk) ) - allocate( zmscr15(zm%kk) ) - allocate( zmscr16(zm%kk) ) - allocate( zmscr17(zm%kk) ) + allocate( zmscr01(stats_zm%kk) ) + allocate( zmscr02(stats_zm%kk) ) + allocate( zmscr03(stats_zm%kk) ) + allocate( zmscr04(stats_zm%kk) ) + allocate( zmscr05(stats_zm%kk) ) + allocate( zmscr06(stats_zm%kk) ) + allocate( zmscr07(stats_zm%kk) ) + allocate( zmscr08(stats_zm%kk) ) + allocate( zmscr09(stats_zm%kk) ) + allocate( zmscr10(stats_zm%kk) ) + allocate( zmscr11(stats_zm%kk) ) + allocate( zmscr12(stats_zm%kk) ) + allocate( zmscr13(stats_zm%kk) ) + allocate( zmscr14(stats_zm%kk) ) + allocate( zmscr15(stats_zm%kk) ) + allocate( zmscr16(stats_zm%kk) ) + allocate( zmscr17(stats_zm%kk) ) zmscr01 = 0.0_r8 zmscr02 = 0.0_r8 @@ -2287,110 +2948,112 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & if (l_output_rad_files) then - i = 1 - do while ( ichar(clubb_vars_rad_zt(i)(1:1)) /= 0 & - .and. len_trim(clubb_vars_rad_zt(i)) /= 0 & - .and. i <= nvarmax_rad_zt ) - i = i + 1 - end do - ntot = i - 1 - if ( ntot == nvarmax_rad_zt ) then - write(fstderr,*) "There are more statistical variables listed in ", & - "clubb_vars_rad_zt than allowed for by nvarmax_rad_zt." - write(fstderr,*) "Check the number of variables listed for clubb_vars_rad_zt ", & - "in the stats namelist, or change nvarmax_rad_zt." - write(fstderr,*) "nvarmax_rad_zt = ", nvarmax_rad_zt - stop "stats_init_clubb: number of rad_zt statistical variables exceeds limit" - endif - - rad_zt%nn = ntot - rad_zt%kk = nnrad_zt - - allocate( rad_zt%z( rad_zt%kk ) ) - - allocate( rad_zt%x( 1, 1, rad_zt%kk, rad_zt%nn ) ) - allocate( rad_zt%n( 1, 1, rad_zt%kk, rad_zt%nn ) ) - allocate( rad_zt%l_in_update( 1, 1, rad_zt%kk, rad_zt%nn ) ) - - call stats_zero( rad_zt%kk, rad_zt%nn, rad_zt%x, rad_zt%n, rad_zt%l_in_update ) + i = 1 + do while ( ichar(clubb_vars_rad_zt(i)(1:1)) /= 0 .and. & + len_trim(clubb_vars_rad_zt(i)) /= 0 .and. & + i <= nvarmax_rad_zt ) + i = i + 1 + end do + ntot = i - 1 + if ( ntot == nvarmax_rad_zt ) then + write(fstderr,*) "There are more statistical variables listed in ", & + "clubb_vars_rad_zt than allowed for by nvarmax_rad_zt." + write(fstderr,*) "Check the number of variables listed for clubb_vars_rad_zt ", & + "in the stats namelist, or change nvarmax_rad_zt." + write(fstderr,*) "nvarmax_rad_zt = ", nvarmax_rad_zt + call endrun ("stats_init_clubb: number of rad_zt statistical variables exceeds limit") + endif - allocate( rad_zt%f%var( rad_zt%nn ) ) - allocate( rad_zt%f%z( rad_zt%kk ) ) + stats_rad_zt%num_output_fields = ntot + stats_rad_zt%kk = nnrad_zt - fname = trim( fname_rad_zt ) + allocate( stats_rad_zt%z( stats_rad_zt%kk ) ) - call stats_init_rad_zt( clubb_vars_rad_zt, l_error ) + allocate( stats_rad_zt%accum_field_values( 1, 1, stats_rad_zt%kk, stats_rad_zt%num_output_fields ) ) + allocate( stats_rad_zt%accum_num_samples( 1, 1, stats_rad_zt%kk, stats_rad_zt%num_output_fields ) ) + allocate( stats_rad_zt%l_in_update( 1, 1, stats_rad_zt%kk, stats_rad_zt%num_output_fields ) ) - ! Initialize rad_zm (radiation points) + call stats_zero( stats_rad_zt%kk, stats_rad_zt%num_output_fields, stats_rad_zt%accum_field_values, & + stats_rad_zt%accum_num_samples, stats_rad_zt%l_in_update ) - i = 1 - do while ( ichar(clubb_vars_rad_zm(i)(1:1)) /= 0 & - .and. len_trim(clubb_vars_rad_zm(i)) /= 0 & - .and. i <= nvarmax_rad_zm ) - i = i + 1 - end do - ntot = i - 1 - if ( ntot == nvarmax_rad_zm ) then - write(fstderr,*) "There are more statistical variables listed in ", & - "clubb_vars_rad_zm than allowed for by nvarmax_rad_zm." - write(fstderr,*) "Check the number of variables listed for clubb_vars_rad_zm ", & - "in the stats namelist, or change nvarmax_rad_zm." - write(fstderr,*) "nvarmax_rad_zm = ", nvarmax_rad_zm - stop "stats_init_clubb: number of rad_zm statistical variables exceeds limit" - endif + allocate( stats_rad_zt%file%var( stats_rad_zt%num_output_fields ) ) + allocate( stats_rad_zt%file%z( stats_rad_zt%kk ) ) - rad_zm%nn = ntot - rad_zm%kk = nnrad_zm + fname = trim( fname_rad_zt ) - allocate( rad_zm%z( rad_zm%kk ) ) + call stats_init_rad_zt( clubb_vars_rad_zt, l_error ) - allocate( rad_zm%x( 1, 1, rad_zm%kk, rad_zm%nn ) ) - allocate( rad_zm%n( 1, 1, rad_zm%kk, rad_zm%nn ) ) - allocate( rad_zm%l_in_update( 1, 1, rad_zm%kk, rad_zm%nn ) ) + ! Initialize rad_zm (radiation points) + + i = 1 + do while ( ichar(clubb_vars_rad_zm(i)(1:1)) /= 0 .and. & + len_trim(clubb_vars_rad_zm(i)) /= 0 .and. & + i <= nvarmax_rad_zm ) + i = i + 1 + end do + ntot = i - 1 + if ( ntot == nvarmax_rad_zm ) then + write(fstderr,*) "There are more statistical variables listed in ", & + "clubb_vars_rad_zm than allowed for by nvarmax_rad_zm." + write(fstderr,*) "Check the number of variables listed for clubb_vars_rad_zm ", & + "in the stats namelist, or change nvarmax_rad_zm." + write(fstderr,*) "nvarmax_rad_zm = ", nvarmax_rad_zm + call endrun ("stats_init_clubb: number of rad_zm statistical variables exceeds limit") + endif - call stats_zero( rad_zm%kk, rad_zm%nn, rad_zm%x, rad_zm%n, rad_zm%l_in_update ) + stats_rad_zm%num_output_fields = ntot + stats_rad_zm%kk = nnrad_zm - allocate( rad_zm%f%var( rad_zm%nn ) ) - allocate( rad_zm%f%z( rad_zm%kk ) ) + allocate( stats_rad_zm%z( stats_rad_zm%kk ) ) + allocate( stats_rad_zm%accum_field_values( 1, 1, stats_rad_zm%kk, stats_rad_zm%num_output_fields ) ) + allocate( stats_rad_zm%accum_num_samples( 1, 1, stats_rad_zm%kk, stats_rad_zm%num_output_fields ) ) + allocate( stats_rad_zm%l_in_update( 1, 1, stats_rad_zm%kk, stats_rad_zm%num_output_fields ) ) - fname = trim( fname_rad_zm ) + call stats_zero( stats_rad_zm%kk, stats_rad_zm%num_output_fields, stats_rad_zm%accum_field_values, & + stats_rad_zm%accum_num_samples, stats_rad_zm%l_in_update ) - call stats_init_rad_zm( clubb_vars_rad_zm, l_error ) + allocate( stats_rad_zm%file%var( stats_rad_zm%num_output_fields ) ) + allocate( stats_rad_zm%file%z( stats_rad_zm%kk ) ) + + fname = trim( fname_rad_zm ) + + call stats_init_rad_zm( clubb_vars_rad_zm, l_error ) end if ! l_output_rad_files ! Initialize sfc (surface point) i = 1 - do while ( ichar(clubb_vars_sfc(i)(1:1)) /= 0 & - .and. len_trim(clubb_vars_sfc(i)) /= 0 & - .and. i <= nvarmax_sfc ) - i = i + 1 + do while ( ichar(clubb_vars_sfc(i)(1:1)) /= 0 .and. & + len_trim(clubb_vars_sfc(i)) /= 0 .and. & + i <= nvarmax_sfc ) + i = i + 1 end do ntot = i - 1 if ( ntot == nvarmax_sfc ) then - write(fstderr,*) "There are more statistical variables listed in ", & - "clubb_vars_sfc than allowed for by nvarmax_sfc." - write(fstderr,*) "Check the number of variables listed for clubb_vars_sfc ", & - "in the stats namelist, or change nvarmax_sfc." - write(fstderr,*) "nvarmax_sfc = ", nvarmax_sfc - stop "stats_init_clubb: number of sfc statistical variables exceeds limit" + write(fstderr,*) "There are more statistical variables listed in ", & + "clubb_vars_sfc than allowed for by nvarmax_sfc." + write(fstderr,*) "Check the number of variables listed for clubb_vars_sfc ", & + "in the stats namelist, or change nvarmax_sfc." + write(fstderr,*) "nvarmax_sfc = ", nvarmax_sfc + call endrun ("stats_init_clubb: number of sfc statistical variables exceeds limit") endif - sfc%nn = ntot - sfc%kk = 1 + stats_sfc%num_output_fields = ntot + stats_sfc%kk = 1 - allocate( sfc%z( sfc%kk ) ) + allocate( stats_sfc%z( stats_sfc%kk ) ) - allocate( sfc%x( 1, 1, sfc%kk, sfc%nn ) ) - allocate( sfc%n( 1, 1, sfc%kk, sfc%nn ) ) - allocate( sfc%l_in_update( 1, 1, sfc%kk, sfc%nn ) ) + allocate( stats_sfc%accum_field_values( 1, 1, stats_sfc%kk, stats_sfc%num_output_fields ) ) + allocate( stats_sfc%accum_num_samples( 1, 1, stats_sfc%kk, stats_sfc%num_output_fields ) ) + allocate( stats_sfc%l_in_update( 1, 1, stats_sfc%kk, stats_sfc%num_output_fields ) ) - call stats_zero( sfc%kk, sfc%nn, sfc%x, sfc%n, sfc%l_in_update ) + call stats_zero( stats_sfc%kk, stats_sfc%num_output_fields, stats_sfc%accum_field_values, & + stats_sfc%accum_num_samples, stats_sfc%l_in_update ) - allocate( sfc%f%var( sfc%nn ) ) - allocate( sfc%f%z( sfc%kk ) ) + allocate( stats_sfc%file%var( stats_sfc%num_output_fields ) ) + allocate( stats_sfc%file%z( stats_sfc%kk ) ) fname = trim( fname_sfc ) @@ -2399,46 +3062,45 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & ! Check for errors if ( l_error ) then - write(fstderr,*) 'stats_init: errors found' - stop + call endrun ('stats_init: errors found') endif ! Now call add fields - do i = 1, zt%nn + do i = 1, stats_zt%num_output_fields - temp1 = trim(zt%f%var(i)%name) + temp1 = trim(stats_zt%file%var(i)%name) sub = temp1 if (len(temp1) .gt. 16) sub = temp1(1:16) - call addfld(trim(sub),trim(zt%f%var(i)%units),nnzp,& - 'A',trim(zt%f%var(i)%description),phys_decomp) + call addfld(trim(sub),trim(stats_zt%file%var(i)%units),nnzp,& + 'A',trim(stats_zt%file%var(i)%description),phys_decomp) enddo - do i = 1, zm%nn + do i = 1, stats_zm%num_output_fields - temp1 = trim(zm%f%var(i)%name) + temp1 = trim(stats_zm%file%var(i)%name) sub = temp1 if (len(temp1) .gt. 16) sub = temp1(1:16) - call addfld(trim(sub),trim(zm%f%var(i)%units),nnzp,& - 'A',trim(zm%f%var(i)%description),phys_decomp) + call addfld(trim(sub),trim(stats_zm%file%var(i)%units),nnzp,& + 'A',trim(stats_zm%file%var(i)%description),phys_decomp) enddo if (l_output_rad_files) then - do i = 1, rad_zt%nn - call addfld(trim(rad_zt%f%var(i)%name),trim(rad_zt%f%var(i)%units),nnzp,& - 'A',trim(rad_zt%f%var(i)%description),phys_decomp) + do i = 1, stats_rad_zt%num_output_fields + call addfld(trim(stats_rad_zt%file%var(i)%name),trim(stats_rad_zt%file%var(i)%units),nnzp,& + 'A',trim(stats_rad_zt%file%var(i)%description),phys_decomp) enddo - do i = 1, rad_zm%nn - call addfld(trim(rad_zm%f%var(i)%name),trim(rad_zm%f%var(i)%units),nnzp,& - 'A',trim(rad_zm%f%var(i)%description),phys_decomp) + do i = 1, stats_rad_zm%num_output_fields + call addfld(trim(stats_rad_zm%file%var(i)%name),trim(stats_rad_zm%file%var(i)%units),nnzp,& + 'A',trim(stats_rad_zm%file%var(i)%description),phys_decomp) enddo endif - do i = 1, sfc%nn - call addfld(trim(sfc%f%var(i)%name),trim(sfc%f%var(i)%units),1,& - 'A',trim(sfc%f%var(i)%description),phys_decomp) + do i = 1, stats_sfc%num_output_fields + call addfld(trim(stats_sfc%file%var(i)%name),trim(stats_sfc%file%var(i)%units),1,& + 'A',trim(stats_sfc%file%var(i)%description),phys_decomp) enddo return @@ -2467,11 +3129,11 @@ subroutine stats_end_timestep_clubb(lchnk,thecol,out_zt,out_zm,out_radzt,out_rad fstderr ! Constant(s) use stats_variables, only: & - zt, & ! Variable(s) - zm, & - rad_zt, & - rad_zm, & - sfc, & + stats_zt, & ! Variable(s) + stats_zm, & + stats_rad_zt, & + stats_rad_zm, & + stats_sfc, & l_stats_last, & stats_tsamp, & stats_tout, & @@ -2479,10 +3141,12 @@ subroutine stats_end_timestep_clubb(lchnk,thecol,out_zt,out_zm,out_radzt,out_rad use error_code, only: & clubb_at_least_debug_level ! Procedure(s) - - use cam_history, only: outfld + + use cam_history, only: outfld - use ppgrid, only: pcols, pverp + use ppgrid, only: pcols, pverp + + use cam_abortutils, only: endrun implicit none @@ -2513,19 +3177,19 @@ subroutine stats_end_timestep_clubb(lchnk,thecol,out_zt,out_zm,out_radzt,out_rad ! Look for errors by checking the number of sampling points ! for each variable in the zt statistics at each vertical level. - do i = 1, zt%nn - do k = 1, zt%kk + do i = 1, stats_zt%num_output_fields + do k = 1, stats_zt%kk - if ( zt%n(1,1,k,i) /= 0 .and. & - zt%n(1,1,k,i) /= floor(stats_tout/stats_tsamp) ) then + if ( stats_zt%accum_num_samples(1,1,k,i) /= 0 .and. & + stats_zt%accum_num_samples(1,1,k,i) /= floor(stats_tout/stats_tsamp) ) then l_error = .true. ! This will stop the run if ( clubb_at_least_debug_level( 1 ) ) then write(fstderr,*) 'Possible sampling error for variable ', & - trim(zt%f%var(i)%name), ' in zt ', & + trim(stats_zt%file%var(i)%name), ' in zt ', & 'at k = ', k, & - '; zt%n(',k,',',i,') = ', zt%n(1,1,k,i) + '; stats_zt%accum_num_samples(',k,',',i,') = ', stats_zt%accum_num_samples(1,1,k,i) endif endif @@ -2535,19 +3199,19 @@ subroutine stats_end_timestep_clubb(lchnk,thecol,out_zt,out_zm,out_radzt,out_rad ! Look for errors by checking the number of sampling points ! for each variable in the zm statistics at each vertical level. - do i = 1, zm%nn - do k = 1, zm%kk + do i = 1, stats_zm%num_output_fields + do k = 1, stats_zm%kk - if ( zm%n(1,1,k,i) /= 0 .and. & - zm%n(1,1,k,i) /= floor(stats_tout/stats_tsamp) ) then + if ( stats_zm%accum_num_samples(1,1,k,i) /= 0 .and. & + stats_zm%accum_num_samples(1,1,k,i) /= floor(stats_tout/stats_tsamp) ) then l_error = .true. ! This will stop the run if ( clubb_at_least_debug_level( 1 ) ) then write(fstderr,*) 'Possible sampling error for variable ', & - trim(zm%f%var(i)%name), ' in zm ', & + trim(stats_zm%file%var(i)%name), ' in zm ', & 'at k = ', k, & - '; zm%n(',k,',',i,') = ', zm%n(1,1,k,i) + '; stats_zm%accum_num_samples(',k,',',i,') = ', stats_zm%accum_num_samples(1,1,k,i) endif endif @@ -2558,19 +3222,19 @@ subroutine stats_end_timestep_clubb(lchnk,thecol,out_zt,out_zm,out_radzt,out_rad if (l_output_rad_files) then ! Look for errors by checking the number of sampling points ! for each variable in the rad_zt statistics at each vertical level. - do i = 1, rad_zt%nn - do k = 1, rad_zt%kk + do i = 1, stats_rad_zt%num_output_fields + do k = 1, stats_rad_zt%kk - if ( rad_zt%n(1,1,k,i) /= 0 .and. & - rad_zt%n(1,1,k,i) /= floor(stats_tout/stats_tsamp) ) then + if ( stats_rad_zt%accum_num_samples(1,1,k,i) /= 0 .and. & + stats_rad_zt%accum_num_samples(1,1,k,i) /= floor(stats_tout/stats_tsamp) ) then l_error = .true. ! This will stop the run if ( clubb_at_least_debug_level( 1 ) ) then write(fstderr,*) 'Possible sampling error for variable ', & - trim(rad_zt%f%var(i)%name), ' in rad_zt ', & + trim(stats_rad_zt%file%var(i)%name), ' in rad_zt ', & 'at k = ', k, & - '; rad_zt%n(',k,',',i,') = ', rad_zt%n(1,1,k,i) + '; stats_rad_zt%accum_num_samples(',k,',',i,') = ', stats_rad_zt%accum_num_samples(1,1,k,i) endif endif @@ -2580,42 +3244,42 @@ subroutine stats_end_timestep_clubb(lchnk,thecol,out_zt,out_zm,out_radzt,out_rad ! Look for errors by checking the number of sampling points ! for each variable in the rad_zm statistics at each vertical level. - do i = 1, rad_zm%nn - do k = 1, rad_zm%kk + do i = 1, stats_rad_zm%num_output_fields + do k = 1, stats_rad_zm%kk - if ( rad_zm%n(1,1,k,i) /= 0 .and. & - rad_zm%n(1,1,k,i) /= floor(stats_tout/stats_tsamp) ) then + if ( stats_rad_zm%accum_num_samples(1,1,k,i) /= 0 .and. & + stats_rad_zm%accum_num_samples(1,1,k,i) /= floor(stats_tout/stats_tsamp) ) then l_error = .true. ! This will stop the run if ( clubb_at_least_debug_level( 1 ) ) then write(fstderr,*) 'Possible sampling error for variable ', & - trim(rad_zm%f%var(i)%name), ' in rad_zm ', & + trim(stats_rad_zm%file%var(i)%name), ' in rad_zm ', & 'at k = ', k, & - '; rad_zm%n(',k,',',i,') = ', rad_zm%n(1,1,k,i) + '; stats_rad_zm%accum_num_samples(',k,',',i,') = ', stats_rad_zm%accum_num_samples(1,1,k,i) endif endif enddo enddo - end if ! l_output_rad_files + end if ! l_output_rad_files ! Look for errors by checking the number of sampling points ! for each variable in the sfc statistics at each vertical level. - do i = 1, sfc%nn - do k = 1, sfc%kk + do i = 1, stats_sfc%num_output_fields + do k = 1, stats_sfc%kk - if ( sfc%n(1,1,k,i) /= 0 .and. & - sfc%n(1,1,k,i) /= floor(stats_tout/stats_tsamp) ) then + if ( stats_sfc%accum_num_samples(1,1,k,i) /= 0 .and. & + stats_sfc%accum_num_samples(1,1,k,i) /= floor(stats_tout/stats_tsamp) ) then l_error = .true. ! This will stop the run if ( clubb_at_least_debug_level( 1 ) ) then write(fstderr,*) 'Possible sampling error for variable ', & - trim(sfc%f%var(i)%name), ' in sfc ', & + trim(stats_sfc%file%var(i)%name), ' in sfc ', & 'at k = ', k, & - '; sfc%n(',k,',',i,') = ', sfc%n(1,1,k,i) + '; stats_sfc%accum_num_samples(',k,',',i,') = ', stats_sfc%accum_num_samples(1,1,k,i) endif endif @@ -2625,68 +3289,74 @@ subroutine stats_end_timestep_clubb(lchnk,thecol,out_zt,out_zm,out_radzt,out_rad ! Stop the run if errors are found. if ( l_error ) then - write(fstderr,*) 'Possible statistical sampling error' - write(fstderr,*) 'For details, set debug_level to a value of at ', & - 'least 1 in the appropriate model.in file.' - stop 'stats_end_timestep: error(s) found' + write(fstderr,*) 'Possible statistical sampling error' + write(fstderr,*) 'For details, set debug_level to a value of at ', & + 'least 1 in the appropriate model.in file.' + call endrun ('stats_end_timestep: error(s) found') endif ! Compute averages - call stats_avg( zt%kk, zt%nn, zt%x, zt%n ) - call stats_avg( zm%kk, zm%nn, zm%x, zm%n ) + call stats_avg( stats_zt%kk, stats_zt%num_output_fields, stats_zt%accum_field_values, stats_zt%accum_num_samples ) + call stats_avg( stats_zm%kk, stats_zm%num_output_fields, stats_zm%accum_field_values, stats_zm%accum_num_samples ) if (l_output_rad_files) then - call stats_avg( rad_zt%kk, rad_zt%nn, rad_zt%x, rad_zt%n ) - call stats_avg( rad_zm%kk, rad_zm%nn, rad_zm%x, rad_zm%n ) + call stats_avg( stats_rad_zt%kk, stats_rad_zt%num_output_fields, stats_rad_zt%accum_field_values, & + stats_rad_zt%accum_num_samples ) + call stats_avg( stats_rad_zm%kk, stats_rad_zm%num_output_fields, stats_rad_zm%accum_field_values, & + stats_rad_zm%accum_num_samples ) end if - call stats_avg( sfc%kk, sfc%nn, sfc%x, sfc%n ) + call stats_avg( stats_sfc%kk, stats_sfc%num_output_fields, stats_sfc%accum_field_values, stats_sfc%accum_num_samples ) ! Here we are not outputting the data, rather reading the stats into ! arrays which are conformable to CAM output. Also, the data is "flipped" ! in the vertical level to be the same as CAM output. - do i = 1, zt%nn - do k = 1, zt%kk - out_zt(thecol,k,i) = zt%x(1,1,zt%kk-k+1,i) - if(out_zt(thecol,k,i) .ne. out_zt(thecol,k,i)) out_zt(thecol,k,i) = 0.0_r8 + do i = 1, stats_zt%num_output_fields + do k = 1, stats_zt%kk + out_zt(thecol,k,i) = stats_zt%accum_field_values(1,1,stats_zt%kk-k+1,i) + if(out_zt(thecol,k,i) .ne. out_zt(thecol,k,i)) out_zt(thecol,k,i) = 0.0_r8 enddo enddo - do i = 1, zm%nn - do k = 1, zt%kk - out_zm(thecol,k,i) = zm%x(1,1,zt%kk-k+1,i) - if(out_zm(thecol,k,i) .ne. out_zm(thecol,k,i)) out_zm(thecol,k,i) = 0.0_r8 + do i = 1, stats_zm%num_output_fields + do k = 1, stats_zt%kk + out_zm(thecol,k,i) = stats_zm%accum_field_values(1,1,stats_zt%kk-k+1,i) + if(out_zm(thecol,k,i) .ne. out_zm(thecol,k,i)) out_zm(thecol,k,i) = 0.0_r8 enddo enddo if (l_output_rad_files) then - do i = 1, rad_zt%nn - do k = 1, rad_zt%kk - out_radzt(thecol,k,i) = rad_zt%x(1,1,zt%kk-k+1,i) - if(out_radzt(thecol,k,i) .ne. out_radzt(thecol,k,i)) out_radzt(thecol,k,i) = 0.0_r8 + do i = 1, stats_rad_zt%num_output_fields + do k = 1, stats_rad_zt%kk + out_radzt(thecol,k,i) = stats_rad_zt%accum_field_values(1,1,stats_zt%kk-k+1,i) + if(out_radzt(thecol,k,i) .ne. out_radzt(thecol,k,i)) out_radzt(thecol,k,i) = 0.0_r8 enddo enddo - do i = 1, rad_zm%nn - do k = 1, rad_zm%kk - out_radzm(thecol,k,i) = rad_zm%x(1,1,zt%kk-k+1,i) - if(out_radzm(thecol,k,i) .ne. out_radzm(thecol,k,i)) out_radzm(thecol,k,i) = 0.0_r8 + do i = 1, stats_rad_zm%num_output_fields + do k = 1, stats_rad_zm%kk + out_radzm(thecol,k,i) = stats_rad_zm%accum_field_values(1,1,stats_zt%kk-k+1,i) + if(out_radzm(thecol,k,i) .ne. out_radzm(thecol,k,i)) out_radzm(thecol,k,i) = 0.0_r8 enddo enddo endif - do i = 1, sfc%nn - out_sfc(thecol,1,i) = sfc%x(1,1,1,i) + do i = 1, stats_sfc%num_output_fields + out_sfc(thecol,1,i) = stats_sfc%accum_field_values(1,1,1,i) if(out_sfc(thecol,1,i) .ne. out_sfc(thecol,1,i)) out_sfc(thecol,1,i) = 0.0_r8 enddo ! Reset sample fields - call stats_zero( zt%kk, zt%nn, zt%x, zt%n, zt%l_in_update ) - call stats_zero( zm%kk, zm%nn, zm%x, zm%n, zm%l_in_update ) + call stats_zero( stats_zt%kk, stats_zt%num_output_fields, stats_zt%accum_field_values, & + stats_zt%accum_num_samples, stats_zt%l_in_update ) + call stats_zero( stats_zm%kk, stats_zm%num_output_fields, stats_zm%accum_field_values, & + stats_zm%accum_num_samples, stats_zm%l_in_update ) if (l_output_rad_files) then - call stats_zero( rad_zt%kk, rad_zt%nn, rad_zt%x, rad_zt%n, rad_zt%l_in_update ) - call stats_zero( rad_zm%kk, rad_zm%nn, rad_zm%x, rad_zm%n, rad_zm%l_in_update ) + call stats_zero( stats_rad_zt%kk, stats_rad_zt%num_output_fields, stats_rad_zt%accum_field_values, & + stats_rad_zt%accum_num_samples, stats_rad_zt%l_in_update ) + call stats_zero( stats_rad_zm%kk, stats_rad_zm%num_output_fields, stats_rad_zm%accum_field_values, & + stats_rad_zm%accum_num_samples, stats_rad_zm%l_in_update ) end if - call stats_zero( sfc%kk, sfc%nn, sfc%x, sfc%n, sfc%l_in_update ) - + call stats_zero( stats_sfc%kk, stats_sfc%num_output_fields, stats_sfc%accum_field_values, & + stats_sfc%accum_num_samples, stats_sfc%l_in_update ) return @@ -2719,16 +3389,16 @@ subroutine stats_zero( kk, nn, x, n, l_in_update ) integer, intent(in) :: kk, nn ! Output - real(kind=stat_rknd), dimension(1,1,kk,nn), intent(out) :: x + real(kind=stat_rknd), dimension(1,1,kk,nn), intent(out) :: x integer(kind=stat_nknd), dimension(1,1,kk,nn), intent(out) :: n - logical, dimension(1,1,kk,nn), intent(out) :: l_in_update + logical, dimension(1,1,kk,nn), intent(out) :: l_in_update ! Zero out arrays if ( nn > 0 ) then - x(:,:,:,:) = 0.0_r8 - n(:,:,:,:) = 0 - l_in_update(:,:,:,:) = .false. + x(:,:,:,:) = 0.0_r8 + n(:,:,:,:) = 0 + l_in_update(:,:,:,:) = .false. end if return @@ -2769,13 +3439,13 @@ subroutine stats_avg( kk, nn, x, n ) ! Compute averages do m=1,nn - do k=1,kk + do k=1,kk - if ( n(1,1,k,m) > 0 ) then - x(1,1,k,m) = x(1,1,k,m) / real( n(1,1,k,m) ) - end if + if ( n(1,1,k,m) > 0 ) then + x(1,1,k,m) = x(1,1,k,m) / real( n(1,1,k,m) ) + end if - end do + end do end do return diff --git a/models/atm/cam/src/physics/cam/convect_deep.F90 b/models/atm/cam/src/physics/cam/convect_deep.F90 index fe67671d14c4..bf72b911af46 100644 --- a/models/atm/cam/src/physics/cam/convect_deep.F90 +++ b/models/atm/cam/src/physics/cam/convect_deep.F90 @@ -131,6 +131,8 @@ subroutine convect_deep_init(pref_edge) select case ( deep_scheme ) case('off') ! ==> no deep convection if (masterproc) write(iulog,*)'convect_deep: no deep convection selected' + case('CLUBB_SGS') + if (masterproc) write(iulog,*)'convect_deep: CLUBB_SGS selected' case('ZM') ! 1 ==> Zhang-McFarlane (default) if (masterproc) write(iulog,*)'convect_deep initializing Zhang-McFarlane convection' call zm_conv_init(pref_edge) @@ -202,18 +204,19 @@ subroutine convect_deep_tend( & real(r8), pointer :: pblh(:) ! Planetary boundary layer height real(r8), pointer :: tpert(:) ! Thermal temperature excess - real(r8) zero(pcols, pver) + ! Temperature tendency from deep convection (pbuf pointer). + real(r8), pointer, dimension(:,:) :: ttend_dp - integer i, k + real(r8) zero(pcols, pver) - real(r8), pointer, dimension(:,:) :: ttend_dp + integer i, k call pbuf_get_field(pbuf, cldtop_idx, jctop ) call pbuf_get_field(pbuf, cldbot_idx, jcbot ) call pbuf_get_field(pbuf, icwmrdp_idx, ql ) select case ( deep_scheme ) - case('off') ! 0 ==> no deep convection + case('off', 'CLUBB_SGS') ! 0 ==> no deep convection zero = 0 mcon = 0 dlf = 0 @@ -274,7 +277,7 @@ end subroutine convect_deep_tend subroutine convect_deep_tend_2( state, ptend, ztodt, pbuf) - use physics_types, only: physics_state, physics_ptend + use physics_types, only: physics_state, physics_ptend, physics_ptend_init use physics_buffer, only: physics_buffer_desc use constituents, only: pcnst @@ -290,6 +293,8 @@ subroutine convect_deep_tend_2( state, ptend, ztodt, pbuf) if ( deep_scheme .eq. 'ZM' ) then ! 1 ==> Zhang-McFarlane (default) call zm_conv_tend_2( state, ptend, ztodt, pbuf) + else + call physics_ptend_init(ptend, state%psetcols, 'convect_deep') end if diff --git a/models/atm/cam/src/physics/cam/convect_shallow.F90 b/models/atm/cam/src/physics/cam/convect_shallow.F90 index 7d735e0691a8..5f4de1c30ac0 100644 --- a/models/atm/cam/src/physics/cam/convect_shallow.F90 +++ b/models/atm/cam/src/physics/cam/convect_shallow.F90 @@ -14,7 +14,7 @@ module convect_shallow use physconst, only : cpair, zvir use ppgrid, only : pver, pcols, pverp use zm_conv, only : zm_conv_evap - use cam_history, only : outfld, addfld, add_default, phys_decomp + use cam_history, only : outfld, addfld, phys_decomp use cam_logfile, only : iulog use phys_control, only : phys_getopts @@ -57,6 +57,7 @@ module convect_shallow integer :: pblh_idx = 0 integer :: prec_sh_idx = 0 integer :: snow_sh_idx = 0 + integer :: cmfmc_sh_idx = 0 integer :: & ! field index in physics buffer sh_flxprc_idx, & @@ -78,8 +79,6 @@ subroutine convect_shallow_register use physics_buffer, only : pbuf_add_field, dtype_r8, dyn_time_lvls - implicit none - call phys_getopts( shallow_scheme_out = shallow_scheme, microp_scheme_out = microp_scheme) @@ -92,6 +91,8 @@ subroutine convect_shallow_register call pbuf_add_field('NEVAPR_SHCU','physpkg' ,dtype_r8,(/pcols,pver/), nevapr_shcu_idx ) call pbuf_add_field('PREC_SH', 'physpkg' ,dtype_r8,(/pcols/), prec_sh_idx ) call pbuf_add_field('SNOW_SH', 'physpkg' ,dtype_r8,(/pcols/), snow_sh_idx ) + ! Updraft mass flux by shallow convection [ kg/s/m2 ] + call pbuf_add_field('CMFMC_SH', 'physpkg' ,dtype_r8,(/pcols,pverp/), cmfmc_sh_idx ) if( shallow_scheme .eq. 'UW' ) then call pbuf_add_field('shfrc','physpkg' ,dtype_r8,(/pcols,pver/),shfrc_idx ) @@ -136,8 +137,6 @@ subroutine convect_shallow_init(pref_edge) use physics_buffer, only : pbuf_get_index, physics_buffer_desc, pbuf_set_field use time_manager, only : is_first_step - implicit none - real(r8), intent(in) :: pref_edge(plevp) ! Reference pressures at interfaces integer limcnv ! Top interface level limit for convection @@ -200,7 +199,7 @@ subroutine convect_shallow_init(pref_edge) call addfld( 'PRECSH ' , 'm/s ', 1, 'A' , & 'Shallow Convection precipitation rate' , phys_decomp ) call addfld( 'CMFMC ' , 'kg/m2/s ', pverp, 'A' , & - 'Moist shallow convection mass flux' , phys_decomp ) + 'Moist convection (deep+shallow) mass flux' , phys_decomp ) call addfld( 'CMFSL ' , 'W/m2 ', pverp, 'A' , & 'Moist shallow convection liquid water static energy flux' , phys_decomp ) call addfld( 'CMFLQ ' , 'W/m2 ', pverp, 'A' , & @@ -461,6 +460,8 @@ subroutine convect_shallow_tend( ztodt , cmfmc , cmfmc2 , & real(r8), pointer, dimension(:,:) :: sh_cldliq real(r8), pointer, dimension(:,:) :: sh_cldice + real(r8), pointer, dimension(:,:) :: cmfmc2_sh ! (pcols,pverp) Updraft mass flux by shallow convection [ kg/s/m2 ] + logical :: lq(pcnst) ! ----------------------- ! @@ -501,6 +502,8 @@ subroutine convect_shallow_tend( ztodt , cmfmc , cmfmc2 , & call pbuf_get_field(pbuf, shfrc_idx, shfrc ) endif + call pbuf_get_field(pbuf, cmfmc_sh_idx, cmfmc2_sh) + ! Initialization @@ -625,13 +628,15 @@ subroutine convect_shallow_tend( ztodt , cmfmc , cmfmc2 , & ! Convective fluxes of 'sl' and 'qt' in energy unit ! ! ------------------------------------------------- ! - cmfsl(:ncol,:pverp) = slflx(:ncol,:pverp) - cmflq(:ncol,:pverp) = qtflx(:ncol,:pverp) * latvap + cmfsl(:ncol,:) = slflx(:ncol,:) + cmflq(:ncol,:) = qtflx(:ncol,:) * latvap call outfld( 'PRECSH' , precc , pcols, lchnk ) end select + cmfmc2_sh = cmfmc2 + ! --------------------------------------------------------! ! Calculate fractional occurance of shallow convection ! ! --------------------------------------------------------! diff --git a/models/atm/cam/src/physics/cam/dynamic_vector_procdef.inc b/models/atm/cam/src/physics/cam/dynamic_vector_procdef.inc new file mode 100644 index 000000000000..81d71dce48c0 --- /dev/null +++ b/models/atm/cam/src/physics/cam/dynamic_vector_procdef.inc @@ -0,0 +1,583 @@ +! Type-bound procedures for a dynamic vector. + +#ifdef USE_PURE +#define PURE pure +#else +#define PURE +#endif + +! Construct an empty vector. +PURE function new_vector_default() result(new_vec) + ! Create an empty vector + type( VECTOR_NAME ) :: new_vec + + ! Currently, this does nothing. But some compilers may do weird things if + ! you don't "define" new_vec somehow, and clearing the vector is safe. + call new_vec%clear() + +end function new_vector_default + +! Construct a vector from another vector. +PURE function new_vector_copy(vec) result(new_vec) + ! Create a vector from a pre-existing array. + type( VECTOR_NAME ), intent(in) :: vec + type( VECTOR_NAME ) :: new_vec + + new_vec = vec + +end function new_vector_copy + +! Construct a vector from an array. +PURE function new_vector_array(array) result(new_vec) + ! Create a vector from a pre-existing array. + TYPE_NAME, intent(in) :: array(:) + type( VECTOR_NAME ) :: new_vec + + new_vec = array + +end function new_vector_array + +! Query if the vector is empty. +PURE function empty_vec(self) result(is_empty) + class( VECTOR_NAME ), intent(in) :: self + logical :: is_empty + + is_empty = (self%vec_size == 0) + +end function empty_vec + +! Get size of the vector. +PURE function size_vec(self) result(vec_size) + class( VECTOR_NAME ), intent(in) :: self + integer :: vec_size + + vec_size = self%vec_size + +end function size_vec + +! Get maximum size the vector can have. +PURE function max_size_vec(self) result(max_size) + class( VECTOR_NAME ), intent(in) :: self + integer :: max_size + + ! The only theoretical limitation that can be determined without a system + ! call is the maximum size of an integer. + max_size = huge(self%vec_size) + +end function max_size_vec + +! Query current memory capacity of vector. +PURE function capacity_vec(self) result(capacity) + class( VECTOR_NAME ), intent(in) :: self + integer :: capacity + + if (allocated(self%data)) then + capacity = size(self%data) + else + capacity = 0 + end if + +end function capacity_vec + +! Get one item based on an index. +PURE function get_single_vec(self, index) result(item) + class( VECTOR_NAME ), intent(in) :: self + integer, intent(in) :: index + TYPE_NAME, allocatable :: item + + if (index > self%vec_size .or. index < 1) then + THROW(OOBMsg("get", [1, self%vec_size], index)) + ! Purely to satisfy uninitialized data checks. + allocate(item) + return + end if + + allocate(item, source=self%data(index)) + +end function get_single_vec + +! Get items within a certain range. +PURE function get_range_vec(self, begin, end, stride) result(items) + class( VECTOR_NAME ), intent(in) :: self + integer, intent(in) :: begin + integer, intent(in) :: end + integer, intent(in), optional :: stride + + ! Have to use an allocatable, because we have to check if stride is + ! present before we know what the size should be. + TYPE_NAME, allocatable :: items(:) + + ! An oddity: since in Fortran function results must be "defined", we have + ! to allocate "items" to portably avoid a segfault and allow the user to + ! recover from an error. This is true regardless of what the function + ! result is assigned to. + if (end > self%vec_size) then + allocate(items(0)) + THROW(OOBMsg("get", [1, self%vec_size], end)) + return + end if + if (begin < 1) then + allocate(items(0)) + THROW(OOBMsg("get", [1, self%vec_size], begin)) + return + end if + + if (present(stride)) then + allocate(items(end+1-begin/stride)) + items = self%data(begin:end:stride) + else + allocate(items(end+1-begin)) + items = self%data(begin:end) + end if + +end function get_range_vec + +! Get an array containing a copy of the vector's elements. +! If array is not allocated, returns a size zero array. +PURE function get_array_vec(self) result(array) + class( VECTOR_NAME ), intent(in) :: self + TYPE_NAME :: array(self%vec_size) + + if (allocated(self%data)) then + array = self%data(:self%vec_size) + end if + +end function get_array_vec + +! Get first item in the array +PURE function front_vec(self) result(item) + class( VECTOR_NAME ), intent(in) :: self + TYPE_NAME :: item + + item = self%get(1) + +end function front_vec + +! Get last item in the array +PURE function back_vec(self) result(item) + class( VECTOR_NAME ), intent(in) :: self + TYPE_NAME :: item + + item = self%get(self%vec_size) + +end function back_vec + +! Declare the vector to have zero size. +! Does not change vector capacity. +PURE subroutine clear_vec(self) + class( VECTOR_NAME ), intent(inout) :: self + + call self%resize(0) + +end subroutine clear_vec + +! Declare the vector to have different size. +! Does not reduce vector capacity, but will enforce size <= capacity by +! growing array if necessary. +! Resizing to negative value is equivalent to resizing to 0. +PURE subroutine resize_vec(self, new_size, fill_value) + class( VECTOR_NAME ), intent(inout) :: self + integer, intent(in) :: new_size + TYPE_NAME, intent(in), optional :: fill_value + + integer :: request_capacity + + ! If not big enough, request capacity twice as big + ! as we have now (or 4 or 8 or... times, if necessary). + if (new_size > self%capacity()) then + request_capacity = max(self%capacity(),1) + + do while (request_capacity < new_size) + request_capacity = request_capacity * 2 + end do + + call self%reserve(request_capacity) + end if + + if (present(fill_value)) then + self%data((self%vec_size+1):new_size) = fill_value + end if + + self%vec_size = max(new_size,0) + +end subroutine resize_vec + +! Set one item based on an index. +PURE subroutine set_single_vec(self, item, index) + class( VECTOR_NAME ), intent(inout) :: self + TYPE_NAME, intent(in) :: item + integer, intent(in) :: index + + if (index > self%vec_size .or. index < 1) then + THROW(OOBMsg("set", [1, self%vec_size], index)) + return + end if + + self%data(index) = item + +end subroutine set_single_vec + +! Set range in array. +PURE subroutine set_range_vec(self, array, begin, end, stride) + class( VECTOR_NAME ), intent(inout) :: self + TYPE_NAME, intent(in) :: array(:) + integer, intent(in) :: begin + integer, intent(in) :: end + integer, intent(in), optional :: stride + + if (end > self%vec_size) then + THROW(OOBMsg("set", [1, self%vec_size], end)) + return + end if + if (begin < 1) then + THROW(OOBMsg("set", [1, self%vec_size], begin)) + return + end if + + if (present(stride)) then + self%data(begin:end:stride) = array + else + self%data(begin:end) = array + end if + +end subroutine set_range_vec + +! Set range in array with a fill value. +PURE subroutine set_range_fill_vec(self, fill_value, begin, end, stride) + class( VECTOR_NAME ), intent(inout) :: self + TYPE_NAME, intent(in) :: fill_value + integer, intent(in) :: begin + integer, intent(in) :: end + integer, intent(in), optional :: stride + + if (end > self%vec_size) then + THROW(OOBMsg("set", [1, self%vec_size], end)) + return + end if + if (begin < 1) then + THROW(OOBMsg("set", [1, self%vec_size], begin)) + return + end if + + if (present(stride)) then + self%data(begin:end:stride) = fill_value + else + self%data(begin:end) = fill_value + end if + +end subroutine set_range_fill_vec + +! Set array from an array. +PURE subroutine set_array_vec(self, array) + class( VECTOR_NAME ), intent(inout) :: self + TYPE_NAME, intent(in) :: array(:) + + if (size(array) /= self%vec_size) then + THROW("Input array is not the same size as the vector it sets.") + end if + + if (self%vec_size > 0) then + self%data(:self%vec_size) = array(:self%vec_size) + end if + +end subroutine set_array_vec + +! Set array from a fill value. +! Bounds-checking unnecessary; empty arrays are left empty. +PURE subroutine set_fill_vec(self, fill_value) + class( VECTOR_NAME ), intent(inout) :: self + TYPE_NAME, intent(in) :: fill_value + + if (allocated(self%data)) then + self%data(:self%vec_size) = fill_value + end if + +end subroutine set_fill_vec + +! Add new object as last element. +PURE subroutine push_back_vec(self, item) + class( VECTOR_NAME ), intent(inout) :: self + TYPE_NAME, intent(in) :: item + + call self%resize(self%vec_size+1) + + call self%set(item, self%vec_size) + +end subroutine push_back_vec + +! Remove last element. +PURE subroutine pop_back_vec(self) + class( VECTOR_NAME ), intent(inout) :: self + + if (self%empty()) then + THROW("Attempted to pop an element from an empty vector.") + end if + + call self%resize(self%vec_size-1) + +end subroutine pop_back_vec + +! Insert element +! Valid values are 1 to self%vec_size+1. +! Inserting at self%vec_size+1 is equivalent to push_back. +PURE subroutine insert_single_vec(self, index, item) + class( VECTOR_NAME ), intent(inout) :: self + integer, intent(in) :: index + TYPE_NAME, intent(in) :: item + + if (index > self%vec_size+1 .or. index < 1) then + THROW(OOBMsg("insert", [1, self%vec_size], index)) + return + end if + + call self%resize(self%vec_size+1) + + ! Move everything forward + self%data(index+1:self%vec_size) = & + self%data(index:self%vec_size-1) + + call self%set(item, index) + +end subroutine insert_single_vec + +! Insert array +PURE subroutine insert_array_vec(self, index, items) + class( VECTOR_NAME ), intent(inout) :: self + integer, intent(in) :: index + TYPE_NAME, intent(in) :: items(:) + + if (index > self%vec_size+1 .or. index < 1) then + THROW(OOBMsg("insert", [1, self%vec_size], index)) + return + end if + + call self%resize(self%vec_size+size(items)) + + ! Move everything forward + self%data(index+size(items):self%vec_size) = & + self%data(index:self%vec_size-size(items)) + + call self%set(items, index, index+size(items)-1) + +end subroutine insert_array_vec + +! Insert repeated value +PURE subroutine insert_repeat_vec(self, index, item, repeats) + class( VECTOR_NAME ), intent(inout) :: self + integer, intent(in) :: index + TYPE_NAME, intent(in) :: item + integer, intent(in) :: repeats + + if (index > self%vec_size+1 .or. index < 1) then + THROW(OOBMsg("insert", [1, self%vec_size], index)) + return + end if + + call self%resize(self%vec_size+repeats) + + ! Move everything forward + self%data(index+repeats:self%vec_size) = & + self%data(index:self%vec_size-repeats) + + call self%set(item, index, index+repeats-1) + +end subroutine insert_repeat_vec + +! Erase element +PURE subroutine erase_single_vec(self, index) + class( VECTOR_NAME ), intent(inout) :: self + integer, intent(in) :: index + + if (index > self%vec_size .or. index < 1) then + THROW(OOBMsg("erase", [1, self%vec_size], index)) + return + end if + + ! Move everything back + self%data(index:(self%vec_size-1)) = self%data((index+1):self%vec_size) + + call self%pop_back() + +end subroutine erase_single_vec + +! Erase "repeats" elements at index. +PURE subroutine erase_range_vec(self, begin, end) + class( VECTOR_NAME ), intent(inout) :: self + integer, intent(in) :: begin + integer, intent(in) :: end + + if (end > self%vec_size) then + THROW(OOBMsg("erase", [1, self%vec_size], end)) + return + end if + if (begin < 1) then + THROW(OOBMsg("erase", [1, self%vec_size], begin)) + return + end if + + ! Move everything back + self%data(begin:self%vec_size-end+begin-1) = & + self%data(end+1:self%vec_size) + + call self%resize(self%vec_size - end + begin-1) + +end subroutine erase_range_vec + +! Shrink vector to minimum size necessary to hold all elements. +PURE subroutine shrink_to_fit_vec(self) + class( VECTOR_NAME ), intent(inout) :: self + TYPE_NAME, allocatable :: tmp_array(:) + + ! Don't do anything unless we have to. + if (self%vec_size < self%capacity()) then + ! If size is zero, just deallocate array. + if (self%vec_size == 0) then + if (allocated(self%data)) deallocate(self%data) + else + ! Allocate temporary at minimum size + allocate(tmp_array(self%vec_size)) + tmp_array = self%data(:self%vec_size) + + deallocate(self%data) + call move_alloc(tmp_array, self%data) + end if + end if + +end subroutine shrink_to_fit_vec + +! Reserve a certain size, if vector is not already that big. +PURE subroutine reserve_vec(self, capacity) + class( VECTOR_NAME ), intent(inout) :: self + integer, intent(in) :: capacity + + TYPE_NAME, allocatable :: tmp_array(:) + + ! Only do anything if we need to get bigger. + if (capacity > self%capacity()) then + + if (self%empty()) then + ! No data to copy + if (allocated(self%data)) deallocate(self%data) + allocate(self%data(capacity)) + else + ! Allocate new size + allocate(tmp_array(capacity)) + ! Copy data + tmp_array(:self%vec_size) = self%data(:self%vec_size) + + ! Replace array with new copy. + deallocate(self%data) + call move_alloc(tmp_array, self%data) + end if + end if + +end subroutine reserve_vec + +! Move allocatable array into self +! Note: Declaring self as intent(out) automatically empties the vector the +! moment we enter this procedure! +PURE subroutine move_in_vec(self, array) + class( VECTOR_NAME ), intent(out) :: self + TYPE_NAME, allocatable, intent(inout) :: array(:) + + if (allocated(array)) then + call move_alloc(array, self%data) + self%vec_size = size(self%data) + end if + +end subroutine move_in_vec + +! Move self into output allocatable array. +! For empty vector, do not allocate output. +PURE subroutine move_out_vec(self, array) + class( VECTOR_NAME ), intent(inout) :: self + TYPE_NAME, allocatable, intent(out) :: array(:) + + call self%shrink_to_fit() + + if (.not. self%empty()) then + call move_alloc(self%data, array) + end if + + call self%clear() + +end subroutine move_out_vec + +! Efficient swapping (no de/reallocation) +PURE subroutine swap_vec(self, other) + class( VECTOR_NAME ), intent(inout) :: self + class( VECTOR_NAME ), intent(inout) :: other + + integer :: tmp_size + TYPE_NAME, allocatable :: tmp_array(:) + + ! The following order is designed to work even if self and other are the + ! same vector. + if (allocated(other%data)) then + call move_alloc(other%data, tmp_array) + end if + + if (allocated(self%data)) then +#ifndef CPRPGI + call move_alloc(self%data, other%data) +#else + ! The above should work, but a PGI bug forces us to copy and + ! deallocate. + allocate(other%data, source=self%data) + deallocate(self%data) +#endif + end if + + if (allocated(tmp_array)) then +#ifndef CPRPGI + call move_alloc(tmp_array, self%data) +#else + ! The above should work, but a PGI bug forces us to copy and + ! deallocate. + allocate(self%data, source=tmp_array) + deallocate(tmp_array) +#endif + end if + + tmp_size = other%vec_size + other%vec_size = self%vec_size + self%vec_size = tmp_size + +end subroutine swap_vec + +! Assign self from an array +PURE subroutine array_assign_vec(self, array) + class( VECTOR_NAME ), intent(inout) :: self + TYPE_NAME, intent(in) :: array(:) + + call self%resize(size(array)) + + call self%set(array) + +end subroutine array_assign_vec + +! Assign self from another vector. +! Copy-and-swap is used to ensure that at most one copy of the array is +! performed. +! This would allow assignment to self in other languages, but Fortran 2003 +! is vague about whether this should work, since "other" must be +! "intent(in)" for an assignment, and this routine would modify it if it is +! the same as "self". +! Use of the "target" attribute is intended to mitigate the risk of a +! problem, warning the compiler that the two objects may overlap with other +! variables. +PURE subroutine vector_assign_vec(self, other) + class( VECTOR_NAME ), intent(inout), target :: self + class( VECTOR_NAME ), intent(in), target :: other + + class( VECTOR_NAME ), allocatable :: temp + + allocate(temp, source=other) + + call self%swap(temp) + + deallocate(temp) + +end subroutine vector_assign_vec + +#undef PURE diff --git a/models/atm/cam/src/physics/cam/dynamic_vector_typedef.inc b/models/atm/cam/src/physics/cam/dynamic_vector_typedef.inc new file mode 100644 index 000000000000..d9cd1b3a2b5c --- /dev/null +++ b/models/atm/cam/src/physics/cam/dynamic_vector_typedef.inc @@ -0,0 +1,266 @@ +! +! Clone of C++ standard library vectors +! +! This type is a wrapper for an allocatable array, which provides +! efficient utilities for dynamic array operations, such as appending new +! elements, truncation, and reserving/retaining memory independently from +! changes to the array's apparent size. +! +! Dynamic arrays allocate a somewhat larger buffer of contiguous memory +! (the "capacity") than is actually being used at any given time (the +! "size"). This allow elements to be efficiently added to one end, with the +! object automatically reallocating a new buffer as necessary whenever the +! current capacity is exhausted. The capacity increases geometrically, +! wasting O(N) space, but requiring only O(1) time (amortized) to add each +! element. +! +! One downside is that this wrapper class does not support many of +! Fortran's intrinsic array operations. For instance, if you have a +! vector of reals, and you want to take the sine, you have to either +! iterate in a loop (slow), or set the upper bound yourself (without the +! safety of bounds checking). The latter looks like this: +! +! x = sin(vec%data(:vec%size())) +! +! Because of this, it's probably preferable to use a standard array instead +! of a vector of reals for numerical work. +! +! Because this type uses an allocatable instead of a pointer, it should not +! cause a memory leak. However, deallocation can be forced by using "clear" +! followed by "shrink_to_fit", or by explicit deallocation of the data +! component. +! +! How to create a vector type: +! ---------------------------- +! +! Define VECTOR_NAME and TYPE_NAME in a module, then include this file +! to create the type. Include this file before "contains" in the module, +! and the "procdef" file afterward. +! +! There must be a function in scope called OOBMsg (or a function macro of +! this name). This must accept a string representing the operation, a size +! 2 integer array representing the bounds of the array, and an integer +! representing an index into the array. It should return a string +! representing an error message for out-of-bounds access. +! +! Finally, define the function macro THROW to an error handling mechanism. +! THROW accepts one argument, a string representing an error message. +! +! Some tips: +! ---------- +! +! - Do not directly use the "data" component, unless it's unavoidable to +! get decent efficiency. +! +! - The data is assumed to always have lower bound 1. +! +! - If you are finished with adding/removing elements, you can convert +! this type into a standard allocatable array with the "move_out" +! method. (You can do the reverse conversion cheaply with "move_in".) +! +! - Don't include these files twice in the same module, as this will cause +! name clashes. +! +! - Don't use this type if you need pointers into the array to remain +! valid as you add and remove elements. As with the C++ type, the array +! is often reallocated if you are adding elements, and this invalidates +! pointers into it. +! +! Advanced features: +! ------------------ +! +! - Define the macro "USE_PURE" if you need to mark all methods as pure. +! This effectively requires errors to be silent (because THROW cannot do +! anything useful if it has no side effects). +! +! Developer's notes: +! ------------------ +! +! 1) The main difference from the C++ types is that we use Fortran array +! indexing conventions: +! - Indexing starts at 1, not 0. +! - The last element of a range is included in the range. E.g. using +! "vec%erase(2,3)" erases two elements, not just one. +! - When an array size would be negative, it is treated as size 0. +! - When an operation's ending index is smaller than the beginning +! index, it is a no-op (unless a negative stride is provided). +! +! 2) We could have iterator types like in C++, but they don't really give +! you anything more than integer indices. Other types, like linked +! lists, will likely require companion iterator types. +! +! 3) For access with bounds-checking, C++ uses the "at" method to provide +! references to individual elements. To avoid working with pointers, and +! to provide an interface somewhat closer to Fortran array conventions, +! this type uses set/get methods instead. +! +! These methods are likely to produce extra copies, which may negatively +! impact performance compared to direct access of the underlying data. +! This is one reason why the data component is public, not private. +! +! 4) All vectors with vec_size = 0 are valid empty vectors, regardless of +! whether or not "data" is allocated, and regardless of its size. This +! slightly complicates some of the methods. However, it means that the +! user does not have to initialize vectors, or treat empty vectors +! differently depending on how they became empty. +! +! 5) Dynamic arrays have a time/space tradeoff parameter, which is the +! factor by which the array's capacity grows whenever it is +! automatically reallocated to hold more elements. In this code, the +! factor is 2, which is a common, simple, and reasonably fast choice. +! +! If there is too much wasted memory over a wide range of use cases, +! however, it may be reasonable to consider using 1.5 or even lower +! (with appropriate attention given to rounding issues). + +type VECTOR_NAME + + TYPE_NAME, allocatable :: data(:) + + integer, private :: vec_size = 0 + contains + + !------------------------ + ! Query functions + !------------------------ + + ! Test whether there are any elements present + procedure, pass(self) :: empty => empty_vec + ! Return current size + procedure, pass(self) :: vsize => size_vec + ! Estimate maximum possible size + procedure, pass(self) :: max_size => max_size_vec + ! Return maximum number of elements that can be held before the data + ! array will be reallocated to a larger size. + procedure, pass(self) :: capacity => capacity_vec + + !------------------------ + ! Retrieving data + !------------------------ + + ! Get the value of the element at a particular index + procedure, pass(self), private :: get_single_vec + ! Get an array of values of all the elements within a range + procedure, pass(self), private :: get_range_vec + ! Get a copy of all the data + procedure, pass(self), private :: get_array_vec + ! Generic for all of the above. + generic :: get => get_single_vec, get_range_vec, get_array_vec + + ! Get the value of the first element + procedure, pass(self) :: front => front_vec + ! Get the value of the last element + procedure, pass(self) :: back => back_vec + + !------------------------ + ! Modifying data + !------------------------ + + ! Reset the vector to size 0 (without changing capacity) + procedure, pass(self) :: clear => clear_vec + + ! Resize the vector (will not reduce capacity) + ! Resizing to a larger size than the capacity causes reallocation of the + ! data array. + procedure, pass(self) :: resize => resize_vec + + ! None of the "set" routines below will grow the array. Setting elements + ! past the end of the vector will result in an out-of-bounds error; use + ! "insert", "push_back", or explicit resizing to add elements. + + ! Set the element at a particular index + procedure, pass(self), private :: set_single_vec + ! Set the elements in a range from an array + procedure, pass(self), private :: set_range_vec + ! Fill all the elements in a range with a scalar value + procedure, pass(self), private :: set_range_fill_vec + ! Set the data to a copy of some array + procedure, pass(self), private :: set_array_vec + ! Fill the data will a scalar value + procedure, pass(self), private :: set_fill_vec + ! Generic for all of the above. + generic :: set => set_single_vec, set_range_vec, set_range_fill_vec, & + set_array_vec, set_fill_vec + + ! Add an element to the back of the vector + procedure, pass(self) :: push_back => push_back_vec + ! Remove the element at the back of the vector + procedure, pass(self) :: pop_back => pop_back_vec + + ! All of the insert routines add elements; the vector will be expanded + ! and data shuffled to ensure that this is non-destructive. For a vector + ! of size n, new elements can be inserted anywhere from 1 to n+1. + ! Inserting at point n+1 is equivalent to adding the new elements one- + ! by-one with push_back. + + ! Insert one element at a particular point + procedure, pass(self), private :: insert_single_vec + ! Insert all elements from an array at a particular point + procedure, pass(self), private :: insert_array_vec + ! Insert multiple copies of the same value at a particular point. + procedure, pass(self), private :: insert_repeat_vec + ! Generic for all of the above. + generic :: insert => insert_single_vec, insert_array_vec, insert_repeat_vec + + ! Erase the element at a particular point + procedure, pass(self), private :: erase_single_vec + ! Erase all the elements between two points (inclusive) + procedure, pass(self), private :: erase_range_vec + ! Generic for all of the above. + generic :: erase => erase_single_vec, erase_range_vec + + !------------------------ + ! Adjusting capacity + !------------------------ + + ! Shrink the vector's capacity to fit its size, releasing unneeded + ! memory + procedure, pass(self) :: shrink_to_fit => shrink_to_fit_vec + + ! Expand the vector to have at least as much capacity as requested + ! Mostly useful to avoid unnecessary reallocation when you know that the + ! data is unlikely to exceed some upper bound on its size. + procedure, pass(self) :: reserve => reserve_vec + + !------------------------ + ! Move operations + !------------------------ + + ! Convert an allocatable array into a dynamic vector + ! No copies or reallocations are performed, but afterward the array is + ! no longer allocated. + procedure, pass(self) :: move_in => move_in_vec + + ! Convert a dynamic vector to an allocatable array + ! An empty vector is converted to an unallocated array. A reallocation + ! and copy is often performed otherwise. Afterward the vector is empty. + procedure, pass(self) :: move_out => move_out_vec + + ! Swap the contents of this vector with another one + ! No copies or reallocations are performed. + procedure, pass(self) :: swap => swap_vec + + !------------------------ + ! Copy/assignment + !------------------------ + + ! Overwrite contents of this vector with those of an array + procedure, pass(self), private :: array_assign_vec + ! Overwrite contents of this vector with those of another vector + procedure, pass(self), private :: vector_assign_vec + generic :: assignment(=) => array_assign_vec, vector_assign_vec + +end type VECTOR_NAME + +!------------------------ +! Constructors +!------------------------ + +interface VECTOR_NAME + ! Construct empty vector + module procedure new_vector_default + ! Construct vector as a copy of another vector + module procedure new_vector_copy + ! Construct vector with contents from an array + module procedure new_vector_array +end interface diff --git a/models/atm/cam/src/physics/cam/hetfrz_classnuc.F90 b/models/atm/cam/src/physics/cam/hetfrz_classnuc.F90 new file mode 100644 index 000000000000..dc27dcbc75e1 --- /dev/null +++ b/models/atm/cam/src/physics/cam/hetfrz_classnuc.F90 @@ -0,0 +1,689 @@ +module hetfrz_classnuc + +!----------------------------------------------------------------------- +! +! Purpose: Calculate heterogeneous freezing rates from classical nucleation theory +! +! Public interfaces: +! +! hetfrz_classnuc_init +! hetfrz_classnuc_calc +! +! Author: +! Corinna Hoose, UiO, May 2009 +! Yong Wang and Xiaohong Liu, UWyo, 12/2012, +! implement in CAM5 and constrain uncertain parameters using natural dust and +! BC(soot) datasets. +! Yong Wang and Xiaohong Liu, UWyo, 05/2013, implement the PDF-contact angle +! approach: Y. Wang et al., Atmos. Chem. Phys., 2014. +! +!----------------------------------------------------------------------- + +use shr_kind_mod, only: r8 => shr_kind_r8 +use wv_saturation, only: svp_water, svp_ice +use shr_spfn_mod, only: erf => shr_spfn_erf + +implicit none +private +save + +public :: hetfrz_classnuc_init, hetfrz_classnuc_calc + +real(r8) :: rair +real(r8) :: cpair +real(r8) :: rh2o +real(r8) :: rhoh2o +real(r8) :: mwh2o +real(r8) :: tmelt +real(r8) :: pi + +integer :: iulog + +!=================================================================================================== +contains +!=================================================================================================== + +subroutine hetfrz_classnuc_init( & + rair_in, cpair_in, rh2o_in, rhoh2o_in, mwh2o_in, & + tmelt_in, pi_in, iulog_in) + + real(r8), intent(in) :: rair_in + real(r8), intent(in) :: cpair_in + real(r8), intent(in) :: rh2o_in + real(r8), intent(in) :: rhoh2o_in + real(r8), intent(in) :: mwh2o_in + real(r8), intent(in) :: tmelt_in + real(r8), intent(in) :: pi_in + integer, intent(in) :: iulog_in + + rair = rair_in + cpair = cpair_in + rh2o = rh2o_in + rhoh2o = rhoh2o_in + mwh2o = mwh2o_in + tmelt = tmelt_in + pi = pi_in + iulog = iulog_in + +end subroutine hetfrz_classnuc_init + +!=================================================================================================== + +subroutine hetfrz_classnuc_calc( & + deltat, t, p, supersatice, & + fn, & + r3lx, icnlx, & + frzbcimm, frzduimm, & + frzbccnt, frzducnt, & + frzbcdep, frzdudep, & + hetraer, awcam, awfacm, dstcoat, & + total_aer_num, coated_aer_num, uncoated_aer_num, & + total_interstitial_aer_num, total_cloudborne_aer_num, errstring) + + real(r8), intent(in) :: deltat ! timestep [s] + real(r8), intent(in) :: t ! temperature [K] + real(r8), intent(in) :: p ! pressure [Pa] + real(r8), intent(in) :: supersatice ! supersaturation ratio wrt ice at 100%rh over water [ ] + real(r8), intent(in) :: r3lx ! volume mean drop radius [m] + real(r8), intent(in) :: icnlx ! in-cloud droplet concentration [cm-3] + + real(r8), intent(in) :: fn(3) ! fraction activated [ ] for cloud borne aerosol number + ! index values are 1:bc, 2:dust_a1, 3:dust_a3 + real(r8), intent(in) :: hetraer(3) ! bc and dust mass mean radius [m] + real(r8), intent(in) :: awcam(3) ! modal added mass [mug m-3] + real(r8), intent(in) :: awfacm(3) ! (OC+BC)/(OC+BC+SO4) + real(r8), intent(in) :: dstcoat(3) ! coated fraction + real(r8), intent(in) :: total_aer_num(3) ! total bc and dust number concentration(interstitial+cloudborne) [#/cm^3] + real(r8), intent(in) :: coated_aer_num(3) ! coated bc and dust number concentration(interstitial) + real(r8), intent(in) :: uncoated_aer_num(3) ! uncoated bc and dust number concentration(interstitial) + real(r8), intent(in) :: total_interstitial_aer_num(3) ! total bc and dust concentration(interstitial) + real(r8), intent(in) :: total_cloudborne_aer_num(3) ! total bc and dust concentration(cloudborne) + + real(r8), intent(out) :: frzbcimm ! het. frz by BC immersion nucleation [cm-3 s-1] + real(r8), intent(out) :: frzduimm ! het. frz by dust immersion nucleation [cm-3 s-1] + real(r8), intent(out) :: frzbccnt ! het. frz by BC contact nucleation [cm-3 s-1] + real(r8), intent(out) :: frzducnt ! het. frz by dust contact nucleation [cm-3 s-1] + real(r8), intent(out) :: frzbcdep ! het. frz by BC deposition nucleation [cm-3 s-1] + real(r8), intent(out) :: frzdudep ! het. frz by dust deposition nucleation [cm-3 s-1] + + character(len=*), intent(out) :: errstring + + ! local variables + + real(r8) :: aw(3) ! water activity [ ] + real(r8) :: molal(3) ! molality [moles/kg] + real(r8), parameter :: Mso4 = 96.06_r8 + + integer, parameter :: id_bc = 1 + integer, parameter :: id_dst1 = 2 + integer, parameter :: id_dst3 = 3 + logical :: do_bc, do_dst1, do_dst3 + + real(r8), parameter :: n1 = 1.e19_r8 ! number of water molecules in contact with unit area of substrate [m-2] + real(r8), parameter :: kboltz = 1.38e-23_r8 + real(r8), parameter :: hplanck = 6.63e-34_r8 + real(r8), parameter :: rhplanck = 1._r8/hplanck + real(r8), parameter :: amu = 1.66053886e-27_r8 + real(r8), parameter :: nus = 1.e13_r8 ! frequ. of vibration [s-1] higher freq. (as in P&K, consistent with Anupam's data) + real(r8), parameter :: taufrz = 195.435_r8 ! time constant for falloff of freezing rate [s] + real(r8), parameter :: rhwincloud = 0.98_r8 ! 98% RH in mixed-phase clouds (Korolev & Isaac, JAS 2006) + real(r8), parameter :: limfacbc = 0.01_r8 ! max. ice nucleating fraction soot + real(r8), parameter :: pi = 4._r8*atan(1.0_r8) + real(r8) :: tc + real(r8) :: vwice + real(r8) :: rhoice + real(r8) :: sigma_iw ! [J/m2] + real(r8) :: sigma_iv ! [J/m2] + real(r8) :: esice ! [Pa] + real(r8) :: eswtr ! [Pa] + real(r8) :: rgimm + real(r8) :: rgdep + real(r8) :: dg0dep + real(r8) :: Adep + real(r8) :: dg0cnt + real(r8) :: Acnt + real(r8) :: rgimm_bc + real(r8) :: rgimm_dust_a1, rgimm_dust_a3 + real(r8) :: dg0imm_bc + real(r8) :: dg0imm_dust_a1, dg0imm_dust_a3 + real(r8) :: Aimm_bc + real(r8) :: Aimm_dust_a1, Aimm_dust_a3 + real(r8) :: q, m, phi + real(r8) :: r_bc ! model radii of BC modes [m] + real(r8) :: r_dust_a1, r_dust_a3 ! model radii of dust modes [m] + real(r8) :: f_imm_bc + real(r8) :: f_imm_dust_a1, f_imm_dust_a3 + real(r8) :: Jimm_bc + real(r8) :: Jimm_dust_a1, Jimm_dust_a3 + real(r8) :: f_dep_bc + real(r8) :: f_dep_dust_a1, f_dep_dust_a3 + real(r8) :: Jdep_bc + real(r8) :: Jdep_dust_a1, Jdep_dust_a3 + real(r8) :: f_cnt_bc + real(r8) :: f_cnt_dust_a1,f_cnt_dust_a3 + real(r8) :: Jcnt_bc + real(r8) :: Jcnt_dust_a1,Jcnt_dust_a3 + integer :: i + + !******************************************************** + ! Hoose et al., 2010 fitting parameters + !******************************************************** + !freezing parameters for immersion freezing + !real(r8),parameter :: theta_imm_bc = 40.17 ! contact angle [deg], converted to rad later + !real(r8),parameter :: dga_imm_bc = 14.4E-20 ! activation energy [J] + !real(r8),parameter :: theta_imm_dust = 30.98 ! contact angle [deg], converted to rad later + !real(r8),parameter :: dga_imm_dust = 15.7E-20 ! activation energy [J] + !freezing parameters for deposition nucleation + !real(r8),parameter :: theta_dep_dust = 12.7 ! contact angle [deg], converted to rad later !Zimmermann et al (2008), illite + !real(r8),parameter :: dga_dep_dust = -6.21E-21 ! activation energy [J] + !real(r8),parameter :: theta_dep_bc = 28. ! contact angle [deg], converted to rad later !Moehler et al (2005), soot + !real(r8),parameter :: dga_dep_bc = -2.E-19 ! activation energy [J] + !******************************************************** + ! Wang et al., 2014 fitting parameters + !******************************************************** + ! freezing parameters for immersion freezing + real(r8),parameter :: theta_imm_bc = 48.0_r8 ! contact angle [deg], converted to rad later !DeMott et al (1990) + real(r8),parameter :: dga_imm_bc = 14.15E-20_r8 ! activation energy [J] + real(r8),parameter :: theta_imm_dust = 46.0_r8 ! contact angle [deg], converted to rad later !DeMott et al (2011) SD + real(r8),parameter :: dga_imm_dust = 14.75E-20_r8 ! activation energy [J] + ! freezing parameters for deposition nucleation + real(r8),parameter :: theta_dep_dust = 20.0_r8 ! contact angle [deg], converted to rad later !Koehler et al (2010) SD + real(r8),parameter :: dga_dep_dust = -8.1E-21_r8 ! activation energy [J] + real(r8),parameter :: theta_dep_bc = 28._r8 ! contact angle [deg], converted to rad later !Moehler et al (2005), soot + real(r8),parameter :: dga_dep_bc = -2.E-19_r8 ! activation energy [J] + + real(r8) :: Kcoll_bc ! collision kernel [cm3 s-1] + real(r8) :: Kcoll_dust_a1 ! collision kernel [cm3 s-1] + real(r8) :: Kcoll_dust_a3 ! collision kernel [cm3 s-1] + + logical :: tot_in = .false. + + !***************************************************************************** + ! PDF theta model + !***************************************************************************** + ! some variables for PDF theta model + ! immersion freezing + real(r8),parameter :: theta_min = 1._r8/180._r8*pi + real(r8),parameter :: theta_max = 179._r8/180._r8*pi + real(r8) :: x1_imm + real(r8) :: x2_imm + real(r8) :: norm_theta_imm + real(r8),parameter :: imm_dust_mean_theta = 46.0_r8/180.0_r8*pi + real(r8),parameter :: imm_dust_var_theta = 0.01_r8 + real(r8) :: pdf_d_theta + integer,parameter :: pdf_n_theta = 101 + real(r8) :: dim_theta(pdf_n_theta) + real(r8) :: dim_f_imm_dust_a1(pdf_n_theta), dim_f_imm_dust_a3(pdf_n_theta) + real(r8) :: dim_Jimm_dust_a1(pdf_n_theta), dim_Jimm_dust_a3(pdf_n_theta) + real(r8) :: pdf_imm_theta(pdf_n_theta) + real(r8) :: sum_imm_dust_a1, sum_imm_dust_a3 + logical :: pdf_imm_in = .true. + !------------------------------------------------------------------------------------------------ + + errstring = ' ' + + if (pdf_imm_in) then + pdf_d_theta = (179._r8-1._r8)/180._r8*pi/(pdf_n_theta-1) + ! calculate the integral in the denominator + x1_imm = (LOG(theta_min)-LOG(imm_dust_mean_theta))/(sqrt(2.0_r8)*imm_dust_var_theta) + x2_imm = (LOG(theta_max)-LOG(imm_dust_mean_theta))/(sqrt(2.0_r8)*imm_dust_var_theta) + norm_theta_imm = (ERF(x2_imm)-ERF(x1_imm))*0.5_r8 + do i = 1, pdf_n_theta + dim_theta(i) = 1._r8/180._r8*pi+(i-1)*pdf_d_theta + pdf_imm_theta(i) = exp(-((LOG(dim_theta(i))-LOG(imm_dust_mean_theta))**2._r8)/(2._r8*imm_dust_var_theta**2._r8))/ & + (dim_theta(i)*imm_dust_var_theta*SQRT(2*pi))/norm_theta_imm + end do + end if + + ! get saturation vapor pressures + eswtr = svp_water(t) ! 0 for liquid + esice = svp_ice(t) ! 1 for ice + + tc = t - tmelt + rhoice = 916.7_r8-0.175_r8*tc-5.e-4_r8*tc**2 + vwice = mwh2o*amu/rhoice + sigma_iw = (28.5_r8+0.25_r8*tc)*1E-3_r8 + sigma_iv = (76.1_r8-0.155_r8*tc + 28.5_r8+0.25_r8*tc)*1E-3_r8 + + ! get mass mean radius + r_bc = hetraer(1) + r_dust_a1 = hetraer(2) + r_dust_a3 = hetraer(3) + + ! calculate collision kernels as a function of environmental parameters and aerosol/droplet sizes + call collkernel(t, p, eswtr, rhwincloud, r3lx, & + r_bc, & ! BC modes + r_dust_a1, r_dust_a3, & ! dust modes + Kcoll_bc, & ! collision kernel [cm3 s-1] + Kcoll_dust_a1, Kcoll_dust_a3) + + !***************************************************************************** + ! take water activity into account + !***************************************************************************** + ! solute effect + aw(:) = 1._r8 + molal(:) = 0._r8 + + ! The heterogeneous ice freezing temperatures of all IN generally decrease with + ! increasing total solute mole fraction. Therefore, the large solution concentration + ! will cause the freezing point depression and the ice freezing temperatures of all + ! IN will get close to the homogeneous ice freezing temperatures. Since we take into + ! account water activity for three heterogeneous freezing modes(immersion, deposition, + ! and contact), we utilize interstitial aerosols(not cloudborne aerosols) to calculate + ! water activity. + ! If the index of IN is 0, it means three freezing modes of this aerosol are depressed. + + do i = 1, 3 + !calculate molality + if ( total_interstitial_aer_num(i) > 0._r8 ) then + molal(i) = (1.e-6_r8*awcam(i)*(1._r8-awfacm(i))/(Mso4*total_interstitial_aer_num(i)*1.e6_r8))/ & + (4*pi/3*rhoh2o*(MAX(r3lx,4.e-6_r8))**3) + aw(i) = 1._r8/(1._r8+2.9244948e-2_r8*molal(i)+2.3141243e-3_r8*molal(i)**2+7.8184854e-7_r8*molal(i)**3) + end if + end do + + !***************************************************************************** + ! immersion freezing begin + !***************************************************************************** + + frzbcimm = 0._r8 + frzduimm = 0._r8 + frzbccnt = 0._r8 + frzducnt = 0._r8 + frzbcdep = 0._r8 + frzdudep = 0._r8 + + ! critical germ size + rgimm = 2*vwice*sigma_iw/(kboltz*t*LOG(supersatice)) + ! take solute effect into account + rgimm_bc = rgimm + rgimm_dust_a1 = rgimm + rgimm_dust_a3 = rgimm + + ! if aw*Si<=1, the freezing point depression is strong enough to prevent freezing + + if (aw(id_bc)*supersatice > 1._r8 ) then + do_bc = .true. + rgimm_bc = 2*vwice*sigma_iw/(kboltz*t*LOG(aw(id_bc)*supersatice)) + else + do_bc = .false. + end if + + if (aw(id_dst1)*supersatice > 1._r8 ) then + do_dst1 = .true. + rgimm_dust_a1 = 2*vwice*sigma_iw/(kboltz*t*LOG(aw(id_dst1)*supersatice)) + else + do_dst1 = .false. + end if + + if (aw(id_dst3)*supersatice > 1._r8 ) then + do_dst3 = .true. + rgimm_dust_a3 = 2*vwice*sigma_iw/(kboltz*t*LOG(aw(id_dst3)*supersatice)) + else + do_dst3 = .false. + end if + + ! form factor + ! only consider flat surfaces due to uncertainty of curved surfaces + + m = COS(theta_imm_bc*pi/180._r8) + f_imm_bc = (2+m)*(1-m)**2/4._r8 + if (.not. pdf_imm_in) then + m = COS(theta_imm_dust*pi/180._r8) + f_imm_dust_a1 = (2+m)*(1-m)**2/4._r8 + + m = COS(theta_imm_dust*pi/180._r8) + f_imm_dust_a3 = (2+m)*(1-m)**2/4._r8 + else + do i = 1, pdf_n_theta + m = cos(dim_theta(i)) + dim_f_imm_dust_a1(i) = (2+m)*(1-m)**2/4._r8 + + m = cos(dim_theta(i)) + dim_f_imm_dust_a3(i) = (2+m)*(1-m)**2/4._r8 + end do + end if + + ! homogeneous energy of germ formation + dg0imm_bc = 4*pi/3._r8*sigma_iw*rgimm_bc**2 + dg0imm_dust_a1 = 4*pi/3._r8*sigma_iw*rgimm_dust_a1**2 + dg0imm_dust_a3 = 4*pi/3._r8*sigma_iw*rgimm_dust_a3**2 + + ! prefactor + Aimm_bc = n1*((vwice*rhplanck)/(rgimm_bc**3)*SQRT(3._r8/pi*kboltz*T*dg0imm_bc)) + Aimm_dust_a1 = n1*((vwice*rhplanck)/(rgimm_dust_a1**3)*SQRT(3._r8/pi*kboltz*T*dg0imm_dust_a1)) + Aimm_dust_a3 = n1*((vwice*rhplanck)/(rgimm_dust_a3**3)*SQRT(3._r8/pi*kboltz*T*dg0imm_dust_a3)) + + ! nucleation rate per particle + + Jimm_bc = Aimm_bc*r_bc**2/SQRT(f_imm_bc)*EXP((-dga_imm_bc-f_imm_bc*dg0imm_bc)/(kboltz*T)) + if (.not. pdf_imm_in) then + ! 1/sqrt(f) + ! the expression of Chen et al. (sqrt(f)) may however lead to unphysical + ! behavior as it implies J->0 when f->0 (i.e. ice nucleation would be + ! more difficult on easily wettable materials). + Jimm_dust_a1 = Aimm_dust_a1*r_dust_a1**2/SQRT(f_imm_dust_a1)*EXP((-dga_imm_dust-f_imm_dust_a1*dg0imm_dust_a1)/(kboltz*T)) + Jimm_dust_a3 = Aimm_dust_a3*r_dust_a3**2/SQRT(f_imm_dust_a3)*EXP((-dga_imm_dust-f_imm_dust_a3*dg0imm_dust_a3)/(kboltz*T)) + end if + + if (pdf_imm_in) then + do i = 1, pdf_n_theta + ! 1/sqrt(f) + dim_Jimm_dust_a1(i) = Aimm_dust_a1*r_dust_a1**2/SQRT(dim_f_imm_dust_a1(i))*EXP((-dga_imm_dust-dim_f_imm_dust_a1(i)* & + dg0imm_dust_a1)/(kboltz*T)) + dim_Jimm_dust_a1(i) = max(dim_Jimm_dust_a1(i), 0._r8) + + dim_Jimm_dust_a3(i) = Aimm_dust_a3*r_dust_a3**2/SQRT(dim_f_imm_dust_a3(i))*EXP((-dga_imm_dust-dim_f_imm_dust_a3(i)* & + dg0imm_dust_a3)/(kboltz*T)) + dim_Jimm_dust_a3(i) = max(dim_Jimm_dust_a3(i), 0._r8) + end do + end if + + ! Limit to 1% of available potential IN (for BC), no limit for dust + if (pdf_imm_in) then + sum_imm_dust_a1 = 0._r8 + sum_imm_dust_a3 = 0._r8 + do i = 1, pdf_n_theta-1 + sum_imm_dust_a1 = sum_imm_dust_a1+0.5_r8*((pdf_imm_theta(i)*exp(-dim_Jimm_dust_a1(i)*deltat)+ & + pdf_imm_theta(i+1)*exp(-dim_Jimm_dust_a1(i+1)*deltat)))*pdf_d_theta + sum_imm_dust_a3 = sum_imm_dust_a3+0.5_r8*((pdf_imm_theta(i)*exp(-dim_Jimm_dust_a3(i)*deltat)+ & + pdf_imm_theta(i+1)*exp(-dim_Jimm_dust_a3(i+1)*deltat)))*pdf_d_theta + end do + end if + + if (.not.tot_in) then + if (do_bc) frzbcimm = frzbcimm+MIN(limfacbc*total_cloudborne_aer_num(id_bc)/deltat, & + total_cloudborne_aer_num(id_bc)/deltat*(1._r8-exp(-Jimm_bc*deltat))) + + if (.not. pdf_imm_in) then + if (do_dst1) frzduimm = frzduimm+MIN(1*total_cloudborne_aer_num(id_dst1)/deltat, & + total_cloudborne_aer_num(id_dst1)/deltat*(1._r8-exp(-Jimm_dust_a1*deltat))) + if (do_dst3) frzduimm = frzduimm+MIN(1*total_cloudborne_aer_num(id_dst3)/deltat, & + total_cloudborne_aer_num(id_dst3)/deltat*(1._r8-exp(-Jimm_dust_a3*deltat))) + else + if (do_dst1) frzduimm = frzduimm+MIN(1*total_cloudborne_aer_num(id_dst1)/deltat, & + total_cloudborne_aer_num(id_dst1)/deltat*(1._r8-sum_imm_dust_a1)) + if (do_dst3) frzduimm = frzduimm+MIN(1*total_cloudborne_aer_num(id_dst3)/deltat, & + total_cloudborne_aer_num(id_dst3)/deltat*(1._r8-sum_imm_dust_a3)) + end if + + else + if (do_bc) frzbcimm = frzbcimm+MIN(limfacbc*fn(id_bc)*total_aer_num(id_bc)/deltat, & + fn(id_bc)*total_aer_num(id_bc)/deltat*(1._r8-exp(-Jimm_bc*deltat))) + + if (.not. pdf_imm_in) then + if (do_dst1) frzduimm = frzduimm+MIN(1*fn(id_dst1)*total_aer_num(id_dst1)/deltat, & + fn(id_dst1)*total_aer_num(id_dst1)/deltat*(1._r8-exp(-Jimm_dust_a1*deltat))) + if (do_dst3) frzduimm = frzduimm+MIN(1*fn(id_dst3)*total_aer_num(id_dst3)/deltat, & + fn(id_dst3)*total_aer_num(id_dst3)/deltat*(1._r8-exp(-Jimm_dust_a3*deltat))) + else + if (do_dst1) frzduimm = frzduimm+MIN(1*fn(id_dst1)*total_aer_num(id_dst1)/deltat, & + fn(id_dst1)*total_aer_num(id_dst1)/deltat*(1._r8-sum_imm_dust_a1)) + if (do_dst3) frzduimm = frzduimm+MIN(1*fn(id_dst3)*total_aer_num(id_dst3)/deltat, & + fn(id_dst3)*total_aer_num(id_dst3)/deltat*(1._r8-sum_imm_dust_a3)) + end if + end if + + if (t > 263.15_r8) then + frzduimm = 0._r8 + frzbcimm = 0._r8 + end if + + !!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Deposition nucleation + !!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! critical germ size + ! assume 98% RH in mixed-phase clouds (Korolev & Isaac, JAS 2006) + rgdep=2*vwice*sigma_iv/(kboltz*t*LOG(rhwincloud*supersatice)) + + ! form factor + m = COS(theta_dep_bc*pi/180._r8) + f_dep_bc = (2+m)*(1-m)**2/4._r8 + + m = COS(theta_dep_dust*pi/180._r8) + f_dep_dust_a1 = (2+m)*(1-m)**2/4._r8 + + m = COS(theta_dep_dust*pi/180._r8) + f_dep_dust_a3 = (2+m)*(1-m)**2/4._r8 + + ! homogeneous energy of germ formation + dg0dep = 4*pi/3._r8*sigma_iv*rgdep**2 + + ! prefactor + ! attention: division of small numbers + Adep = (rhwincloud*eswtr)**2*(vwice/(mwh2o*amu))/(kboltz*T*nus)*SQRT(sigma_iv/(kboltz*T)) + + ! nucleation rate per particle + if (rgdep > 0) then + Jdep_bc = Adep*r_bc**2/SQRT(f_dep_bc)*EXP((-dga_dep_bc-f_dep_bc*dg0dep)/(kboltz*T)) + Jdep_dust_a1 = Adep*r_dust_a1**2/SQRT(f_dep_dust_a1)*EXP((-dga_dep_dust-f_dep_dust_a1*dg0dep)/(kboltz*T)) + Jdep_dust_a3 = Adep*r_dust_a3**2/SQRT(f_dep_dust_a3)*EXP((-dga_dep_dust-f_dep_dust_a3*dg0dep)/(kboltz*T)) + else + Jdep_bc = 0._r8 + Jdep_dust_a1 = 0._r8 + Jdep_dust_a3 = 0._r8 + end if + + ! Limit to 1% of available potential IN (for BC), no limit for dust + if (.not.tot_in) then + if (do_bc) frzbcdep = frzbcdep+MIN(limfacbc*uncoated_aer_num(id_bc)/deltat, & + uncoated_aer_num(id_bc)/deltat & + *(1._r8-exp(-Jdep_bc*deltat))) + if (do_dst1) frzdudep = frzdudep+MIN(uncoated_aer_num(id_dst1)/deltat, & + uncoated_aer_num(id_dst1)/deltat & + *(1._r8-exp(-Jdep_dust_a1*deltat))) + if (do_dst3) frzdudep = frzdudep+MIN(uncoated_aer_num(id_dst3)/deltat, & + uncoated_aer_num(id_dst3)/deltat & + *(1._r8-exp(-Jdep_dust_a3*deltat))) + else + if (do_bc) frzbcdep = frzbcdep+MIN(limfacbc*(1._r8-fn(id_bc)) & + *(1._r8-dstcoat(1))*total_aer_num(id_bc)/deltat, & + (1._r8-fn(id_bc))*(1._r8-dstcoat(1))*total_aer_num(id_bc)/deltat & + *(1._r8-exp(-Jdep_bc*deltat))) + if (do_dst1) frzdudep = frzdudep+MIN((1._r8-fn(id_dst1)) & + *(1._r8-dstcoat(2))*total_aer_num(id_dst1)/deltat, & + (1._r8-fn(id_dst1))*(1._r8-dstcoat(2))*total_aer_num(id_dst1)/deltat & + *(1._r8-exp(-Jdep_dust_a1*deltat))) + if (do_dst3) frzdudep = frzdudep+MIN((1._r8-fn(id_dst3)) & + *(1._r8-dstcoat(3))*total_aer_num(id_dst3)/deltat, & + (1._r8-fn(id_dst3))*(1._r8-dstcoat(3))*total_aer_num(id_dst3)/deltat & + *(1._r8-exp(-Jdep_dust_a3*deltat))) + end if + + !!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! contact nucleation + !!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! form factor + m = COS(theta_dep_bc*pi/180._r8) + f_cnt_bc = (2+m)*(1-m)**2/4._r8 + + m = COS(theta_dep_dust*pi/180._r8) + f_cnt_dust_a1 = (2+m)*(1-m)**2/4._r8 + + m = COS(theta_dep_dust*pi/180._r8) + f_cnt_dust_a3 = (2+m)*(1-m)**2/4._r8 + + ! homogeneous energy of germ formation + dg0cnt = 4*pi/3._r8*sigma_iv*rgimm**2 + + ! prefactor + ! attention: division of small numbers + Acnt = rhwincloud*eswtr*4*pi/(nus*SQRT(2*pi*mwh2o*amu*kboltz*T)) + + ! nucleation rate per particle + Jcnt_bc = Acnt*r_bc**2*EXP((-dga_dep_bc-f_cnt_bc*dg0cnt)/(kboltz*T))*Kcoll_bc*icnlx + Jcnt_dust_a1 = Acnt*r_dust_a1**2*EXP((-dga_dep_dust-f_cnt_dust_a1*dg0cnt)/(kboltz*T))*Kcoll_dust_a1*icnlx + Jcnt_dust_a3 = Acnt*r_dust_a3**2*EXP((-dga_dep_dust-f_cnt_dust_a3*dg0cnt)/(kboltz*T))*Kcoll_dust_a3*icnlx + + ! Limit to 1% of available potential IN (for BC), no limit for dust + if (.not.tot_in) then + if (do_bc) frzbccnt = frzbccnt+MIN(limfacbc*uncoated_aer_num(id_bc)/deltat, & + uncoated_aer_num(id_bc)/deltat & + *(1._r8-exp(-Jcnt_bc*deltat))) + if (do_dst1) frzducnt = frzducnt+MIN(uncoated_aer_num(id_dst1)/deltat, & + uncoated_aer_num(id_dst1)/deltat & + *(1._r8-exp(-Jcnt_dust_a1*deltat))) + if (do_dst3) frzducnt = frzducnt+MIN(uncoated_aer_num(id_dst3)/deltat, & + uncoated_aer_num(id_dst3)/deltat & + *(1._r8-exp(-Jcnt_dust_a3*deltat))) + else + if (do_bc) frzbccnt = frzbccnt+MIN(limfacbc*(1._r8-fn(id_bc))*(1._r8-dstcoat(1))*total_aer_num(id_bc)/deltat, & + (1._r8-fn(id_bc))*(1._r8-dstcoat(1))*total_aer_num(id_bc)/deltat & + *(1._r8-exp(-Jcnt_bc*deltat))) + if (do_dst1) frzducnt = frzducnt+MIN((1._r8-fn(id_dst1))*(1._r8-dstcoat(2))*total_aer_num(id_dst1)/deltat, & + (1._r8-fn(id_dst1))*(1._r8-dstcoat(2))*total_aer_num(id_dst1)/deltat & + *(1._r8-exp(-Jcnt_dust_a1*deltat))) + if (do_dst3) frzducnt = frzducnt+MIN((1._r8-fn(id_dst3))*(1._r8-dstcoat(3))*total_aer_num(id_dst3)/deltat, & + (1._r8-fn(id_dst3))*(1._r8-dstcoat(3))*total_aer_num(id_dst3)/deltat & + *(1._r8-exp(-Jcnt_dust_a3*deltat))) + end if + + if (frzducnt <= -1._r8) then + write(iulog,*) 'hetfrz_classnuc_calc: frzducnt', frzducnt, Jcnt_dust_a1,Jcnt_dust_a3, & + Kcoll_dust_a1, Kcoll_dust_a3 + errstring = 'ERROR in hetfrz_classnuc_calc::frzducnt' + return + end if + +end subroutine hetfrz_classnuc_calc + +!=================================================================================================== + +!----------------------------------------------------------------------- +! +! Purpose: calculate collision kernels as a function of environmental parameters and aerosol/droplet sizes +! +! Author: Corinna Hoose, UiO, October 2009 +! +! Modifications: Yong Wang and Xiaohong Liu, UWyo, 12/2012 +!----------------------------------------------------------------------- + +subroutine collkernel( & + t, pres, eswtr, rhwincloud, r3lx, & + r_bc, & ! BC modes + r_dust_a1, r_dust_a3, & ! dust modes + Kcoll_bc, & ! collision kernel [cm3 s-1] + Kcoll_dust_a1, Kcoll_dust_a3) + + real(r8), intent(in) :: t ! temperature [K] + real(r8), intent(in) :: pres ! pressure [Pa] + real(r8), intent(in) :: eswtr ! saturation vapor pressure of water [Pa] + real(r8), intent(in) :: r3lx ! volume mean drop radius [m] + real(r8), intent(in) :: rhwincloud ! in-cloud relative humidity over water [ ] + real(r8), intent(in) :: r_bc ! model radii of BC modes [m] + real(r8), intent(in) :: r_dust_a1 ! model radii of dust modes [m] + real(r8), intent(in) :: r_dust_a3 ! model radii of dust modes [m] + + real(r8), intent(out) :: Kcoll_bc ! collision kernel [cm3 s-1] + real(r8), intent(out) :: Kcoll_dust_a1 + real(r8), intent(out) :: Kcoll_dust_a3 + + ! local variables + real(r8) :: a, b, c, a_f, b_f, c_f, f + real(r8) :: tc ! temperature [deg C] + real(r8) :: rho_air ! air density [kg m-3] + real(r8) :: viscos_air ! dynamic viscosity of air [kg m-1 s-1] + real(r8) :: Ktherm_air ! thermal conductivity of air [J/(m s K)] + real(r8) :: lambda ! mean free path [m] + real(r8) :: Kn ! Knudsen number [ ] + real(r8) :: Re ! Reynolds number [ ] + real(r8) :: Pr ! Prandtl number [ ] + real(r8) :: Sc ! Schmidt number [ ] + real(r8) :: vterm ! terminal velocity [m s-1] + real(r8) :: Ktherm ! thermal conductivity of aerosol [J/(m s K)] + real(r8) :: Dvap ! water vapor diffusivity [m2 s-1] + real(r8) :: Daer ! aerosol diffusivity [m2 s-1] + real(r8) :: latvap ! latent heat of vaporization [J kg-1] + real(r8) :: kboltz ! Boltzmann constant [J K-1] + real(r8) :: G ! thermodynamic function in Cotton et al. [kg m-1 s-1] + real(r8) :: r_a ! aerosol radius [m] + real(r8) :: f_t ! factor by Waldmann & Schmidt [ ] + real(r8) :: Q_heat ! heat flux [J m-2 s-1] + real(r8) :: Tdiff_cotton ! temperature difference between droplet and environment [K] + real(r8) :: K_brownian,K_thermo_cotton,K_diffusio_cotton ! collision kernels [m3 s-1] + real(r8) :: K_total ! total collision kernel [cm3 s-1] + integer :: i + !------------------------------------------------------------------------------------------------ + + Kcoll_bc = 0._r8 + Kcoll_dust_a1 = 0._r8 + Kcoll_dust_a3 = 0._r8 + + tc = t - tmelt + kboltz = 1.38065e-23_r8 + + ! air viscosity for tc<0, from depvel_part.F90 + viscos_air = (1.718_r8+0.0049_r8*tc-1.2e-5_r8*tc*tc)*1.e-5_r8 + ! air density + rho_air = pres/(rair*t) + ! mean free path: Seinfeld & Pandis 8.6 + lambda = 2*viscos_air/(pres*SQRT(8/(pi*rair*t))) + ! latent heat of vaporization, varies with T + latvap = 1000*(-0.0000614342_r8*tc**3 + 0.00158927_r8*tc**2 - 2.36418_r8*tc + 2500.79_r8) + ! droplet terminal velocity after Chen & Liu, QJRMS 2004 + a = 8.8462e2_r8 + b = 9.7593e7_r8 + c = -3.4249e-11_r8 + a_f = 3.1250e-1_r8 + b_f = 1.0552e-3_r8 + c_f = -2.4023_r8 + f = EXP(EXP(a_f + b_f*(LOG(r3lx))**3 + c_f*rho_air**1.5_r8)) + vterm = (a+ (b + c*r3lx)*r3lx)*r3lx*f + + ! Reynolds number + Re = 2*vterm*r3lx*rho_air/viscos_air + ! thermal conductivity of air: Seinfeld & Pandis eq. 15.75 + Ktherm_air = 1.e-3_r8*(4.39_r8+0.071_r8*t) !J/(m s K) + ! Prandtl number + Pr = viscos_air*cpair/Ktherm_air + ! water vapor diffusivity: Pruppacher & Klett 13-3 + Dvap = 0.211e-4_r8*(t/273.15_r8)*(101325._r8/pres) + ! G-factor = rhoh2o*Xi in Rogers & Yau, p. 104 + G = rhoh2o/((latvap/(rh2o*t) - 1)*latvap*rhoh2o/(Ktherm_air*t) & + + rhoh2o*rh2o*t/(Dvap*eswtr)) + + ! variables depending on aerosol radius + ! loop over 3 aerosol modes + do i = 1, 3 + if (i == 1) r_a = r_bc + if (i == 2) r_a = r_dust_a1 + if (i == 3) r_a = r_dust_a3 + ! Knudsen number (Seinfeld & Pandis 8.1) + Kn = lambda/r_a + ! aerosol diffusivity + Daer = kboltz*t*(1 + Kn)/(6*pi*r_a*viscos_air) + ! Schmidt number + Sc = viscos_air/(Daer*rho_air) + + ! Young (1974) first equ. on page 771 + K_brownian = 4*pi*r3lx*Daer*(1 + 0.3_r8*Re**0.5_r8*Sc**0.33_r8) + + ! thermal conductivities from Seinfeld & Pandis, Table 8.6 + if (i == 1) Ktherm = 4.2_r8 ! Carbon + if (i == 2 .or. i == 3) Ktherm = 0.72_r8 ! clay + ! form factor + f_t = 0.4_r8*(1._r8 + 1.45_r8*Kn + 0.4_r8*Kn*EXP(-1._r8/Kn)) & + *(Ktherm_air + 2.5_r8*Kn*Ktherm) & + /((1._r8 + 3._r8*Kn)*(2._r8*Ktherm_air + 5._r8*Kn*Ktherm+Ktherm)) + ! calculate T-Tc as in Cotton et al. + Tdiff_cotton = -G*(rhwincloud - 1._r8)*latvap/Ktherm_air + Q_heat = Ktherm_air/r3lx*(1._r8 + 0.3_r8*Re**0.5_r8*Pr**0.33_r8)*Tdiff_cotton + K_thermo_cotton = 4._r8*pi*r3lx*r3lx*f_t*Q_heat/pres + K_diffusio_cotton = -(1._r8/f_t)*(rh2o*t/latvap)*K_thermo_cotton + K_total = 1.e6_r8*(K_brownian + K_thermo_cotton + K_diffusio_cotton) ! convert m3/s -> cm3/s + ! set K to 0 if negative + if (K_total .lt. 0._r8) K_total = 0._r8 + + if (i == 1) Kcoll_bc = K_total + if (i == 2) Kcoll_dust_a1 = K_total + if (i == 3) Kcoll_dust_a3 = K_total + + end do + +end subroutine collkernel + +!=================================================================================================== + + +end module hetfrz_classnuc diff --git a/models/atm/cam/src/physics/cam/hetfrz_classnuc_cam.F90 b/models/atm/cam/src/physics/cam/hetfrz_classnuc_cam.F90 new file mode 100644 index 000000000000..9b071c269eac --- /dev/null +++ b/models/atm/cam/src/physics/cam/hetfrz_classnuc_cam.F90 @@ -0,0 +1,1293 @@ +module hetfrz_classnuc_cam + +!--------------------------------------------------------------------------------- +! +! CAM Interfaces for hetfrz_classnuc module. +! +!--------------------------------------------------------------------------------- + +use shr_kind_mod, only: r8=>shr_kind_r8 +use spmd_utils, only: masterproc +use ppgrid, only: pcols, pver, begchunk, endchunk +use physconst, only: rair, cpair, rh2o, rhoh2o, mwh2o, tmelt, pi +use constituents, only: cnst_get_ind +use physics_types, only: physics_state +use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field +use phys_control, only: phys_getopts, use_hetfrz_classnuc +use rad_constituents, only: rad_cnst_get_info, rad_cnst_get_mode_idx, rad_cnst_get_spec_idx, & + rad_cnst_get_aer_mmr, rad_cnst_get_aer_props, & + rad_cnst_get_mode_num, rad_cnst_get_mode_props + +use physics_buffer, only: pbuf_add_field, dtype_r8, pbuf_old_tim_idx, & + pbuf_get_index, pbuf_get_field +use cam_history, only: addfld, phys_decomp, add_default, outfld + +use ref_pres, only: top_lev => trop_cloud_top_lev +use wv_saturation, only: svp_water, svp_ice + +use cam_logfile, only: iulog +use error_messages, only: handle_errmsg, alloc_err +use cam_abortutils, only: endrun + +use hetfrz_classnuc, only: hetfrz_classnuc_init, hetfrz_classnuc_calc + +implicit none +private +save + +public :: & + hetfrz_classnuc_cam_readnl, & + hetfrz_classnuc_cam_register, & + hetfrz_classnuc_cam_init, & + hetfrz_classnuc_cam_calc, & + hetfrz_classnuc_cam_save_cbaero + +! Namelist variables +logical :: hist_hetfrz_classnuc = .false. + +! Vars set via init method. +real(r8) :: mincld ! minimum allowed cloud fraction + +! constituent indices +integer :: & + cldliq_idx = -1, & + cldice_idx = -1, & + numliq_idx = -1, & + numice_idx = -1 + +! pbuf indices for fields provided by heterogeneous freezing +integer :: & + frzimm_idx, & + frzcnt_idx, & + frzdep_idx + +! pbuf indices for fields needed by heterogeneous freezing +integer :: & + ast_idx = -1 + +! modal aerosols +integer, parameter :: MAM3_nmodes = 3 +integer, parameter :: MAM7_nmodes = 7 +integer :: nmodes = -1 ! number of aerosol modes + +! mode indices +integer :: mode_accum_idx = -1 ! accumulation mode +integer :: mode_coarse_idx = -1 ! coarse mode +integer :: mode_finedust_idx = -1 ! fine dust mode +integer :: mode_coardust_idx = -1 ! coarse dust mode +integer :: mode_pcarbon_idx = -1 ! primary carbon mode + +! mode properties +real(r8) :: alnsg_mode_accum +real(r8) :: alnsg_mode_coarse +real(r8) :: alnsg_mode_finedust +real(r8) :: alnsg_mode_coardust +real(r8) :: alnsg_mode_pcarbon + +! specie properties +real(r8) :: specdens_dust +real(r8) :: specdens_so4 +real(r8) :: specdens_bc +real(r8) :: specdens_soa +real(r8) :: specdens_pom + +! List all species +integer :: ncnst = 0 ! Total number of constituents (mass and number) needed + ! by the parameterization (depends on aerosol model used) + +integer :: so4_accum ! sulfate in accumulation mode +integer :: bc_accum ! black-c in accumulation mode +integer :: pom_accum ! p-organic in accumulation mode +integer :: soa_accum ! s-organic in accumulation mode +integer :: dst_accum ! dust in accumulation mode +integer :: ncl_accum ! seasalt in accumulation mode +integer :: num_accum ! number in accumulation mode + +integer :: dst_coarse ! dust in coarse mode +integer :: ncl_coarse ! seasalt in coarse mode +integer :: so4_coarse ! sulfate in coarse mode +integer :: num_coarse ! number in coarse mode + +integer :: dst_finedust ! dust in finedust mode +integer :: so4_finedust ! sulfate in finedust mode +integer :: num_finedust ! number in finedust mode + +integer :: dst_coardust ! dust in coardust mode +integer :: so4_coardust ! sulfate in coardust mode +integer :: num_coardust ! number in coardust mode + +integer :: bc_pcarbon ! black-c in primary carbon mode +integer :: pom_pcarbon ! p-organic in primary carbon mode +integer :: num_pcarbon ! number in primary carbon mode + +! Index arrays for looping over all constituents +integer, allocatable :: mode_idx(:) +integer, allocatable :: spec_idx(:) + +! Copy of cloud borne aerosols before modification by droplet nucleation +! The basis is converted from mass to volume. +real(r8), allocatable :: aer_cb(:,:,:,:) + +! Copy of interstitial aerosols with basis converted from mass to volume. +real(r8), allocatable :: aer(:,:,:,:) + +!=============================================================================== +contains +!=============================================================================== + +subroutine hetfrz_classnuc_cam_readnl(nlfile) + + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use mpishorthand + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: subname = 'hetfrz_classnuc_cam_readnl' + + namelist /hetfrz_classnuc_nl/ hist_hetfrz_classnuc + + !----------------------------------------------------------------------------- + + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'hetfrz_classnuc_nl', status=ierr) + if (ierr == 0) then + read(unitn, hetfrz_classnuc_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(subname // ':: ERROR reading namelist') + end if + end if + close(unitn) + call freeunit(unitn) + + end if + +#ifdef SPMD + ! Broadcast namelist variables + call mpibcast(hist_hetfrz_classnuc, 1, mpilog, 0, mpicom) +#endif + +end subroutine hetfrz_classnuc_cam_readnl + +!================================================================================================ + +subroutine hetfrz_classnuc_cam_register() + + if (.not. use_hetfrz_classnuc) return + + ! pbuf fields provided by hetfrz_classnuc + call pbuf_add_field('FRZIMM', 'physpkg', dtype_r8, (/pcols,pver/), frzimm_idx) + call pbuf_add_field('FRZCNT', 'physpkg', dtype_r8, (/pcols,pver/), frzcnt_idx) + call pbuf_add_field('FRZDEP', 'physpkg', dtype_r8, (/pcols,pver/), frzdep_idx) + +end subroutine hetfrz_classnuc_cam_register + +!================================================================================================ + +subroutine hetfrz_classnuc_cam_init(mincld_in) + + real(r8), intent(in) :: mincld_in + + ! local variables + logical :: prog_modal_aero + integer :: m, n, nspec + integer :: istat + + real(r8) :: sigma_logr_aer + + character(len=32) :: str32 + character(len=*), parameter :: routine = 'hetfrz_classnuc_cam_init' + !-------------------------------------------------------------------------------------------- + + if (.not. use_hetfrz_classnuc) return + + ! This parameterization currently assumes that prognostic modal aerosols are on. Check... + call phys_getopts(prog_modal_aero_out=prog_modal_aero) + if (.not. prog_modal_aero) call endrun(routine//': cannot use hetfrz_classnuc without prognostic modal aerosols') + + mincld = mincld_in + + call cnst_get_ind('CLDLIQ', cldliq_idx) + call cnst_get_ind('CLDICE', cldice_idx) + call cnst_get_ind('NUMLIQ', numliq_idx) + call cnst_get_ind('NUMICE', numice_idx) + + ! pbuf fields used by hetfrz_classnuc + ast_idx = pbuf_get_index('AST') + + call addfld('bc_num', '#/cm3', pver, 'A', 'total bc number', phys_decomp) + call addfld('dst1_num', '#/cm3', pver, 'A', 'total dst1 number', phys_decomp) + call addfld('dst3_num', '#/cm3', pver, 'A', 'total dst3 number', phys_decomp) + call addfld('bcc_num', '#/cm3', pver, 'A', 'coated bc number', phys_decomp) + call addfld('dst1c_num', '#/cm3', pver, 'A', 'coated dst1 number', phys_decomp) + call addfld('dst3c_num', '#/cm3', pver, 'A', 'coated dst3 number', phys_decomp) + call addfld('bcuc_num', '#/cm3', pver, 'A', 'uncoated bc number', phys_decomp) + call addfld('dst1uc_num', '#/cm3', pver, 'A', 'uncoated dst1 number', phys_decomp) + call addfld('dst3uc_num', '#/cm3', pver, 'A', 'uncoated dst3 number', phys_decomp) + + call addfld('bc_a1_num', '#/cm3', pver, 'A', 'interstitial bc number', phys_decomp) + call addfld('dst_a1_num', '#/cm3', pver, 'A', 'interstitial dst1 number', phys_decomp) + call addfld('dst_a3_num', '#/cm3', pver, 'A', 'interstitial dst3 number', phys_decomp) + call addfld('bc_c1_num', '#/cm3', pver, 'A', 'cloud borne bc number', phys_decomp) + call addfld('dst_c1_num', '#/cm3', pver, 'A', 'cloud borne dst1 number', phys_decomp) + call addfld('dst_c3_num', '#/cm3', pver, 'A', 'cloud borne dst3 number', phys_decomp) + + call addfld('fn_bc_c1_num', '#/cm3', pver, 'A', 'cloud borne bc number derived from fn', phys_decomp) + call addfld('fn_dst_c1_num', '#/cm3', pver, 'A', 'cloud borne dst1 number derived from fn', phys_decomp) + call addfld('fn_dst_c3_num', '#/cm3', pver, 'A', 'cloud borne dst3 number derived from fn', phys_decomp) + + call addfld('na500', '#/cm3', pver, 'A', 'interstitial aerosol number with D>500 nm', phys_decomp) + call addfld('totna500', '#/cm3', pver, 'A', 'total aerosol number with D>500 nm', phys_decomp) + + call addfld('FREQIMM', 'fraction', pver, 'A', 'Fractional occurance of immersion freezing', phys_decomp) + call addfld('FREQCNT', 'fraction', pver, 'A', 'Fractional occurance of contact freezing', phys_decomp) + call addfld('FREQDEP', 'fraction', pver, 'A', 'Fractional occurance of deposition freezing', phys_decomp) + call addfld('FREQMIX', 'fraction', pver, 'A', 'Fractional occurance of mixed-phase clouds' , phys_decomp) + + call addfld('DSTFREZIMM', 'm-3s-1', pver, 'A', 'dust immersion freezing rate', phys_decomp) + call addfld('DSTFREZCNT', 'm-3s-1', pver, 'A', 'dust contact freezing rate', phys_decomp) + call addfld('DSTFREZDEP', 'm-3s-1', pver, 'A', 'dust deposition freezing rate', phys_decomp) + + call addfld('BCFREZIMM', 'm-3s-1', pver, 'A', 'bc immersion freezing rate', phys_decomp) + call addfld('BCFREZCNT', 'm-3s-1', pver, 'A', 'bc contact freezing rate', phys_decomp) + call addfld('BCFREZDEP', 'm-3s-1', pver, 'A', 'bc deposition freezing rate', phys_decomp) + + call addfld('NIMIX_IMM', '#/m3', pver, 'A', & + 'Activated Ice Number Concentration due to het immersion freezing in Mixed Clouds', phys_decomp) + call addfld('NIMIX_CNT', '#/m3', pver, 'A', & + 'Activated Ice Number Concentration due to het contact freezing in Mixed Clouds', phys_decomp) + call addfld('NIMIX_DEP', '#/m3', pver, 'A', & + 'Activated Ice Number Concentration due to het deposition freezing in Mixed Clouds', phys_decomp) + + call addfld('DSTNIDEP', '#/m3', pver, 'A', & + 'Activated Ice Number Concentration due to dst dep freezing in Mixed Clouds', phys_decomp) + call addfld('DSTNICNT', '#/m3', pver, 'A', & + 'Activated Ice Number Concentration due to dst cnt freezing in Mixed Clouds', phys_decomp) + call addfld('DSTNIIMM', '#/m3', pver, 'A', & + 'Activated Ice Number Concentration due to dst imm freezing in Mixed Clouds', phys_decomp) + + call addfld('BCNIDEP', '#/m3', pver, 'A', & + 'Activated Ice Number Concentration due to bc dep freezing in Mixed Clouds', phys_decomp) + call addfld('BCNICNT', '#/m3', pver, 'A', & + 'Activated Ice Number Concentration due to bc cnt freezing in Mixed Clouds', phys_decomp) + call addfld('BCNIIMM', '#/m3', pver, 'A', & + 'Activated Ice Number Concentration due to bc imm freezing in Mixed Clouds', phys_decomp) + + call addfld('NUMICE10s', '#/m3', pver, 'A', & + 'Ice Number Concentration due to het freezing in Mixed Clouds during 10-s period', phys_decomp) + call addfld('NUMIMM10sDST', '#/m3', pver, 'A', & + 'Ice Number Concentration due to imm freezing by dst in Mixed Clouds during 10-s period', phys_decomp) + call addfld('NUMIMM10sBC', '#/m3', pver, 'A', & + 'Ice Number Concentration due to imm freezing by bc in Mixed Clouds during 10-s period', phys_decomp) + + if (hist_hetfrz_classnuc) then + + call add_default('bc_num', 1, ' ') + call add_default('dst1_num', 1, ' ') + call add_default('dst3_num', 1, ' ') + call add_default('bcc_num', 1, ' ') + call add_default('dst1c_num', 1, ' ') + call add_default('dst3c_num', 1, ' ') + call add_default('bcuc_num', 1, ' ') + call add_default('dst1uc_num', 1, ' ') + call add_default('dst3uc_num', 1, ' ') + + call add_default('bc_a1_num', 1, ' ') + call add_default('dst_a1_num', 1, ' ') + call add_default('dst_a3_num', 1, ' ') + call add_default('bc_c1_num', 1, ' ') + call add_default('dst_c1_num', 1, ' ') + call add_default('dst_c3_num', 1, ' ') + + call add_default('fn_bc_c1_num', 1, ' ') + call add_default('fn_dst_c1_num', 1, ' ') + call add_default('fn_dst_c3_num', 1, ' ') + + call add_default('na500', 1, ' ') + call add_default('totna500', 1, ' ') + + call add_default('FREQIMM', 1, ' ') + call add_default('FREQCNT', 1, ' ') + call add_default('FREQDEP', 1, ' ') + call add_default('FREQMIX', 1, ' ') + + call add_default('DSTFREZIMM', 1, ' ') + call add_default('DSTFREZCNT', 1, ' ') + call add_default('DSTFREZDEP', 1, ' ') + + call add_default('BCFREZIMM', 1, ' ') + call add_default('BCFREZCNT', 1, ' ') + call add_default('BCFREZDEP', 1, ' ') + + call add_default('NIMIX_IMM', 1, ' ') + call add_default('NIMIX_CNT', 1, ' ') + call add_default('NIMIX_DEP', 1, ' ') + + call add_default('DSTNIDEP', 1, ' ') + call add_default('DSTNICNT', 1, ' ') + call add_default('DSTNIIMM', 1, ' ') + + call add_default('BCNIDEP', 1, ' ') + call add_default('BCNICNT', 1, ' ') + call add_default('BCNIIMM', 1, ' ') + + call add_default('NUMICE10s', 1, ' ') + call add_default('NUMIMM10sDST', 1, ' ') + call add_default('NUMIMM10sBC', 1, ' ') + + end if + + ! The following code sets indices of the mode specific species used + ! in the module. Having a list of the species needed allows us to + ! allocate temporary space for just those species rather than for all the + ! CAM species (pcnst) which may be considerably more than needed. + ! + ! The indices set below are for use with the CAM rad_constituents + ! interfaces. Using the rad_constituents interfaces isolates the physics + ! parameterization which requires constituent information from the chemistry + ! code which provides that information. + + ! nmodes is the total number of modes + call rad_cnst_get_info(0, nmodes=nmodes) + + ! Determine mode indices for all modes referenced in this module. + mode_accum_idx = rad_cnst_get_mode_idx(0, 'accum') + mode_coarse_idx = rad_cnst_get_mode_idx(0, 'coarse') + mode_finedust_idx = rad_cnst_get_mode_idx(0, 'fine_dust') + mode_coardust_idx = rad_cnst_get_mode_idx(0, 'coarse_dust') + mode_pcarbon_idx = rad_cnst_get_mode_idx(0, 'primary_carbon') + + ! Check that required mode types were found + if (nmodes == MAM3_nmodes) then + if (mode_accum_idx == -1 .or. mode_coarse_idx == -1) then + write(iulog,*) routine//': ERROR required mode type not found - mode idx:', & + mode_accum_idx, mode_coarse_idx + call endrun(routine//': ERROR required mode type not found') + end if + + else if (nmodes == MAM7_nmodes) then + if (mode_coardust_idx == -1 .or. mode_finedust_idx == -1 .or. mode_pcarbon_idx == -1) then + write(iulog,*) routine//': ERROR required mode type not found - mode idx:', & + mode_coardust_idx, mode_finedust_idx, mode_pcarbon_idx + call endrun(routine//': ERROR required mode type not found') + end if + end if + + ! Set some mode properties + + call rad_cnst_get_mode_props(0, mode_accum_idx, sigmag=sigma_logr_aer) + alnsg_mode_accum = log(sigma_logr_aer) + + if (nmodes == MAM3_nmodes) then + call rad_cnst_get_mode_props(0, mode_coarse_idx, sigmag=sigma_logr_aer) + alnsg_mode_coarse = log(sigma_logr_aer) + + else if (nmodes == MAM7_nmodes) then + call rad_cnst_get_mode_props(0, mode_finedust_idx, sigmag=sigma_logr_aer) + alnsg_mode_finedust = log(sigma_logr_aer) + + call rad_cnst_get_mode_props(0, mode_coardust_idx, sigmag=sigma_logr_aer) + alnsg_mode_coardust = log(sigma_logr_aer) + + call rad_cnst_get_mode_props(0, mode_pcarbon_idx, sigmag=sigma_logr_aer) + alnsg_mode_pcarbon = log(sigma_logr_aer) + end if + + ! Set list indices for all constituents (mass and number) used in this module. + ! The list is specific to the aerosol model used. Note that the order of the + ! constituents in these lists is arbitrary. + + if (nmodes == MAM3_nmodes) then + ncnst = 11 + so4_accum = 1 + bc_accum = 2 + pom_accum = 3 + soa_accum = 4 + dst_accum = 5 + ncl_accum = 6 + num_accum = 7 + dst_coarse = 8 + ncl_coarse = 9 + so4_coarse = 10 + num_coarse = 11 + else if (nmodes == MAM7_nmodes) then + ncnst = 15 + so4_accum = 1 + bc_accum = 2 + pom_accum = 3 + soa_accum = 4 + ncl_accum = 6 + num_accum = 7 + dst_finedust = 8 + so4_finedust = 9 + num_finedust = 10 + dst_coardust = 11 + so4_coardust = 12 + num_coardust = 13 + bc_pcarbon = 5 + pom_pcarbon = 14 + num_pcarbon = 15 + end if + + ! Allocate arrays to hold specie and mode indices for all constitutents (mass and number) + ! needed in this module. + allocate(mode_idx(ncnst), spec_idx(ncnst), stat=istat) + call alloc_err(istat, routine, 'mode_idx, spec_idx', ncnst) + mode_idx = -1 + spec_idx = -1 + + ! Allocate space for copy of cloud borne aerosols before modification by droplet nucleation. + allocate(aer_cb(pcols,pver,ncnst,begchunk:endchunk), stat=istat) + call alloc_err(istat, routine, 'aer_cb', pcols*pver*ncnst*(endchunk-begchunk+1)) + + ! Allocate space for copy of interstitial aerosols with modified basis + allocate(aer(pcols,pver,ncnst,begchunk:endchunk), stat=istat) + call alloc_err(istat, routine, 'aer', pcols*pver*ncnst*(endchunk-begchunk+1)) + + ! The following code sets the species and mode indices for each constituent + ! in the list. The indices are identical in the interstitial and the cloud + ! borne phases. + ! Specie index 0 is used to indicate the mode number mixing ratio + + ! Indices for species in accumulation mode (so4, bc, pom, soa, nacl, dust) + spec_idx(num_accum) = 0 + mode_idx(num_accum) = mode_accum_idx + spec_idx(so4_accum) = rad_cnst_get_spec_idx(0, mode_accum_idx, 'sulfate') + mode_idx(so4_accum) = mode_accum_idx + spec_idx(bc_accum) = rad_cnst_get_spec_idx(0, mode_accum_idx, 'black-c') + mode_idx(bc_accum) = mode_accum_idx + spec_idx(pom_accum) = rad_cnst_get_spec_idx(0, mode_accum_idx, 'p-organic') + mode_idx(pom_accum) = mode_accum_idx + spec_idx(soa_accum) = rad_cnst_get_spec_idx(0, mode_accum_idx, 's-organic') + mode_idx(soa_accum) = mode_accum_idx + spec_idx(ncl_accum) = rad_cnst_get_spec_idx(0, mode_accum_idx, 'seasalt') + mode_idx(ncl_accum) = mode_accum_idx + if (nmodes == MAM3_nmodes) then + spec_idx(dst_accum) = rad_cnst_get_spec_idx(0, mode_accum_idx, 'dust') + mode_idx(dst_accum) = mode_accum_idx + end if + + ! Indices for species in coarse mode (dust, nacl, so4) + if (mode_coarse_idx > 0) then + spec_idx(num_coarse) = 0 + mode_idx(num_coarse) = mode_coarse_idx + spec_idx(ncl_coarse) = rad_cnst_get_spec_idx(0, mode_coarse_idx, 'seasalt') + mode_idx(ncl_coarse) = mode_coarse_idx + spec_idx(dst_coarse) = rad_cnst_get_spec_idx(0, mode_coarse_idx, 'dust') + mode_idx(dst_coarse) = mode_coarse_idx + spec_idx(so4_coarse) = rad_cnst_get_spec_idx(0, mode_coarse_idx, 'sulfate') + mode_idx(so4_coarse) = mode_coarse_idx + end if + + ! Indices for species in fine dust mode (dust, so4) + if (mode_finedust_idx > 0) then + spec_idx(num_finedust) = 0 + mode_idx(num_finedust) = mode_finedust_idx + spec_idx(dst_finedust) = rad_cnst_get_spec_idx(0, mode_finedust_idx, 'dust') + mode_idx(dst_finedust) = mode_finedust_idx + spec_idx(so4_finedust) = rad_cnst_get_spec_idx(0, mode_finedust_idx, 'sulfate') + mode_idx(so4_finedust) = mode_finedust_idx + end if + + ! Indices for species in coarse dust mode (dust, so4) + if (mode_coardust_idx > 0) then + spec_idx(num_coardust) = 0 + mode_idx(num_coardust) = mode_coardust_idx + spec_idx(dst_coardust) = rad_cnst_get_spec_idx(0, mode_coardust_idx, 'dust') + mode_idx(dst_coardust) = mode_coardust_idx + spec_idx(so4_coardust) = rad_cnst_get_spec_idx(0, mode_coardust_idx, 'sulfate') + mode_idx(so4_coardust) = mode_coardust_idx + end if + + ! Indices for species in primary carbon mode (bc, pom) + if (mode_pcarbon_idx > 0) then + spec_idx(num_pcarbon) = 0 + mode_idx(num_pcarbon) = mode_pcarbon_idx + spec_idx(bc_pcarbon) = rad_cnst_get_spec_idx(0, mode_pcarbon_idx, 'black-c') + mode_idx(bc_pcarbon) = mode_pcarbon_idx + spec_idx(pom_pcarbon) = rad_cnst_get_spec_idx(0, mode_pcarbon_idx, 'p-organic') + mode_idx(pom_pcarbon) = mode_pcarbon_idx + end if + + ! Check that all required specie types were found + if (any(spec_idx == -1)) then + write(iulog,*) routine//': ERROR required species type not found - indicies:', spec_idx + call endrun(routine//': ERROR required species type not found') + end if + + ! Get some specie specific properties. + if (nmodes == MAM3_nmodes) then + call rad_cnst_get_aer_props(0, mode_idx(dst_accum), spec_idx(dst_accum), density_aer=specdens_dust) + else if (nmodes == MAM7_nmodes) then + call rad_cnst_get_aer_props(0, mode_idx(dst_finedust), spec_idx(dst_finedust), density_aer=specdens_dust) + end if + call rad_cnst_get_aer_props(0, mode_idx(so4_accum), spec_idx(so4_accum), density_aer=specdens_so4) + call rad_cnst_get_aer_props(0, mode_idx(bc_accum), spec_idx(bc_accum), density_aer=specdens_bc) + call rad_cnst_get_aer_props(0, mode_idx(soa_accum), spec_idx(soa_accum), density_aer=specdens_soa) + call rad_cnst_get_aer_props(0, mode_idx(pom_accum), spec_idx(pom_accum), density_aer=specdens_pom) + + call hetfrz_classnuc_init( & + rair, cpair, rh2o, rhoh2o, mwh2o, & + tmelt, pi, iulog) + +end subroutine hetfrz_classnuc_cam_init + +!================================================================================================ + +subroutine hetfrz_classnuc_cam_calc( & + state, deltatin, factnum, pbuf) + + ! arguments + type(physics_state), target, intent(in) :: state + real(r8), intent(in) :: deltatin ! time step (s) + real(r8), intent(in) :: factnum(:,:,:) ! activation fraction for aerosol number + type(physics_buffer_desc), pointer :: pbuf(:) + + ! local workspace + + ! outputs shared with the microphysics via the pbuf + real(r8), pointer :: frzimm(:,:) + real(r8), pointer :: frzcnt(:,:) + real(r8), pointer :: frzdep(:,:) + + integer :: itim_old + integer :: i, k + + real(r8) :: rho(pcols,pver) ! air density (kg m-3) + + real(r8), pointer :: ast(:,:) + + real(r8) :: lcldm(pcols,pver) + + real(r8), pointer :: ptr2d(:,:) + + real(r8) :: fn(3) + real(r8) :: awcam(pcols,pver,3) + real(r8) :: awfacm(pcols,pver,3) + real(r8) :: hetraer(pcols,pver,3) + real(r8) :: dstcoat(pcols,pver,3) + real(r8) :: total_interstitial_aer_num(pcols,pver,3) + real(r8) :: total_cloudborne_aer_num(pcols,pver,3) + real(r8) :: total_aer_num(pcols,pver,3) + real(r8) :: coated_aer_num(pcols,pver,3) + real(r8) :: uncoated_aer_num(pcols,pver,3) + + real(r8) :: fn_cloudborne_aer_num(pcols,pver,3) + + + real(r8) :: con1, r3lx, supersatice + + real(r8) :: qcic + real(r8) :: ncic + + real(r8) :: frzbcimm(pcols,pver), frzduimm(pcols,pver) + real(r8) :: frzbccnt(pcols,pver), frzducnt(pcols,pver) + real(r8) :: frzbcdep(pcols,pver), frzdudep(pcols,pver) + + real(r8) :: freqimm(pcols,pver), freqcnt(pcols,pver), freqdep(pcols,pver), freqmix(pcols,pver) + real(r8) :: nnuccc_bc(pcols,pver), nnucct_bc(pcols,pver), nnudep_bc(pcols,pver) + real(r8) :: nnuccc_dst(pcols,pver), nnucct_dst(pcols,pver), nnudep_dst(pcols,pver) + real(r8) :: niimm_bc(pcols,pver), nicnt_bc(pcols,pver), nidep_bc(pcols,pver) + real(r8) :: niimm_dst(pcols,pver), nicnt_dst(pcols,pver), nidep_dst(pcols,pver) + real(r8) :: numice10s(pcols,pver) + real(r8) :: numice10s_imm_dst(pcols,pver) + real(r8) :: numice10s_imm_bc(pcols,pver) + + real(r8) :: na500(pcols,pver) + real(r8) :: tot_na500(pcols,pver) + + character(128) :: errstring ! Error status + !------------------------------------------------------------------------------- + + associate( & + lchnk => state%lchnk, & + ncol => state%ncol, & + t => state%t, & + qc => state%q(:,:,cldliq_idx), & + nc => state%q(:,:,numliq_idx), & + pmid => state%pmid ) + + itim_old = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, ast_idx, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + + do k = top_lev, pver + do i = 1, ncol + rho(i,k) = pmid(i,k)/(rair*t(i,k)) + end do + end do + + do k = top_lev, pver + do i = 1, ncol + lcldm(i,k) = max(ast(i,k), mincld) + end do + end do + + ! Convert interstitial and cloud borne aerosols from a mass to a volume basis before + ! being used in get_aer_num + do i = 1, ncnst + aer_cb(:ncol,:,i,lchnk) = aer_cb(:ncol,:,i,lchnk) * rho(:ncol,:) + + ! Check whether constituent is a mass or number mixing ratio + if (spec_idx(i) == 0) then + call rad_cnst_get_mode_num(0, mode_idx(i), 'a', state, pbuf, ptr2d) + else + call rad_cnst_get_aer_mmr(0, mode_idx(i), spec_idx(i), 'a', state, pbuf, ptr2d) + end if + aer(:ncol,:,i,lchnk) = ptr2d(:ncol,:) * rho(:ncol,:) + end do + + ! Init top levels of outputs of get_aer_num + total_aer_num = 0._r8 + coated_aer_num = 0._r8 + uncoated_aer_num = 0._r8 + total_interstitial_aer_num = 0._r8 + total_cloudborne_aer_num = 0._r8 + hetraer = 0._r8 + awcam = 0._r8 + awfacm = 0._r8 + dstcoat = 0._r8 + na500 = 0._r8 + tot_na500 = 0._r8 + + ! output aerosols as reference information for heterogeneous freezing + do i = 1, ncol + do k = top_lev, pver + call get_aer_num(i, k, ncnst, aer(:,:,:,lchnk), aer_cb(:,:,:,lchnk), rho(i,k), & + total_aer_num(i,k,:), coated_aer_num(i,k,:), uncoated_aer_num(i,k,:), & + total_interstitial_aer_num(i,k,:), total_cloudborne_aer_num(i,k,:), & + hetraer(i,k,:), awcam(i,k,:), awfacm(i,k,:), dstcoat(i,k,:), & + na500(i,k), tot_na500(i,k)) + + fn_cloudborne_aer_num(i,k,1) = total_aer_num(i,k,1)*factnum(i,k,mode_accum_idx) ! bc + if (nmodes == MAM3_nmodes) then + fn_cloudborne_aer_num(i,k,2) = total_aer_num(i,k,2)*factnum(i,k,mode_accum_idx) ! dst_a1 + fn_cloudborne_aer_num(i,k,3) = total_aer_num(i,k,3)*factnum(i,k,mode_coarse_idx) ! dst_a3 + else if (nmodes == MAM7_nmodes) then + fn_cloudborne_aer_num(i,k,2) = total_aer_num(i,k,2)*factnum(i,k,mode_finedust_idx) + fn_cloudborne_aer_num(i,k,3) = total_aer_num(i,k,3)*factnum(i,k,mode_coardust_idx) + end if + end do + end do + + call outfld('bc_num', total_aer_num(:,:,1), pcols, lchnk) + call outfld('dst1_num', total_aer_num(:,:,2), pcols, lchnk) + call outfld('dst3_num', total_aer_num(:,:,3), pcols, lchnk) + + call outfld('bcc_num', coated_aer_num(:,:,1), pcols, lchnk) + call outfld('dst1c_num', coated_aer_num(:,:,2), pcols, lchnk) + call outfld('dst3c_num', coated_aer_num(:,:,3), pcols, lchnk) + + call outfld('bcuc_num', uncoated_aer_num(:,:,1), pcols, lchnk) + call outfld('dst1uc_num', uncoated_aer_num(:,:,2), pcols, lchnk) + call outfld('dst3uc_num', uncoated_aer_num(:,:,3), pcols, lchnk) + + call outfld('bc_a1_num', total_interstitial_aer_num(:,:,1), pcols, lchnk) + call outfld('dst_a1_num', total_interstitial_aer_num(:,:,2), pcols, lchnk) + call outfld('dst_a3_num', total_interstitial_aer_num(:,:,3), pcols, lchnk) + + call outfld('bc_c1_num', total_cloudborne_aer_num(:,:,1), pcols, lchnk) + call outfld('dst_c1_num', total_cloudborne_aer_num(:,:,2), pcols, lchnk) + call outfld('dst_c3_num', total_cloudborne_aer_num(:,:,3), pcols, lchnk) + + call outfld('fn_bc_c1_num', fn_cloudborne_aer_num(:,:,1), pcols, lchnk) + call outfld('fn_dst_c1_num', fn_cloudborne_aer_num(:,:,2), pcols, lchnk) + call outfld('fn_dst_c3_num', fn_cloudborne_aer_num(:,:,3), pcols, lchnk) + + call outfld('na500', na500, pcols, lchnk) + call outfld('totna500', tot_na500, pcols, lchnk) + + ! frzimm, frzcnt, frzdep are the outputs of this parameterization used by the microphysics + call pbuf_get_field(pbuf, frzimm_idx, frzimm) + call pbuf_get_field(pbuf, frzcnt_idx, frzcnt) + call pbuf_get_field(pbuf, frzdep_idx, frzdep) + + frzimm(:ncol,:) = 0._r8 + frzcnt(:ncol,:) = 0._r8 + frzdep(:ncol,:) = 0._r8 + + frzbcimm(:ncol,:) = 0._r8 + frzduimm(:ncol,:) = 0._r8 + frzbccnt(:ncol,:) = 0._r8 + frzducnt(:ncol,:) = 0._r8 + frzbcdep(:ncol,:) = 0._r8 + frzdudep(:ncol,:) = 0._r8 + + freqimm(:ncol,:) = 0._r8 + freqcnt(:ncol,:) = 0._r8 + freqdep(:ncol,:) = 0._r8 + freqmix(:ncol,:) = 0._r8 + + numice10s(:ncol,:) = 0._r8 + numice10s_imm_dst(:ncol,:) = 0._r8 + numice10s_imm_bc(:ncol,:) = 0._r8 + + do i = 1, ncol + do k = top_lev, pver + + if (t(i,k) > 235.15_r8 .and. t(i,k) < 269.15_r8) then + qcic = min(qc(i,k)/lcldm(i,k), 5.e-3_r8) + ncic = max(nc(i,k)/lcldm(i,k), 0._r8) + + con1 = 1._r8/(1.333_r8*pi)**0.333_r8 + r3lx = con1*(rho(i,k)*qcic/(rhoh2o*max(ncic*rho(i,k), 1.0e6_r8)))**0.333_r8 ! in m + r3lx = max(4.e-6_r8, r3lx) + supersatice = svp_water(t(i,k))/svp_ice(t(i,k)) + + fn(1) = factnum(i,k,mode_accum_idx) ! bc accumulation mode + if (nmodes == MAM3_nmodes) then + fn(2) = factnum(i,k,mode_accum_idx) ! dust_a1 accumulation mode + fn(3) = factnum(i,k,mode_coarse_idx) ! dust_a3 coarse mode + else if (nmodes == MAM7_nmodes) then + fn(2) = factnum(i,k,mode_finedust_idx) + fn(3) = factnum(i,k,mode_coardust_idx) + end if + + call hetfrz_classnuc_calc( & + deltatin, t(i,k), pmid(i,k), supersatice, & + fn, r3lx, ncic*rho(i,k)*1.0e-6_r8, frzbcimm(i,k), frzduimm(i,k), & + frzbccnt(i,k), frzducnt(i,k), frzbcdep(i,k), frzdudep(i,k), hetraer(i,k,:), & + awcam(i,k,:), awfacm(i,k,:), dstcoat(i,k,:), total_aer_num(i,k,:), & + coated_aer_num(i,k,:), uncoated_aer_num(i,k,:), total_interstitial_aer_num(i,k,:), & + total_cloudborne_aer_num(i,k,:), errstring) + + call handle_errmsg(errstring, subname="hetfrz_classnuc_calc") + + frzimm(i,k) = frzbcimm(i,k) + frzduimm(i,k) + frzcnt(i,k) = frzbccnt(i,k) + frzducnt(i,k) + frzdep(i,k) = frzbcdep(i,k) + frzdudep(i,k) + + if (frzimm(i,k) > 0._r8) freqimm(i,k) = 1._r8 + if (frzcnt(i,k) > 0._r8) freqcnt(i,k) = 1._r8 + if (frzdep(i,k) > 0._r8) freqdep(i,k) = 1._r8 + if ((frzimm(i,k) + frzcnt(i,k) + frzdep(i,k)) > 0._r8) freqmix(i,k) = 1._r8 + else + frzimm(i,k) = 0._r8 + frzcnt(i,k) = 0._r8 + frzdep(i,k) = 0._r8 + end if + + nnuccc_bc(i,k) = frzbcimm(i,k)*1.0e6_r8*ast(i,k) + nnucct_bc(i,k) = frzbccnt(i,k)*1.0e6_r8*ast(i,k) + nnudep_bc(i,k) = frzbcdep(i,k)*1.0e6_r8*ast(i,k) + + nnuccc_dst(i,k) = frzduimm(i,k)*1.0e6_r8*ast(i,k) + nnucct_dst(i,k) = frzducnt(i,k)*1.0e6_r8*ast(i,k) + nnudep_dst(i,k) = frzdudep(i,k)*1.0e6_r8*ast(i,k) + + niimm_bc(i,k) = frzbcimm(i,k)*1.0e6_r8*deltatin + nicnt_bc(i,k) = frzbccnt(i,k)*1.0e6_r8*deltatin + nidep_bc(i,k) = frzbcdep(i,k)*1.0e6_r8*deltatin + + niimm_dst(i,k) = frzduimm(i,k)*1.0e6_r8*deltatin + nicnt_dst(i,k) = frzducnt(i,k)*1.0e6_r8*deltatin + nidep_dst(i,k) = frzdudep(i,k)*1.0e6_r8*deltatin + + numice10s(i,k) = (frzimm(i,k)+frzcnt(i,k)+frzdep(i,k))*1.0e6_r8*deltatin*(10._r8/deltatin) + numice10s_imm_dst(i,k) = frzduimm(i,k)*1.0e6_r8*deltatin*(10._r8/deltatin) + numice10s_imm_bc(i,k) = frzbcimm(i,k)*1.0e6_r8*deltatin*(10._r8/deltatin) + end do + end do + + call outfld('FREQIMM', freqimm, pcols, lchnk) + call outfld('FREQCNT', freqcnt, pcols, lchnk) + call outfld('FREQDEP', freqdep, pcols, lchnk) + call outfld('FREQMIX', freqmix, pcols, lchnk) + + call outfld('DSTFREZIMM', nnuccc_dst, pcols, lchnk) + call outfld('DSTFREZCNT', nnucct_dst, pcols, lchnk) + call outfld('DSTFREZDEP', nnudep_dst, pcols, lchnk) + + call outfld('BCFREZIMM', nnuccc_bc, pcols, lchnk) + call outfld('BCFREZCNT', nnucct_bc, pcols, lchnk) + call outfld('BCFREZDEP', nnudep_bc, pcols, lchnk) + + call outfld('NIMIX_IMM', niimm_bc+niimm_dst, pcols, lchnk) + call outfld('NIMIX_CNT', nicnt_bc+nicnt_dst, pcols, lchnk) + call outfld('NIMIX_DEP', nidep_bc+nidep_dst, pcols, lchnk) + + call outfld('DSTNICNT', nicnt_dst, pcols, lchnk) + call outfld('DSTNIDEP', nidep_dst, pcols, lchnk) + call outfld('DSTNIIMM', niimm_dst, pcols, lchnk) + + call outfld('BCNICNT', nicnt_bc, pcols, lchnk) + call outfld('BCNIDEP', nidep_bc, pcols, lchnk) + call outfld('BCNIIMM', niimm_bc, pcols, lchnk) + + call outfld('NUMICE10s', numice10s, pcols, lchnk) + call outfld('NUMIMM10sDST', numice10s_imm_dst, pcols, lchnk) + call outfld('NUMIMM10sBC', numice10s_imm_bc, pcols, lchnk) + + end associate + +end subroutine hetfrz_classnuc_cam_calc + +!==================================================================================================== + +subroutine hetfrz_classnuc_cam_save_cbaero(state, pbuf) + + ! Save the required cloud borne aerosol constituents. + type(physics_state), intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + + ! local variables + integer :: i, lchnk + real(r8), pointer :: ptr2d(:,:) + !------------------------------------------------------------------------------- + + lchnk = state%lchnk + + ! loop over the cloud borne constituents required by this module and save + ! a local copy + + do i = 1, ncnst + + ! Check whether constituent is a mass or number mixing ratio + if (spec_idx(i) == 0) then + call rad_cnst_get_mode_num(0, mode_idx(i), 'c', state, pbuf, ptr2d) + else + call rad_cnst_get_aer_mmr(0, mode_idx(i), spec_idx(i), 'c', state, pbuf, ptr2d) + end if + aer_cb(:,:,i,lchnk) = ptr2d + end do + +end subroutine hetfrz_classnuc_cam_save_cbaero + +!==================================================================================================== + +subroutine get_aer_num(ii, kk, ncnst, aer, aer_cb, rhoair,& + total_aer_num, & + coated_aer_num, & + uncoated_aer_num, & + total_interstial_aer_num, & + total_cloudborne_aer_num, & + hetraer, awcam, awfacm, dstcoat, & + na500, tot_na500) + + !***************************************************************************** + ! Purpose: Calculate BC and Dust number, including total number(interstitial+ + ! cloud borne), one monolayer coated number, and uncoated number + ! + ! Author: Yong Wang and Xiaohong Liu, UWyo, 12/2012 + !***************************************************************************** + + ! input + integer, intent(in) :: ii, kk, ncnst + real(r8), intent(in) :: aer(pcols,pver,ncnst) ! interstitial aerosols, volume basis + real(r8), intent(in) :: aer_cb(pcols,pver,ncnst) ! cloud borne aerosols, volume basis + real(r8), intent(in) :: rhoair ! air density (kg/m3) + + ! The interstitial and cloud borne aerosol concentrations are accessed from + ! module variables local to this module. + + ! output + real(r8), intent(out) :: total_aer_num(3) ! #/cm^3 + real(r8), intent(out) :: total_interstial_aer_num(3) ! #/cm^3 + real(r8), intent(out) :: total_cloudborne_aer_num(3) ! #/cm^3 + real(r8), intent(out) :: coated_aer_num(3) ! #/cm^3 + real(r8), intent(out) :: uncoated_aer_num(3) ! #/cm^3 + real(r8), intent(out) :: hetraer(3) ! BC and Dust mass mean radius [m] + real(r8), intent(out) :: awcam(3) ! modal added mass [mug m-3] + real(r8), intent(out) :: awfacm(3) ! (OC+BC)/(OC+BC+SO4) + real(r8), intent(out) :: dstcoat(3) ! coated fraction + real(r8), intent(out) :: na500 ! #/cm^3 interstitial aerosol number with D>500 nm (#/cm^3) + real(r8), intent(out) :: tot_na500 ! #/cm^3 total aerosol number with D>500 nm (#/cm^3) + + + !local variables + !------------coated variables-------------------- + real(r8), parameter :: n_so4_monolayers_dust = 1.0_r8 ! number of so4(+nh4) monolayers needed to coat a dust particle + real(r8), parameter :: dr_so4_monolayers_dust = n_so4_monolayers_dust * 4.76e-10_r8 + real(r8), parameter :: spechygro_so4 = 0.507_r8 ! Sulfate hygroscopicity + real(r8), parameter :: spechygro_soa = 0.14_r8 ! SOA hygroscopicity + real(r8), parameter :: spechygro_pom = 0.1_r8 ! POM hygroscopicity + real(r8), parameter :: soa_equivso4_factor = spechygro_soa/spechygro_so4 + real(r8), parameter :: pom_equivso4_factor = spechygro_pom/spechygro_so4 + real(r8) :: vol_shell(3) + real(r8) :: vol_core(3) + real(r8) :: fac_volsfc_dust_a1, fac_volsfc_dust_a3, fac_volsfc_bc + real(r8) :: tmp1, tmp2 + real(r8) :: bc_num ! bc number in accumulation mode for MAM3 + ! bc number in accumulation and primary carbon mode for MAM7 + real(r8) :: dst1_num, dst3_num ! dust number in accumulation and corase mode for MAM3 + ! dust number in fine dust and corase dust mode for MAM7 + logical :: num_to_mass_in = .true. + real(r8), parameter :: bc_num_to_mass = 4.669152e+17_r8 ! #/kg from emission + real(r8), parameter :: dst1_num_to_mass = 3.484e+15_r8 ! #/kg for dust in accumulation mode + + real(r8) :: dmc, ssmc + + real(r8) :: as_so4, as_du, as_soa + real(r8) :: dst1_num_imm, dst3_num_imm, bc_num_imm + real(r8) :: dmc_imm, ssmc_imm + real(r8) :: as_bc, as_pom, as_ss + + real(r8) :: r_bc ! model radii of BC modes [m] + real(r8) :: r_dust_a1, r_dust_a3 ! model radii of dust modes [m] + + integer :: i + real(r8) :: dst1_scale + !------------------------------------------------------------------------------- + + ! init output vars + total_aer_num = 0._r8 + total_interstial_aer_num = 0._r8 + total_cloudborne_aer_num = 0._r8 + coated_aer_num = 0._r8 + uncoated_aer_num = 0._r8 + hetraer = 0._r8 + awcam = 0._r8 + awfacm = 0._r8 + dstcoat = 0._r8 + na500 = 0._r8 + tot_na500 = 0._r8 + + !***************************************************************************** + ! calculate intersitial aerosol + !***************************************************************************** + + if (nmodes == MAM3_nmodes) then + + if (.not. num_to_mass_in) then + + as_so4 = aer(ii,kk,so4_accum) + as_bc = aer(ii,kk,bc_accum) + as_pom = aer(ii,kk,pom_accum) + as_soa = aer(ii,kk,soa_accum) + as_ss = aer(ii,kk,ncl_accum) + as_du = aer(ii,kk,dst_accum) + + if (as_du > 0._r8) then + dst1_num = as_du/(as_so4+as_bc+as_pom+as_soa+as_ss+as_du) & + * aer(ii,kk,num_accum)*1.0e-6_r8 ! #/cm^3 + else + dst1_num = 0.0_r8 + end if + + if (as_bc > 0._r8) then + bc_num = as_bc/(as_so4+as_bc+as_pom+as_soa+as_ss+as_du) & + * aer(ii,kk,num_accum)*1.0e-6_r8 ! #/cm^3 + else + bc_num = 0.0_r8 + end if + + else + + dst1_num = aer(ii,kk,dst_accum) * dst1_num_to_mass*1.0e-6_r8 ! #/cm^3, dust # in accumulation mode + bc_num = aer(ii,kk,bc_accum) * bc_num_to_mass*1.0e-6_r8 ! #/cm^3 + end if + dmc = aer(ii,kk,dst_coarse) + ssmc = aer(ii,kk,ncl_coarse) + + if (dmc > 0._r8 ) then + dst3_num = dmc/(ssmc+dmc) * aer(ii,kk,num_coarse)*1.0e-6_r8 ! #/cm^3 + else + dst3_num = 0.0_r8 + end if + + else if (nmodes == MAM7_nmodes) then + bc_num = (aer(ii,kk,bc_accum)+aer(ii,kk,bc_pcarbon)) * bc_num_to_mass*1.0e-6_r8 ! #/cm^3 + dst1_num = aer(ii,kk,num_finedust)*1.0e-6_r8 ! #/cm^3 + dst3_num = aer(ii,kk,num_coardust)*1.0e-6_r8 ! #/cm^3 + end if + + !***************************************************************************** + ! calculate cloud borne aerosol + !***************************************************************************** + + if (nmodes == MAM3_nmodes) then + + as_so4 = aer_cb(ii,kk,so4_accum) + as_bc = aer_cb(ii,kk,bc_accum) + as_pom = aer_cb(ii,kk,pom_accum) + as_soa = aer_cb(ii,kk,soa_accum) + as_ss = aer_cb(ii,kk,ncl_accum) + as_du = aer_cb(ii,kk,dst_accum) + + if (as_du > 0._r8) then + dst1_num_imm = as_du/(as_so4+as_bc+as_pom+as_soa+as_ss+as_du) & + * aer_cb(ii,kk,num_accum)*1.0e-6_r8 ! #/cm^3 + else + dst1_num_imm = 0.0_r8 + end if + + if (as_bc > 0._r8) then + bc_num_imm = as_bc/(as_so4+as_bc+as_pom+as_soa+as_ss+as_du) & + * aer_cb(ii,kk,num_accum)*1.0e-6_r8 ! #/cm^3 + else + bc_num_imm = 0.0_r8 + end if + + dmc_imm = aer_cb(ii,kk,dst_coarse) + ssmc_imm = aer_cb(ii,kk,ncl_coarse) + + if (dmc_imm > 0._r8) then + dst3_num_imm = dmc_imm/(ssmc_imm+dmc_imm) * aer_cb(ii,kk,num_coarse)*1.0e-6_r8 ! #/cm^3 + else + dst3_num_imm = 0.0_r8 + end if + + else if (nmodes == MAM7_nmodes) then + ! primary carbon mode is insoluble and thus don't consider its cloud-borne state + as_so4 = aer_cb(ii,kk,so4_accum) + as_bc = aer_cb(ii,kk,bc_accum) + as_pom = aer_cb(ii,kk,pom_accum) + as_soa = aer_cb(ii,kk,soa_accum) + as_ss = aer_cb(ii,kk,ncl_accum) + if (as_bc > 0._r8) then + bc_num_imm = as_bc/(as_so4+as_bc+as_pom+as_soa+as_ss) & + * aer_cb(ii,kk,num_accum)*1.0e-6_r8 ! #/cm^3 + else + bc_num_imm = 0.0_r8 + end if + dst1_num_imm = aer_cb(ii,kk,num_finedust)*1.0e-6_r8 ! #/cm^3 + dst3_num_imm = aer_cb(ii,kk,num_coardust)*1.0e-6_r8 ! #/cm^3 + end if + + total_interstial_aer_num(1) = bc_num + total_interstial_aer_num(2) = dst1_num + total_interstial_aer_num(3) = dst3_num + + total_cloudborne_aer_num(1) = bc_num_imm + total_cloudborne_aer_num(2) = dst1_num_imm + total_cloudborne_aer_num(3) = dst3_num_imm + + !***************************************************************************** + ! calculate mass mean radius + !***************************************************************************** + + if (nmodes == MAM3_nmodes) then + + if (aer(ii,kk,bc_accum)*1.0e-3_r8 > 1.0e-30_r8 .and. bc_num > 1.0e-3_r8) then + r_bc = ( 3._r8/(4*pi*specdens_bc)*aer(ii,kk,bc_accum)/(bc_num*1.0e6_r8) )**(1._r8/3._r8) + else + r_bc = 0.04e-6_r8 + end if + + if (aer(ii,kk,dst_accum)*1.0e-3_r8 > 1.0e-30_r8 .and. dst1_num > 1.0e-3_r8) then + r_dust_a1 = ( 3._r8/(4*pi*specdens_dust)*aer(ii,kk,dst_accum)/(dst1_num*1.0e6_r8) )**(1._r8/3._r8) + else + r_dust_a1 = 0.258e-6_r8 + end if + + if (aer(ii,kk,dst_coarse)*1.0e-3_r8 > 1.0e-30_r8 .and. dst3_num > 1.0e-3_r8) then + r_dust_a3 = ( 3._r8/(4*pi*specdens_dust)*aer(ii,kk,dst_coarse)/(dst3_num*1.0e6_r8) )**(1._r8/3._r8) + else + r_dust_a3 = 1.576e-6_r8 + end if + + else if (nmodes == MAM7_nmodes) then + + if ((aer(ii,kk,bc_accum)+aer(ii,kk,bc_pcarbon))*1.0e-3_r8 > 1.0e-30_r8 & + .and. bc_num > 1.0e-3_r8) then + r_bc = ( 3._r8/(4*pi*specdens_bc)*(aer(ii,kk,bc_accum)+aer(ii,kk,bc_pcarbon))/ & + (bc_num*1.0e6_r8) )**(1._r8/3._r8) + else + r_bc = 0.067e-6_r8 ! from emission size + end if + + if (aer(ii,kk,dst_finedust)*1.0e-3_r8 > 1.0e-30_r8 .and. dst1_num > 1.0e-3_r8) then + r_dust_a1 = ( 3._r8/(4*pi*specdens_dust)*aer(ii,kk,dst_finedust)/(dst1_num*1.0e6_r8) )**(1._r8/3._r8) + else + r_dust_a1 = 0.258e-6_r8 + end if + + if (aer(ii,kk,dst_coardust)*1.0e-3_r8 > 1.0e-30_r8 .and. dst3_num > 1.0e-3_r8) then + r_dust_a3 = ( 3._r8/(4*pi*specdens_dust)*aer(ii,kk,dst_coardust)/(dst3_num*1.0e6_r8) )**(1._r8/3._r8) + else + r_dust_a3 = 1.576e-6_r8 + end if + end if + + hetraer(1) = r_bc + hetraer(2) = r_dust_a1 + hetraer(3) = r_dust_a3 + + !***************************************************************************** + ! calculate coated fraction + !***************************************************************************** + + if (nmodes == MAM3_nmodes) then + + fac_volsfc_bc = exp(2.5_r8*alnsg_mode_accum**2) + fac_volsfc_dust_a1 = exp(2.5_r8*alnsg_mode_accum**2) + fac_volsfc_dust_a3 = exp(2.5_r8*alnsg_mode_coarse**2) + + vol_shell(2) = ( aer(ii,kk,so4_accum)/specdens_so4 + & + aer(ii,kk,pom_accum)*pom_equivso4_factor/specdens_pom + & + aer(ii,kk,soa_accum)*soa_equivso4_factor/specdens_soa )/rhoair + + vol_core(2) = aer(ii,kk,dst_accum)/(specdens_dust*rhoair) + + ! ratio1 = vol_shell/vol_core = + ! actual hygroscopic-shell-volume/dust-core-volume + ! ratio2 = 6.0_r8*dr_so4_monolayers_pcage/(dgncur_a*fac_volsfc_dust) + ! = (shell-volume corresponding to n_so4_monolayers_pcage)/core-volume + ! The 6.0/(dgncur_a*fac_volsfc_dust) = (mode-surface-area/mode-volume) + ! Note that vol_shell includes both so4, pom, AND soa as "equivalent so4", + ! The soa_equivso4_factor accounts for the lower hygroscopicity of soa. + ! + ! Define xferfrac_pcage = min( 1.0, ratio1/ratio2) + ! But ratio1/ratio2 == tmp1/tmp2, and coding below avoids possible overflow + + ! bc + vol_shell(1) = vol_shell(2) + vol_core(1) = aer(ii,kk,bc_accum)/(specdens_bc*rhoair) + tmp1 = vol_shell(1)*(r_bc*2._r8)*fac_volsfc_bc + tmp2 = max(6.0_r8*dr_so4_monolayers_dust*vol_core(1), 0.0_r8) + dstcoat(1) = tmp1/tmp2 + + ! dust_a1 + tmp1 = vol_shell(2)*(r_dust_a1*2._r8)*fac_volsfc_dust_a1 + tmp2 = max(6.0_r8*dr_so4_monolayers_dust*vol_core(2), 0.0_r8) + dstcoat(2) = tmp1/tmp2 + + ! dust_a3 + vol_shell(3) = aer(ii,kk,so4_coarse)/(specdens_so4*rhoair) + vol_core(3) = aer(ii,kk,dst_coarse)/(specdens_dust*rhoair) + tmp1 = vol_shell(3)*(r_dust_a3*2._r8)*fac_volsfc_dust_a3 + tmp2 = max(6.0_r8*dr_so4_monolayers_dust*vol_core(3), 0.0_r8) + dstcoat(3) = tmp1/tmp2 + + else if (nmodes == MAM7_nmodes) then + + ! for BC, only consider primary carbon mode, + ! because most of particles in this mode are uncoated + ! and nearly all particles in accumulation mode are coated + fac_volsfc_bc = exp(2.5_r8*alnsg_mode_pcarbon**2) + + vol_shell(1) = ( aer(ii,kk,pom_pcarbon)*pom_equivso4_factor/specdens_pom )/rhoair + vol_core(1) = aer(ii,kk,bc_pcarbon)/(specdens_bc*rhoair) + tmp1 = vol_shell(1)*(r_bc*2._r8)*fac_volsfc_bc + tmp2 = max(6.0_r8*dr_so4_monolayers_dust*vol_core(1), 0.0_r8) + dstcoat(1) = tmp1/tmp2 + + fac_volsfc_dust_a1 = exp(2.5_r8*alnsg_mode_finedust**2) + fac_volsfc_dust_a3 = exp(2.5_r8*alnsg_mode_coardust**2) + + vol_shell(2) = aer(ii,kk,so4_finedust)/(specdens_so4*rhoair) + vol_core(2) = aer(ii,kk,dst_finedust)/(specdens_dust*rhoair) + + tmp1 = vol_shell(2)*(r_dust_a1*2._r8)*fac_volsfc_dust_a1 + tmp2 = max(6.0_r8*dr_so4_monolayers_dust*vol_core(2), 0.0_r8) + dstcoat(2) = tmp1/tmp2 + + vol_shell(3) = aer(ii,kk,so4_coardust)/(specdens_so4*rhoair) + vol_core(3) = aer(ii,kk,dst_coardust)/(specdens_dust*rhoair) + tmp1 = vol_shell(3)*(r_dust_a3*2._r8)*fac_volsfc_dust_a3 + tmp2 = max(6.0_r8*dr_so4_monolayers_dust*vol_core(3), 0.0_r8) + dstcoat(3) = tmp1/tmp2 + + end if + + if (dstcoat(1) > 1._r8) dstcoat(1) = 1._r8 + if (dstcoat(1) < 0.001_r8) dstcoat(1) = 0.001_r8 + if (dstcoat(2) > 1._r8) dstcoat(2) = 1._r8 + if (dstcoat(2) < 0.001_r8) dstcoat(2) = 0.001_r8 + if (dstcoat(3) > 1._r8) dstcoat(3) = 1._r8 + if (dstcoat(3) < 0.001_r8) dstcoat(3) = 0.001_r8 + + do i = 1, 3 + total_aer_num(i) = total_interstial_aer_num(i) + total_cloudborne_aer_num(i) + coated_aer_num(i) = total_interstial_aer_num(i)*dstcoat(i) + uncoated_aer_num(i) = total_interstial_aer_num(i)*(1._r8-dstcoat(i)) + end do + + if (nmodes == MAM7_nmodes) then + coated_aer_num(1) = (aer(ii,kk,bc_pcarbon)*bc_num_to_mass*1.0e-6_r8)*dstcoat(1)+ & + (aer(ii,kk,bc_accum)*bc_num_to_mass*1.0e-6_r8) + uncoated_aer_num(1) = (aer(ii,kk,bc_pcarbon)*bc_num_to_mass*1.0e-6_r8)*(1._r8-dstcoat(1)) + end if + + if (nmodes == MAM3_nmodes) then + dst1_scale = 0.488_r8 ! scaled for D>0.5-1 um from 0.1-1 um + else if (nmodes == MAM7_nmodes) then + dst1_scale = 0.566_r8 ! scaled for D>0.5-2 um from 0.1-2 um + end if + + tot_na500 = total_aer_num(1)*0.0256_r8 & ! scaled for D>0.5 um using Clarke et al., 1997; 2004; 2007: rg=0.1um, sig=1.6 + + total_aer_num(2)*dst1_scale + total_aer_num(3) + + na500 = total_interstial_aer_num(1)*0.0256_r8 & ! scaled for D>0.5 um using Clarke et al., 1997; 2004; 2007: rg=0.1um, sig=1.6 + + total_interstial_aer_num(2)*dst1_scale + total_interstial_aer_num(3) + + !***************************************************************************** + ! prepare some variables for water activity + !***************************************************************************** + + if (nmodes == MAM3_nmodes) then + + ! accumulation mode for dust_a1 + if (aer(ii,kk,num_accum) > 0._r8) then + awcam(2) = (dst1_num*1.0e6_r8)/aer(ii,kk,num_accum)* & + ( aer(ii,kk,so4_accum) + aer(ii,kk,soa_accum) + & + aer(ii,kk,pom_accum) + aer(ii,kk,bc_accum) )*1.0e9_r8 ! [mug m-3] + else + awcam(2) = 0._r8 + end if + + if (awcam(2) > 0._r8) then + awfacm(2) = ( aer(ii,kk,bc_accum) + aer(ii,kk,soa_accum) + aer(ii,kk,pom_accum) )/ & + ( aer(ii,kk,soa_accum) + aer(ii,kk,pom_accum) + aer(ii,kk,so4_accum) + aer(ii,kk,bc_accum) ) + else + awfacm(2) = 0._r8 + end if + + ! accumulation mode for bc + if (aer(ii,kk,num_accum) > 0._r8) then + awcam(1) = (bc_num*1.0e6_r8)/aer(ii,kk,num_accum)* & + ( aer(ii,kk,so4_accum) + aer(ii,kk,soa_accum) + aer(ii,kk,pom_accum) + aer(ii,kk,bc_accum) )*1.0e9_r8 ! [mug m-3] + else + awcam(1) = 0._r8 + end if + awfacm(1) = awfacm(2) + + ! coarse mode for dust_a3 + if (aer(ii,kk,num_coarse) > 0._r8) then + awcam(3) = (dst3_num*1.0e6_r8)/aer(ii,kk,num_coarse)* aer(ii,kk,so4_coarse)*1.0e9_r8 + else + awcam(3) = 0._r8 + end if + awfacm(3) = 0._r8 + + else if (nmodes == MAM7_nmodes) then + + ! accumulation mode for bc (primary carbon mode is insoluble) + if (aer(ii,kk,num_accum) > 0._r8) then + awcam(1) = (bc_num*1.0e6_r8)/aer(ii,kk,num_accum)* & + ( aer(ii,kk,so4_accum) + aer(ii,kk,soa_accum) + aer(ii,kk,pom_accum) + aer(ii,kk,bc_accum) )*1.0e9_r8 ! [mug m-3] + else + awcam(1) = 0._r8 + end if + + if (awcam(1) > 0._r8) then + awfacm(1) = ( aer(ii,kk,bc_accum) + aer(ii,kk,soa_accum) + aer(ii,kk,pom_accum) )/ & + ( aer(ii,kk,soa_accum) + aer(ii,kk,pom_accum) + aer(ii,kk,so4_accum) + aer(ii,kk,bc_accum) ) + else + awfacm(1) = 0._r8 + end if + + if (aer(ii,kk,num_finedust) > 0._r8) then + awcam(2) = (dst1_num*1.0e6_r8)/aer(ii,kk,num_finedust)* aer(ii,kk,so4_finedust)*1.0e9_r8 + else + awcam(2) = 0._r8 + end if + awfacm(2) = 0._r8 + + if (aer(ii,kk,num_coardust) > 0._r8) then + awcam(3) = (dst3_num*1.0e6_r8)/aer(ii,kk,num_coardust)* aer(ii,kk,so4_coardust)*1.0e9_r8 + else + awcam(3) = 0._r8 + end if + awfacm(3) = 0._r8 + + end if + +end subroutine get_aer_num + +!==================================================================================================== + +end module hetfrz_classnuc_cam diff --git a/models/atm/cam/src/physics/cam/macrop_driver.F90 b/models/atm/cam/src/physics/cam/macrop_driver.F90 index bc42e1fb274e..046c48938d3a 100644 --- a/models/atm/cam/src/physics/cam/macrop_driver.F90 +++ b/models/atm/cam/src/physics/cam/macrop_driver.F90 @@ -13,11 +13,14 @@ module macrop_driver use shr_kind_mod, only: r8=>shr_kind_r8 use spmd_utils, only: masterproc use ppgrid, only: pcols, pver, pverp - use physconst, only: latice + use physconst, only: latice, latvap use phys_control, only: phys_getopts use constituents, only: cnst_get_ind, pcnst - use perf_mod, only: t_startf, t_stopf - use cam_logfile, only: iulog + use physics_buffer, only: physics_buffer_desc, pbuf_set_field, pbuf_get_field, pbuf_old_tim_idx + use time_manager, only: is_first_step + use cldwat2m_macro, only: ini_macro + use perf_mod, only: t_startf, t_stopf + use cam_logfile, only: iulog use cam_abortutils, only: endrun implicit none @@ -28,6 +31,7 @@ module macrop_driver public :: macrop_driver_register public :: macrop_driver_init public :: macrop_driver_tend + public :: ice_macro_tend logical, public :: do_cldice ! .true., park macrophysics is prognosing cldice logical, public :: do_cldliq ! .true., park macrophysics is prognosing cldliq @@ -42,13 +46,17 @@ module macrop_driver ! evaporate cumulus liquid condensate. This option only influences the treatment of cumulus ! liquid condensate, not cumulus ice condensate. - logical, private, parameter :: cu_det_st = .false. + logical, parameter :: cu_det_st = .false. - ! -------------------------------- ! - ! End of Private Module Parameters ! - ! -------------------------------- ! + logical :: micro_do_icesupersat - logical :: use_shfrc ! Local copy of flag from convect_shallow_use_shfrc + ! Parameters used for selecting generalized critical RH for liquid and ice stratus + integer :: rhminl_opt = 0 + integer :: rhmini_opt = 0 + + + character(len=16) :: shallow_scheme + logical :: use_shfrc ! Local copy of flag from convect_shallow_use_shfrc integer :: & ixcldliq, &! cloud liquid amount index @@ -77,8 +85,16 @@ module macrop_driver concld_idx, &! concld index in physics buffer fice_idx, & cmeliq_idx, & - shfrc_idx - + shfrc_idx, & + naai_idx + + integer :: & + tke_idx = -1, &! tke defined at the model interfaces + qtl_flx_idx = -1, &! overbar(w'qtl' where qtl = qv + ql) from the PBL scheme + qti_flx_idx = -1, &! overbar(w'qti' where qti = qv + qi) from the PBL scheme + cmfr_det_idx = -1, &! detrained convective mass flux from UNICON + qlr_det_idx = -1, &! detrained convective ql from UNICON + qir_det_idx = -1 ! detrained convective qi from UNICON contains @@ -92,16 +108,15 @@ subroutine macrop_driver_readnl(nlfile) character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input ! Namelist variables - logical :: macro_park_do_cldice = .true. ! do_cldice = .true., park macrophysics is prognosing cldice - logical :: macro_park_do_cldliq = .true. ! do_cldliq = .true., park macrophysics is prognosing cldliq - logical :: macro_park_do_detrain = .true. ! do_detrain = .true., park macrophysics is detraining ice into stratiform + logical :: macro_park_do_cldice = .true. ! do_cldice = .true., park macrophysics is prognosing cldice + logical :: macro_park_do_cldliq = .true. ! do_cldliq = .true., park macrophysics is prognosing cldliq + logical :: macro_park_do_detrain = .true. ! do_detrain = .true., park macrophysics is detraining ice into stratiform ! Local variables integer :: unitn, ierr character(len=*), parameter :: subname = 'macrop_driver_readnl' namelist /macro_park_nl/ macro_park_do_cldice, macro_park_do_cldliq, macro_park_do_detrain - !----------------------------------------------------------------------------- if (masterproc) then @@ -125,13 +140,11 @@ subroutine macrop_driver_readnl(nlfile) end if - - #ifdef SPMD ! Broadcast namelist variables - call mpibcast(do_cldice, 1, mpilog, 0, mpicom) - call mpibcast(do_cldliq, 1, mpilog, 0, mpicom) - call mpibcast(do_detrain, 1, mpilog, 0, mpicom) + call mpibcast(do_cldice, 1, mpilog, 0, mpicom) + call mpibcast(do_cldliq, 1, mpilog, 0, mpicom) + call mpibcast(do_detrain, 1, mpilog, 0, mpicom) #endif end subroutine macrop_driver_readnl @@ -152,6 +165,8 @@ subroutine macrop_driver_register !----------------------------------------------------------------------- + call phys_getopts(shallow_scheme_out=shallow_scheme) + call pbuf_add_field('AST', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), ast_idx) call pbuf_add_field('AIST', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), aist_idx) call pbuf_add_field('ALST', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), alst_idx) @@ -177,7 +192,7 @@ end subroutine macrop_driver_register ! ! !============================================================================ ! - subroutine macrop_driver_init() + subroutine macrop_driver_init(pbuf2d) !-------------------------------------------- ! ! ! @@ -188,21 +203,25 @@ subroutine macrop_driver_init() use cam_history, only: addfld, add_default, phys_decomp use convect_shallow, only: convect_shallow_use_shfrc - + type(physics_buffer_desc), pointer :: pbuf2d(:,:) logical :: history_aerosol ! Output the MAM aerosol tendencies logical :: history_budget ! Output tendencies and state variables for CAM4 ! temperature, water vapor, cloud ice and cloud ! liquid budgets. integer :: history_budget_histfile_num ! output history file number for budget fields + integer :: istat + character(len=*), parameter :: subname = 'macrop_driver_init' + !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - - call phys_getopts( history_aerosol_out = history_aerosol , & - history_budget_out = history_budget , & - history_budget_histfile_num_out = history_budget_histfile_num) + ! Initialization routine for cloud macrophysics + if (shallow_scheme .eq. 'UNICON') rhminl_opt = 1 + call ini_macro(rhminl_opt, rhmini_opt) - ! Initialization routine for cloud macrophysics + call phys_getopts(history_aerosol_out = history_aerosol , & + history_budget_out = history_budget , & + history_budget_histfile_num_out = history_budget_histfile_num, & + micro_do_icesupersat_out = micro_do_icesupersat) ! Find out whether shfrc from convect_shallow will be used in cldfrc @@ -213,7 +232,6 @@ subroutine macrop_driver_init() use_shfrc = .false. endif - call addfld ('DPDLFLIQ ', 'kg/kg/s ', pver, 'A', 'Detrained liquid water from deep convection' ,phys_decomp) call addfld ('DPDLFICE ', 'kg/kg/s ', pver, 'A', 'Detrained ice from deep convection' ,phys_decomp) call addfld ('SHDLFLIQ ', 'kg/kg/s ', pver, 'A', 'Detrained liquid water from shallow convection' ,phys_decomp) @@ -246,15 +264,21 @@ subroutine macrop_driver_init() call addfld ('CLDST ', 'fraction', pver, 'A', 'Stratus cloud fraction' ,phys_decomp) call addfld ('CONCLD ', 'fraction', pver, 'A', 'Convective cloud cover' ,phys_decomp) + call addfld ('CLR_LIQ', 'fraction', pver, 'A', 'Clear sky fraction for liquid stratus' , phys_decomp) + call addfld ('CLR_ICE', 'fraction', pver, 'A', 'Clear sky fraction for ice stratus' , phys_decomp) + call addfld ('CLDLIQSTR ', 'kg/kg', pver, 'A', 'Stratiform CLDLIQ' ,phys_decomp) call addfld ('CLDICESTR ', 'kg/kg', pver, 'A', 'Stratiform CLDICE' ,phys_decomp) call addfld ('CLDLIQCON ', 'kg/kg', pver, 'A', 'Convective CLDLIQ' ,phys_decomp) call addfld ('CLDICECON ', 'kg/kg', pver, 'A', 'Convective CLDICE' ,phys_decomp) call addfld ('CLDSICE ', 'kg/kg ', pver, 'A', 'CloudSat equivalent ice mass mixing ratio' ,phys_decomp) - call addfld ('CMELIQ ', 'kg/kg/s ', pver, 'A', 'Rate of cond-evap of liq within the cloud' ,phys_decomp) + call addfld ('TTENDICE', 'K/s ', pver, 'A', 'T tendency from Ice Saturation Adjustment' ,phys_decomp) + call addfld ('QVTENDICE', 'kg/kg/s ', pver, 'A', 'Q tendency from Ice Saturation Adjustment' ,phys_decomp) + call addfld ('QITENDICE', 'kg/kg/s ', pver, 'A', 'CLDICE tendency from Ice Saturation Adjustment' ,phys_decomp) + call addfld ('NITENDICE', 'kg/kg/s ', pver, 'A', 'NUMICE tendency from Ice Saturation Adjustment' ,phys_decomp) if ( history_budget ) then call add_default ('DPDLFLIQ ', history_budget_histfile_num, ' ') @@ -297,6 +321,49 @@ subroutine macrop_driver_init() CC_ni_idx = pbuf_get_index('CC_ni') CC_qlst_idx = pbuf_get_index('CC_qlst') + if (micro_do_icesupersat) then + naai_idx = pbuf_get_index('NAAI') + endif + + if (rhminl_opt > 0 .or. rhmini_opt > 0) then + cmfr_det_idx = pbuf_get_index('cmfr_det', istat) + if (istat < 0) call endrun(subname//': macrop option requires cmfr_det in pbuf') + if (rhminl_opt > 0) then + qlr_det_idx = pbuf_get_index('qlr_det', istat) + if (istat < 0) call endrun(subname//': macrop option requires qlr_det in pbuf') + end if + if (rhmini_opt > 0) then + qir_det_idx = pbuf_get_index('qir_det', istat) + if (istat < 0) call endrun(subname//': macrop option requires qir_det in pbuf') + end if + end if + + if (rhminl_opt == 2 .or. rhmini_opt == 2) then + tke_idx = pbuf_get_index('tke') + if (rhminl_opt == 2) then + qtl_flx_idx = pbuf_get_index('qtl_flx', istat) + if (istat < 0) call endrun(subname//': macrop option requires qtl_flx in pbuf') + end if + if (rhmini_opt == 2) then + qti_flx_idx = pbuf_get_index('qti_flx', istat) + if (istat < 0) call endrun(subname//': macrop option requires qti_flx in pbuf') + end if + end if + + ! Init pbuf fields. Note that the fields CLD, CONCLD, QCWAT, LCWAT, + ! ICCWAT, and TCWAT are initialized in phys_inidat. + if (is_first_step()) then + call pbuf_set_field(pbuf2d, ast_idx, 0._r8) + call pbuf_set_field(pbuf2d, aist_idx, 0._r8) + call pbuf_set_field(pbuf2d, alst_idx, 0._r8) + call pbuf_set_field(pbuf2d, qist_idx, 0._r8) + call pbuf_set_field(pbuf2d, qlst_idx, 0._r8) + call pbuf_set_field(pbuf2d, nlwat_idx, 0._r8) + call pbuf_set_field(pbuf2d, niwat_idx, 0._r8) + call pbuf_set_field(pbuf2d, fice_idx, 0._r8) + call pbuf_set_field(pbuf2d, cmeliq_idx, 0._r8) + end if + end subroutine macrop_driver_init !============================================================================ ! @@ -310,7 +377,7 @@ subroutine macrop_driver_tend( & dlf, dlf2, cmfmc, cmfmc2, ts, & sst, zdu, & pbuf, & - det_s, det_ice) + det_s, det_ice) !-------------------------------------------------------- ! ! ! @@ -324,14 +391,12 @@ subroutine macrop_driver_tend( & ! ! !-------------------------------------------------------- ! - use shr_kind_mod, only: r8 => shr_kind_r8 use cloud_fraction, only: cldfrc, cldfrc_fice use physics_types, only: physics_state, physics_ptend use physics_types, only: physics_ptend_init, physics_update use physics_types, only: physics_ptend_sum, physics_state_copy use physics_types, only: physics_state_dealloc use cam_history, only: outfld - use physics_buffer, only : physics_buffer_desc, pbuf_get_field, pbuf_old_tim_idx use constituents, only: cnst_get_ind, pcnst use cldwat2m_macro, only: mmacro_pcond use physconst, only: cpair, tmelt, gravit @@ -339,8 +404,6 @@ subroutine macrop_driver_tend( & use ref_pres, only: top_lev => trop_cloud_top_lev - implicit none - ! ! Input arguments ! @@ -377,7 +440,6 @@ subroutine macrop_driver_tend( & integer i,k integer :: lchnk ! Chunk identifier integer :: ncol ! Number of atmospheric columns - integer :: conv_water_in_rad ! Physics buffer fields @@ -407,10 +469,27 @@ subroutine macrop_driver_tend( & real(r8), pointer, dimension(:,:) :: cmeliq + real(r8), pointer, dimension(:,:) :: tke + real(r8), pointer, dimension(:,:) :: qtl_flx + real(r8), pointer, dimension(:,:) :: qti_flx + real(r8), pointer, dimension(:,:) :: cmfr_det + real(r8), pointer, dimension(:,:) :: qlr_det + real(r8), pointer, dimension(:,:) :: qir_det + ! Convective cloud to the physics buffer for purposes of ql contrib. to radn. real(r8), pointer, dimension(:,:) :: fice_ql ! Cloud ice/water partitioning ratio. + real(r8), pointer, dimension(:,:) :: naai ! Number concentration of activated ice nuclei + + real(r8) :: latsub + + ! tendencies for ice saturation adjustment + real(r8) :: stend(pcols,pver) + real(r8) :: qvtend(pcols,pver) + real(r8) :: qitend(pcols,pver) + real(r8) :: initend(pcols,pver) + ! Local variables for cldfrc real(r8) cldst(pcols,pver) ! Stratus cloud fraction @@ -479,6 +558,14 @@ subroutine macrop_driver_tend( & real(r8) qi_inout(pcols,pver) real(r8) concld_old(pcols,pver) + ! Note that below 'clr_old' is defined using 'alst_old' not 'ast_old' for full consistency with the + ! liquid condensation process which is using 'alst' not 'ast'. + ! For microconsistency use 'concld_old', since 'alst_old' was computed using 'concld_old'. + ! Since convective updraft fractional area is small, it does not matter whether 'concld' or 'concld_old' is used. + ! Note also that 'clri_old' is defined using 'ast_old' since current microphysics is operating on 'ast_old' + real(r8) clrw_old(pcols,pver) ! (1 - concld_old - alst_old) + real(r8) clri_old(pcols,pver) ! (1 - concld_old - ast_old) + real(r8) nl_inout(pcols,pver) real(r8) ni_inout(pcols,pver) @@ -497,21 +584,23 @@ subroutine macrop_driver_tend( & real(r8) dlf_ni(pcols,pver) ! Local variables for CFMIP calculations - real(r8) :: mr_lsliq(pcols,pver) ! mixing_ratio_large_scale_cloud_liquid (kg/kg) - real(r8) :: mr_lsice(pcols,pver) ! mixing_ratio_large_scale_cloud_ice (kg/kg) - real(r8) :: mr_ccliq(pcols,pver) ! mixing_ratio_convective_cloud_liquid (kg/kg) - real(r8) :: mr_ccice(pcols,pver) ! mixing_ratio_convective_cloud_ice (kg/kg) + real(r8) :: mr_lsliq(pcols,pver) ! mixing_ratio_large_scale_cloud_liquid (kg/kg) + real(r8) :: mr_lsice(pcols,pver) ! mixing_ratio_large_scale_cloud_ice (kg/kg) + real(r8) :: mr_ccliq(pcols,pver) ! mixing_ratio_convective_cloud_liquid (kg/kg) + real(r8) :: mr_ccice(pcols,pver) ! mixing_ratio_convective_cloud_ice (kg/kg) ! CloudSat equivalent ice mass mixing ratio (kg/kg) real(r8) :: cldsice(pcols,pver) ! ====================================================================== + if (micro_do_icesupersat) then + call pbuf_get_field(pbuf, naai_idx, naai) + endif + lchnk = state%lchnk ncol = state%ncol - call phys_getopts( conv_water_in_rad_out = conv_water_in_rad ) - call physics_state_copy(state, state_loc) ! Copy state to local state_loc. ! Associate pointers with physics buffer fields @@ -636,7 +725,7 @@ subroutine macrop_driver_tend( & ! Only rliq is saved from deep convection, which is the reserved liquid. We need to keep ! track of the integrals of ice and static energy that is effected from conversion to ice - ! so that the energy checker doesn't complain. + ! so that the energy checker doesn't complain. det_s(i) = det_s(i) + ptend_loc%s(i,k)*state_loc%pdel(i,k)/gravit det_ice(i) = det_ice(i) - ptend_loc%q(i,k,ixcldice)*state_loc%pdel(i,k)/gravit @@ -690,6 +779,53 @@ subroutine macrop_driver_tend( & ! ptend_loc is reset to zero by this call call physics_update(state_loc, ptend_loc, dtime) + if (micro_do_icesupersat) then + + ! -------------------------------------- ! + ! Ice Saturation Adjustment Computation ! + ! -------------------------------------- ! + + lq(:) = .FALSE. + + lq(1) = .true. + lq(ixcldice) = .true. + lq(ixnumice) = .true. + + latsub = latvap + latice + + call physics_ptend_init(ptend_loc, state%psetcols, 'iceadj', ls=.true., lq=lq) + + stend(:ncol,:)=0._r8 + qvtend(:ncol,:)=0._r8 + qitend(:ncol,:)=0._r8 + initend(:ncol,:)=0._r8 + + call ice_macro_tend(naai(:ncol,top_lev:pver),state%t(:ncol,top_lev:pver), & + state%pmid(:ncol,top_lev:pver),state%q(:ncol,top_lev:pver,1),state%q(:ncol,top_lev:pver,ixcldice),& + state%q(:ncol,top_lev:pver,ixnumice),latsub,dtime,& + stend(:ncol,top_lev:pver),qvtend(:ncol,top_lev:pver),qitend(:ncol,top_lev:pver),& + initend(:ncol,top_lev:pver)) + + ! update local copy of state with the tendencies + ptend_loc%q(:ncol,top_lev:pver,1)=qvtend(:ncol,top_lev:pver) + ptend_loc%q(:ncol,top_lev:pver,ixcldice)=qitend(:ncol,top_lev:pver) + ptend_loc%q(:ncol,top_lev:pver,ixnumice)=initend(:ncol,top_lev:pver) + ptend_loc%s(:ncol,top_lev:pver)=stend(:ncol,top_lev:pver) + + ! Add the ice tendency to the output tendency + call physics_ptend_sum(ptend_loc, ptend, ncol) + + ! ptend_loc is reset to zero by this call + call physics_update(state_loc, ptend_loc, dtime) + + ! Write output for tendencies: + call outfld( 'TTENDICE', stend/cpair, pcols, lchnk ) + call outfld( 'QVTENDICE', qvtend, pcols, lchnk ) + call outfld( 'QITENDICE', qitend, pcols, lchnk ) + call outfld( 'NITENDICE', initend, pcols, lchnk ) + + endif + ! -------------------------------------- ! ! Computation of Various Cloud Fractions ! ! -------------------------------------- ! @@ -712,6 +848,23 @@ subroutine macrop_driver_tend( & concld_old(:ncol,top_lev:pver) = concld(:ncol,top_lev:pver) + nullify(tke, qtl_flx, qti_flx, cmfr_det, qlr_det, qir_det) + if (tke_idx > 0) call pbuf_get_field(pbuf, tke_idx, tke) + if (qtl_flx_idx > 0) call pbuf_get_field(pbuf, qtl_flx_idx, qtl_flx) + if (qti_flx_idx > 0) call pbuf_get_field(pbuf, qti_flx_idx, qti_flx) + if (cmfr_det_idx > 0) call pbuf_get_field(pbuf, cmfr_det_idx, cmfr_det) + if (qlr_det_idx > 0) call pbuf_get_field(pbuf, qlr_det_idx, qlr_det) + if (qir_det_idx > 0) call pbuf_get_field(pbuf, qir_det_idx, qir_det) + + clrw_old(:ncol,:top_lev-1) = 0._r8 + clri_old(:ncol,:top_lev-1) = 0._r8 + do k = top_lev, pver + do i = 1, ncol + clrw_old(i,k) = max( 0._r8, min( 1._r8, 1._r8 - concld(i,k) - alst(i,k) ) ) + clri_old(i,k) = max( 0._r8, min( 1._r8, 1._r8 - concld(i,k) - ast(i,k) ) ) + end do + end do + if( use_shfrc ) then call pbuf_get_field(pbuf, shfrc_idx, shfrc ) else @@ -836,7 +989,8 @@ subroutine macrop_driver_tend( & ttend, qtend, lmitend, itend, nltend, nitend, & CC_T, CC_qv, CC_ql, CC_qi, CC_nl, CC_ni, CC_qlst, & dlf_T, dlf_qv, dlf_ql, dlf_qi, dlf_nl, dlf_ni, & - concld_old, concld, landfrac, snowh, & + concld_old, concld, clrw_old, clri_old, landfrac, snowh, & + tke, qtl_flx, qti_flx, cmfr_det, qlr_det, qir_det, & tlat, qvlat, qcten, qiten, ncten, niten, & cmeliq, qvadj, qladj, qiadj, qllim, qilim, & cld, alst, aist, qlst, qist, do_cldice ) @@ -891,6 +1045,8 @@ subroutine macrop_driver_tend( & ! state_loc is the equlibrium state after macrophysics call physics_update(state_loc, ptend_loc, dtime) + call outfld('CLR_LIQ', clrw_old, pcols, lchnk) + call outfld('CLR_ICE', clri_old, pcols, lchnk) call outfld( 'MACPDT ', tlat , pcols, lchnk ) call outfld( 'MACPDQ ', qvlat, pcols, lchnk ) @@ -961,4 +1117,71 @@ subroutine macrop_driver_tend( & end subroutine macrop_driver_tend +! Saturation adjustment for ice +! Add ice mass if supersaturated +elemental subroutine ice_macro_tend(naai,t,p,qv,qi,ni,xxls,deltat,stend,qvtend,qitend,nitend) + + use wv_sat_methods, only: wv_sat_qsat_ice + + real(r8), intent(in) :: naai !Activated number of ice nuclei + real(r8), intent(in) :: t !temperature (k) + real(r8), intent(in) :: p !pressure (pa0 + real(r8), intent(in) :: qv !water vapor mixing ratio + real(r8), intent(in) :: qi !ice mixing ratio + real(r8), intent(in) :: ni !ice number concentration + real(r8), intent(in) :: xxls !latent heat of sublimation + real(r8), intent(in) :: deltat !timestep + real(r8), intent(out) :: stend ! 'temperature' tendency + real(r8), intent(out) :: qvtend !vapor tendency + real(r8), intent(out) :: qitend !ice mass tendency + real(r8), intent(out) :: nitend !ice number tendency + + real(r8) :: ESI + real(r8) :: QSI + real(r8) :: tau + logical :: tau_constant + + tau_constant = .true. + + stend = 0._r8 + qvtend = 0._r8 + qitend = 0._r8 + nitend = 0._r8 + + ! calculate qsati from t,p,q + + call wv_sat_qsat_ice(t, p, ESI, QSI) + + if (naai.gt.1.e-18_r8.and.qv.gt.QSI) then + + !optional timescale on condensation + !tau in sections. Try 300. or tau = f(T): 300s t> 268, 1800s for t<238 + ! + if (.not. tau_constant) then + if( t.gt. 268.15_r8 ) then + tau = 300.0_r8 + elseif(t.lt.238.15_r8 ) then + tau = 1800._r8 + else + tau = 300._r8 + (1800._r8 - 300._r8) * ( 268.15_r8 - t ) / 30._r8 + endif + else + tau = 300._r8 + end if + + qitend = (qv-QSI)/deltat !* exp(-tau/deltat) + qvtend = 0._r8 - qitend + stend = qitend * xxls ! moist static energy tend...[J/kg/s] ! + + ! kg(h2o)/kg(air)/s * J/kg(h2o) = J/kg(air)/s (=W/kg) + ! if ice exists (more than 1 L-1) and there is condensation, do not add to number (= growth), else, add 10um ice + + if (ni.lt.1.e3_r8.and.(qi+qitend*deltat).gt.1e-18_r8) then + nitend = nitend + 3._r8 * qitend/(4._r8*3.14_r8* 10.e-6_r8**3*997._r8) + endif + + endif + +end subroutine ice_macro_tend + end module macrop_driver diff --git a/models/atm/cam/src/physics/cam/micro_mg1_0.F90 b/models/atm/cam/src/physics/cam/micro_mg1_0.F90 index aac79901922a..efd32b28e053 100644 --- a/models/atm/cam/src/physics/cam/micro_mg1_0.F90 +++ b/models/atm/cam/src/physics/cam/micro_mg1_0.F90 @@ -32,6 +32,7 @@ module micro_mg1_0 !--------------------------------------------------------------------------------- ! modification for sub-columns, HM, (orig 8/11/10) ! This is done using the logical 'microp_uniform' set to .true. = uniform for subcolumns +!--------------------------------------------------------------------------------- ! Procedures required: ! 1) An implementation of the gamma function (if not intrinsic). @@ -48,6 +49,8 @@ module micro_mg1_0 svp_ice => wv_sat_svp_ice, & svp_to_qsat => wv_sat_svp_to_qsat + use phys_control, only: phys_getopts + implicit none private save @@ -58,8 +61,9 @@ module micro_mg1_0 ! done outside of this module. public :: & - micro_mg_init, & - micro_mg_tend + micro_mg_init, & + micro_mg_get_cols, & + micro_mg_tend integer, parameter :: r8 = selected_real_kind(12) ! 8 byte real @@ -84,7 +88,7 @@ module micro_mg1_0 real(r8) :: Eii !collection efficiency aggregation of ice real(r8) :: Ecr !collection efficiency cloud droplets/rain real(r8) :: f1r,f2r !ventilation param for rain -real(r8) :: dcs !autoconversion size threshold for cloud ice to snow (m) +real(r8) :: DCS !autoconversion size threshold real(r8) :: qsmall !min mixing ratio real(r8) :: bimm,aimm !immersion freezing real(r8) :: rhosu !typical 850mn air density @@ -130,6 +134,12 @@ module micro_mg1_0 real(r8) :: rhmini ! Minimum rh for ice cloud fraction > 0. +logical :: use_hetfrz_classnuc ! option to use heterogeneous freezing + +character(len=16) :: micro_mg_precip_frac_method ! type of precipitation fraction method +real(r8) :: micro_mg_berg_eff_factor ! berg efficiency factor + + !=============================================================================== contains !=============================================================================== @@ -137,7 +147,8 @@ module micro_mg1_0 subroutine micro_mg_init( & kind, gravit, rair, rh2o, cpair, & rhoh2o, tmelt_in, latvap, latice, & - rhmini_in, errstring, dcs_in) + rhmini_in, micro_mg_dcs, use_hetfrz_classnuc_in, & + micro_mg_precip_frac_method_in, micro_mg_berg_eff_factor_in, errstring) !----------------------------------------------------------------------- ! @@ -158,7 +169,11 @@ subroutine micro_mg_init( & real(r8), intent(in) :: latvap real(r8), intent(in) :: latice real(r8), intent(in) :: rhmini_in ! Minimum rh for ice cloud fraction > 0. -real(r8), intent(in) :: dcs_in !autoconversion size threshold for cloud ice to snow (m) +real(r8), intent(in) :: micro_mg_dcs +logical, intent(in) :: use_hetfrz_classnuc_in +character(len=16),intent(in) :: micro_mg_precip_frac_method_in ! type of precipitation fraction method +real(r8), intent(in) :: micro_mg_berg_eff_factor_in ! berg efficiency factor + character(128), intent(out) :: errstring ! Output status (non-blank for error return) integer k @@ -178,12 +193,14 @@ subroutine micro_mg_init( & !declarations for morrison codes (transforms variable names) g= gravit !gravity -r= rair !Dry air Gas constant: note units(phys_constants are in J/K/kmol) +r= rair !Dry air Gas constant: note units(phys_constants are in J/K/kmol) rv= rh2o !water vapor gas contstant -cpp = cpair !specific heat of dry air +cpp = cpair !specific heat of dry air rhow = rhoh2o !density of liquid water tmelt = tmelt_in rhmini = rhmini_in +micro_mg_precip_frac_method = micro_mg_precip_frac_method_in +micro_mg_berg_eff_factor = micro_mg_berg_eff_factor_in ! latent heats @@ -191,6 +208,9 @@ subroutine micro_mg_init( & xlf = latice ! latent heat freezing xxls = xxlv + xlf ! latent heat of sublimation +! flags +use_hetfrz_classnuc = use_hetfrz_classnuc_in + ! parameters for snow/rain fraction for convective clouds tmax_fsnow = tmelt @@ -265,7 +285,7 @@ subroutine micro_mg_init( & ! autoconversion size threshold for cloud ice to snow (m) -dcs = dcs_in +Dcs = micro_mg_dcs ! smallest mixing ratio considered in microphysics @@ -313,7 +333,7 @@ subroutine micro_mg_init( & cons14=gamma(5._r8/2._r8+bs/2._r8) cons16=gamma(1._r8+bi) cons17=gamma(4._r8+bi) -cons22=(4._r8/3._r8*pi*rhow*(25.e-6_r8)**3) +cons22=(4._r8/3._r8*pi*rhow*(25.e-6_r8)**3) cons23=dcs**3 cons24=dcs**2 cons25=dcs**bs @@ -340,7 +360,7 @@ subroutine micro_mg_tend ( & icecldf, rate1ord_cw2pr_st, naai, npccnin, & rndst, nacon, tlat, qvlat, qctend, & qitend, nctend, nitend, effc, effc_fn, & - effi, prect, preci, nevapr, evapsnow, & + effi, prect, preci, nevapr, evapsnow, am_evp_st, & prain, prodsnow, cmeout, deffi, pgamrad, & lamcrad, qsout, dsout, rflx, sflx, & qrout, reff_rain, reff_snow, qcsevap, qisevap, & @@ -353,8 +373,9 @@ subroutine micro_mg_tend ( & frefl, csrfl, acsrfl, fcsrfl, rercld, & ncai, ncal, qrout2, qsout2, nrout2, & nsout2, drout2, dsout2, freqs, freqr, & - nfice, do_cldice, tnd_qsnow, & - tnd_nsnow, re_ice, errstring) + nfice, prer_evap, do_cldice, errstring, & + tnd_qsnow, tnd_nsnow, re_ice, & + frzimm, frzcnt, frzdep) ! input arguments logical, intent(in) :: microp_uniform ! True = configure uniform for sub-columns False = use w/o sub-columns (standard) @@ -378,7 +399,7 @@ subroutine micro_mg_tend ( & real(r8), intent(in) :: cldn(pcols,pver) ! cloud fraction real(r8), intent(in) :: icecldf(pcols,pver) ! ice cloud fraction real(r8), intent(in) :: liqcldf(pcols,pver) ! liquid cloud fraction - + real(r8), intent(out) :: rate1ord_cw2pr_st(pcols,pver) ! 1st order rate for direct cw to precip conversion ! used for scavenging ! Inputs for aerosol activation @@ -390,9 +411,7 @@ subroutine micro_mg_tend ( & ! Used with CARMA cirrus microphysics ! (or similar external microphysics model) logical, intent(in) :: do_cldice ! Prognosing cldice -real(r8), intent(in) :: tnd_qsnow(pcols,pver) ! snow mass tendency (kg/kg/s) -real(r8), intent(in) :: tnd_nsnow(pcols,pver) ! snow number tendency (#/kg/s) -real(r8), intent(in) :: re_ice(pcols,pver) ! ice effective radius (m) + ! output arguments real(r8), intent(out) :: tlat(pcols,pver) ! latent heating rate (W/kg) @@ -408,6 +427,7 @@ subroutine micro_mg_tend ( & real(r8), intent(out) :: preci(pcols) ! cloud ice/snow precip rate (m/s) real(r8), intent(out) :: nevapr(pcols,pver) ! evaporation rate of rain + snow real(r8), intent(out) :: evapsnow(pcols,pver)! sublimation rate of snow +real(r8), intent(out) :: am_evp_st(pcols,pver)! stratiform evaporation area real(r8), intent(out) :: prain(pcols,pver) ! production of rain + snow real(r8), intent(out) :: prodsnow(pcols,pver)! production of snow real(r8), intent(out) :: cmeout(pcols,pver) ! evap/sub of cloud @@ -455,8 +475,8 @@ subroutine micro_mg_tend ( & real(r8), intent(out) :: arefl(pcols,pver) !average reflectivity will zero points outside valid range real(r8), intent(out) :: areflz(pcols,pver) !average reflectivity in z. real(r8), intent(out) :: frefl(pcols,pver) -real(r8), intent(out) :: csrfl(pcols,pver) !cloudsat reflectivity -real(r8), intent(out) :: acsrfl(pcols,pver) !cloudsat average +real(r8), intent(out) :: csrfl(pcols,pver) !cloudsat reflectivity +real(r8), intent(out) :: acsrfl(pcols,pver) !cloudsat average real(r8), intent(out) :: fcsrfl(pcols,pver) real(r8), intent(out) :: rercld(pcols,pver) ! effective radius calculation for rain + cloud real(r8), intent(out) :: ncai(pcols,pver) ! output number conc of ice nuclei available (1/m3) @@ -470,9 +490,26 @@ subroutine micro_mg_tend ( & real(r8), intent(out) :: freqs(pcols,pver) real(r8), intent(out) :: freqr(pcols,pver) real(r8), intent(out) :: nfice(pcols,pver) +real(r8), intent(out) :: prer_evap(pcols,pver) + +real(r8) :: nevapr2(pcols,pver) character(128), intent(out) :: errstring ! Output status (non-blank for error return) +! Tendencies calculated by external schemes that can replace MG's native +! process tendencies. + +! Used with CARMA cirrus microphysics +! (or similar external microphysics model) +real(r8), intent(in), pointer :: tnd_qsnow(:,:) ! snow mass tendency (kg/kg/s) +real(r8), intent(in), pointer :: tnd_nsnow(:,:) ! snow number tendency (#/kg/s) +real(r8), intent(in), pointer :: re_ice(:,:) ! ice effective radius (m) + +! From external ice nucleation. +real(r8), intent(in), pointer :: frzimm(:,:) ! Number tendency due to immersion freezing (1/cm3) +real(r8), intent(in), pointer :: frzcnt(:,:) ! Number tendency due to contact freezing (1/cm3) +real(r8), intent(in), pointer :: frzdep(:,:) ! Number tendency due to deposition nucleation (1/cm3) + ! local workspace ! all units mks unless otherwise stated @@ -607,7 +644,7 @@ subroutine micro_mg_tend ( & real(r8) :: umr(pver) ! mass-weighted rain fallspeed real(r8) :: unc ! number-weighted cloud droplet fallspeed real(r8) :: umc ! mass-weighted cloud droplet fallspeed -real(r8) :: pracs(pver) ! mixing rat tendency due to collection of rain by snow +real(r8) :: pracs(pver) ! mixing rat tendency due to collection of rain by snow real(r8) :: npracs(pver) ! number conc tendency due to collection of rain by snow real(r8) :: mnuccr(pver) ! mixing rat tendency due to freezing of rain real(r8) :: nnuccr(pver) ! number conc tendency due to freezing of rain @@ -727,7 +764,7 @@ subroutine micro_mg_tend ( & ! diagnostic rain/snow for output to history ! values are in-precip (local) !!!! -real(r8) :: drout(pcols,pver) ! rain diameter (m) +real(r8) :: drout(pcols,pver) ! rain diameter (m) !averageed rain/snow for history real(r8) :: dumfice @@ -783,11 +820,35 @@ subroutine micro_mg_tend ( & real(r8), parameter :: cdnl = 0.e6_r8 ! cloud droplet number limiter +! heterogeneous freezing +real(r8) :: mnudep(pver) ! mixing ratio tendency due to deposition of water vapor +real(r8) :: nnudep(pver) ! number conc tendency due to deposition of water vapor +real(r8) :: con1 ! work cnstant +real(r8) :: r3lx ! Mean volume radius (m) +real(r8) :: mi0l +real(r8) :: frztmp + +logical :: do_clubb_sgs + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ! Return error message errstring = ' ' +if (.not. (do_cldice .or. & + (associated(tnd_qsnow) .and. associated(tnd_nsnow) .and. associated(re_ice)))) then + errstring = "MG's native cloud ice processes are disabled, but & + &no replacement values were passed in." +end if + +if (use_hetfrz_classnuc .and. (.not. & + (associated(frzimm) .and. associated(frzcnt) .and. associated(frzdep)))) then + errstring = "Hoose heterogeneous freezing is enabled, but the & + &required tendencies were not all passed in." +end if + +call phys_getopts(do_clubb_sgs_out = do_clubb_sgs) + ! initialize output fields for number conc qand ice nucleation ncai(1:ncol,1:pver)=0._r8 ncal(1:ncol,1:pver)=0._r8 @@ -838,7 +899,7 @@ subroutine micro_mg_tend ( & effi(:,:)=0._r8 ! assign variable deltat for sub-stepping... -deltat=deltatin +deltat=deltatin ! parameters for scheme @@ -913,11 +974,14 @@ subroutine micro_mg_tend ( & ! initialize variables for trop_mozart nevapr(1:ncol,1:pver) = 0._r8 +nevapr2(1:ncol,1:pver) = 0._r8 evapsnow(1:ncol,1:pver) = 0._r8 prain(1:ncol,1:pver) = 0._r8 prodsnow(1:ncol,1:pver) = 0._r8 cmeout(1:ncol,1:pver) = 0._r8 +am_evp_st(1:ncol,1:pver) = 0._r8 + ! for refl calc rainrt1(1:ncol,1:pver) = 0._r8 @@ -1115,7 +1179,8 @@ subroutine micro_mg_tend ( & if (qiic(i,k).ge.qsmall) then - ! first case is for case when liquid water is present, but is completely depleted in time step, i.e., bergrsf > 0 but < 1 + ! first case is for case when liquid water is present, but is completely depleted + ! in time step, i.e., bergrsf > 0 but < 1 if (qc(i,k).ge.qsmall) then rhin = (1.0_r8 + relhum(i,k)) / 2._r8 @@ -1257,7 +1322,7 @@ subroutine micro_mg_tend ( & rflx(i,k+1)=0._r8 sflx(i,k+1)=0._r8 end do ! i loop -end do ! k loop +end do ! k loop do i=1,ncol ltrue(i)=0 @@ -1356,15 +1421,15 @@ subroutine micro_mg_tend ( & do k=top_lev,pver qcvar=relvar(i,k) - cons2=gamma(qcvar+2.47_r8) - cons3=gamma(qcvar) - cons9=gamma(qcvar+2._r8) - cons10=gamma(qcvar+1._r8) - cons12=gamma(qcvar+1.15_r8) - cons15=gamma(qcvar+bc/3._r8) - cons18=qcvar**2.47_r8 - cons19=qcvar**2 - cons20=qcvar**1.15_r8 + cons2=gamma(qcvar+2.47_r8) + cons3=gamma(qcvar) + cons9=gamma(qcvar+2._r8) + cons10=gamma(qcvar+1._r8) + cons12=gamma(qcvar+1.15_r8) + cons15=gamma(qcvar+bc/3._r8) + cons18=qcvar**2.47_r8 + cons19=qcvar**2 + cons20=qcvar**1.15_r8 ! set cwml and cwmi to current qc and qi @@ -1389,11 +1454,21 @@ subroutine micro_mg_tend ( & else ! if rain or snow mix ratio is smaller than ! threshold, then set cldmax to cloud fraction at current level - if (qric(i,k-1).ge.qsmall.or.qniic(i,k-1).ge.qsmall) then - cldmax(i,k)=max(cldmax(i,k-1),cldm(i,k)) + + if (do_clubb_sgs) then + if (qc(i,k).ge.qsmall.or.qi(i,k).ge.qsmall) then + cldmax(i,k)=cldm(i,k) + else + cldmax(i,k)=cldmax(i,k-1) + end if else - cldmax(i,k)=cldm(i,k) - end if + + if (qric(i,k-1).ge.qsmall.or.qniic(i,k-1).ge.qsmall) then + cldmax(i,k)=max(cldmax(i,k-1),cldm(i,k)) + else + cldmax(i,k)=cldm(i,k) + end if + endif end if ! decrease in number concentration due to sublimation/evap @@ -1793,101 +1868,131 @@ subroutine micro_mg_tend ( & ! heterogeneous freezing of cloud water - if (do_cldice .and. qcic(i,k).ge.qsmall .and. t(i,k).lt.269.15_r8) then + if (.not. use_hetfrz_classnuc) then - ! immersion freezing (Bigg, 1953) + if (do_cldice .and. qcic(i,k).ge.qsmall .and. t(i,k).lt.269.15_r8) then + ! immersion freezing (Bigg, 1953) - ! subcolumns - if (microp_uniform) then + ! subcolumns - mnuccc(k) = & - pi*pi/36._r8*rhow* & - cdist1(k)*gamma(7._r8+pgam(k))* & - bimm*(exp(aimm*(273.15_r8-t(i,k)))-1._r8)/ & - lamc(k)**3/lamc(k)**3 + if (microp_uniform) then - nnuccc(k) = & - pi/6._r8*cdist1(k)*gamma(pgam(k)+4._r8) & - *bimm* & - (exp(aimm*(273.15_r8-t(i,k)))-1._r8)/lamc(k)**3 + mnuccc(k) = & + pi*pi/36._r8*rhow* & + cdist1(k)*gamma(7._r8+pgam(k))* & + bimm*(exp(aimm*(273.15_r8-t(i,k)))-1._r8)/ & + lamc(k)**3/lamc(k)**3 - else + nnuccc(k) = & + pi/6._r8*cdist1(k)*gamma(pgam(k)+4._r8) & + *bimm* & + (exp(aimm*(273.15_r8-t(i,k)))-1._r8)/lamc(k)**3 - mnuccc(k) = cons9/(cons3*cons19)* & - pi*pi/36._r8*rhow* & - cdist1(k)*gamma(7._r8+pgam(k))* & - bimm*(exp(aimm*(273.15_r8-t(i,k)))-1._r8)/ & - lamc(k)**3/lamc(k)**3 + else - nnuccc(k) = cons10/(cons3*qcvar)* & - pi/6._r8*cdist1(k)*gamma(pgam(k)+4._r8) & - *bimm* & - (exp(aimm*(273.15_r8-t(i,k)))-1._r8)/lamc(k)**3 - end if ! sub-columns + mnuccc(k) = cons9/(cons3*cons19)* & + pi*pi/36._r8*rhow* & + cdist1(k)*gamma(7._r8+pgam(k))* & + bimm*(exp(aimm*(273.15_r8-t(i,k)))-1._r8)/ & + lamc(k)**3/lamc(k)**3 + nnuccc(k) = cons10/(cons3*qcvar)* & + pi/6._r8*cdist1(k)*gamma(pgam(k)+4._r8) & + *bimm* & + (exp(aimm*(273.15_r8-t(i,k)))-1._r8)/lamc(k)**3 + end if ! sub-columns - ! contact freezing (-40= qsmall) then + con1 = 1._r8/(1.333_r8*pi)**0.333_r8 + r3lx = con1*(rho(i,k)*qcic(i,k)/(rhow*max(ncic(i,k)*rho(i,k), 1.0e6_r8)))**0.333_r8 ! in m + r3lx = max(4.e-6_r8, r3lx) + mi0l = 4._r8/3._r8*pi*rhow*r3lx**3_r8 + + nnuccc(k) = frzimm(i,k)*1.0e6_r8/rho(i,k) + mnuccc(k) = nnuccc(k)*mi0l + + nnucct(k) = frzcnt(i,k)*1.0e6_r8/rho(i,k) + mnucct(k) = nnucct(k)*mi0l + + nnudep(k) = frzdep(i,k)*1.0e6_r8/rho(i,k) + mnudep(k) = nnudep(k)*mi0 + else + nnuccc(k) = 0._r8 + mnuccc(k) = 0._r8 + + nnucct(k) = 0._r8 + mnucct(k) = 0._r8 + + nnudep(k) = 0._r8 + mnudep(k) = 0._r8 + end if + endif + !....................................................................... ! snow self-aggregation from passarelli, 1978, used by reisner, 1998 @@ -1935,7 +2040,7 @@ subroutine micro_mg_tend ( & psacws(k) = pi/4._r8*asn(i,k)*qcic(i,k)*rho(i,k)* & n0s(k)*Eci*cons11/ & - lams(k)**(bs+3._r8) + lams(k)**(bs+3._r8) npsacws(k) = pi/4._r8*asn(i,k)*ncic(i,k)*rho(i,k)* & n0s(k)*Eci*cons11/ & lams(k)**(bs+3._r8) @@ -2056,7 +2161,7 @@ subroutine micro_mg_tend ( & prai(k) = pi/4._r8*asn(i,k)*qiic(i,k)*rho(i,k)* & n0s(k)*Eii*cons11/ & - lams(k)**(bs+3._r8) + lams(k)**(bs+3._r8) nprai(k) = pi/4._r8*asn(i,k)*niic(i,k)* & rho(i,k)*n0s(k)*Eii*cons11/ & lams(k)**(bs+3._r8) @@ -2119,6 +2224,7 @@ subroutine micro_mg_tend ( & ! and distribute across cldmax pre(k)=min(pre(k)*(cldmax(i,k)-dum),0._r8) pre(k)=pre(k)/cldmax(i,k) + am_evp_st(i,k) = max(cldmax(i,k)-dum, 0._r8) end if ! sublimation of snow @@ -2131,11 +2237,12 @@ subroutine micro_mg_tend ( & f2s*(asn(i,k)*rho(i,k)/mu(i,k))**0.5_r8* & sc(i,k)**(1._r8/3._r8)*cons14/ & (lams(k)**(5._r8/2._r8+bs/2._r8))) - prds(k) = epss*(qclr-qvi)/abi + prds(k) = epss*(qclr-qvi)/abi ! only sublimate in out-of-cloud region and distribute over cldmax prds(k)=min(prds(k)*(cldmax(i,k)-dum),0._r8) prds(k)=prds(k)/cldmax(i,k) + am_evp_st(i,k) = max(cldmax(i,k)-dum, 0._r8) end if ! make sure RH not pushed above 100% due to rain evaporation/snow sublimation @@ -2225,8 +2332,8 @@ subroutine micro_mg_tend ( & mnuccc(k) = mnuccc(k)*ratio mnucct(k) = mnucct(k)*ratio msacwi(k) = msacwi(k)*ratio - psacws(k) = psacws(k)*ratio - bergs(k) = bergs(k)*ratio + psacws(k) = psacws(k)*ratio + bergs(k) = bergs(k)*ratio end if ! conservation of nc @@ -2242,32 +2349,38 @@ subroutine micro_mg_tend ( & npra(k) = npra(k)*ratio nnuccc(k) = nnuccc(k)*ratio nnucct(k) = nnucct(k)*ratio - npsacws(k) = npsacws(k)*ratio + npsacws(k) = npsacws(k)*ratio nsubc(k)=nsubc(k)*ratio end if ! conservation of qi if (do_cldice) then - dum = ((-mnuccc(k)-mnucct(k)-msacwi(k))*lcldm(i,k)+(prci(k)+ & - prai(k))*icldm(i,k))*deltat + + frztmp = -mnuccc(k) - mnucct(k) - msacwi(k) + if (use_hetfrz_classnuc) frztmp = -mnuccc(k)-mnucct(k)-mnudep(k)-msacwi(k) + dum = ( frztmp*lcldm(i,k) + (prci(k)+prai(k))*icldm(i,k) )*deltat if (dum.gt.qie) then - ratio = (qie/deltat+(mnuccc(k)+mnucct(k)+msacwi(k))*lcldm(i,k))/((prci(k)+prai(k))*icldm(i,k))*omsm + frztmp = mnuccc(k) + mnucct(k) + msacwi(k) + if (use_hetfrz_classnuc) frztmp = mnuccc(k) + mnucct(k) + mnudep(k) + msacwi(k) + ratio = (qie/deltat + frztmp*lcldm(i,k))/((prci(k)+prai(k))*icldm(i,k))*omsm prci(k) = prci(k)*ratio prai(k) = prai(k)*ratio end if ! conservation of ni - - dum = ((-nnucct(k)-nsacwi(k))*lcldm(i,k)+(nprci(k)+ & - nprai(k)-nsubi(k))*icldm(i,k))*deltat + frztmp = -nnucct(k) - nsacwi(k) + if (use_hetfrz_classnuc) frztmp = -nnucct(k) - nnuccc(k) - nnudep(k) - nsacwi(k) + dum = ( frztmp*lcldm(i,k) + (nprci(k)+nprai(k)-nsubi(k))*icldm(i,k) )*deltat if (dum.gt.nie) then - ratio = (nie/deltat+(nnucct(k)+nsacwi(k))*lcldm(i,k))/ & - ((nprci(k)+nprai(k)-nsubi(k))*icldm(i,k))*omsm + frztmp = nnucct(k) + nsacwi(k) + if (use_hetfrz_classnuc) frztmp = nnucct(k) + nnuccc(k) + nnudep(k) + nsacwi(k) + ratio = (nie/deltat + frztmp*lcldm(i,k))/ & + ((nprci(k)+nprai(k)-nsubi(k))*icldm(i,k))*omsm nprci(k) = nprci(k)*ratio nprai(k) = nprai(k)*ratio nsubi(k) = nsubi(k)*ratio @@ -2362,9 +2475,12 @@ subroutine micro_mg_tend ( & psacws(k)-bergs(k))*lcldm(i,k)-berg(i,k) if (do_cldice) then - qitend(i,k) = qitend(i,k)+ & - (mnuccc(k)+mnucct(k)+msacwi(k))*lcldm(i,k)+(-prci(k)- & - prai(k))*icldm(i,k)+cmei(i,k)+berg(i,k) + + frztmp = mnuccc(k) + mnucct(k) + msacwi(k) + if (use_hetfrz_classnuc) frztmp = mnuccc(k) + mnucct(k) + mnudep(k) + msacwi(k) + qitend(i,k) = qitend(i,k) + frztmp*lcldm(i,k) + & + (-prci(k)-prai(k))*icldm(i,k) + cmei(i,k) + berg(i,k) + end if qrtend(i,k) = qrtend(i,k)+ & @@ -2383,6 +2499,7 @@ subroutine micro_mg_tend ( & evapsnow(i,k) = evapsnow(i,k)-prds(k)*cldmax(i,k) nevapr(i,k) = nevapr(i,k)-pre(k)*cldmax(i,k) + nevapr2(i,k) = nevapr2(i,k)-pre(k)*cldmax(i,k) ! change to make sure prain is positive: do not remove snow from ! prain used for wet deposition @@ -2424,9 +2541,12 @@ subroutine micro_mg_tend ( & -npra(k)-nprc1(k))*lcldm(i,k) if (do_cldice) then - nitend(i,k) = nitend(i,k)+ nnuccd(k)*mtime+ & - (nnucct(k)+nsacwi(k))*lcldm(i,k)+(nsubi(k)-nprci(k)- & - nprai(k))*icldm(i,k) + + frztmp = nnucct(k) + nsacwi(k) + if (use_hetfrz_classnuc) frztmp = nnucct(k) + nnuccc(k) + nnudep(k) + nsacwi(k) + nitend(i,k) = nitend(i,k) + nnuccd(k)*mtime + & + frztmp*lcldm(i,k) + (nsubi(k)-nprci(k)-nprai(k))*icldm(i,k) + end if nstend(i,k) = nstend(i,k)+(nsubs(k)+ & @@ -2474,7 +2594,7 @@ subroutine micro_mg_tend ( & if (qniic(i,k).ge.qsmall) then if (k.eq.top_lev) then - qniic(i,k)=qnitend(i,k)*dz(i,k)/cldmax(i,k)/ums(k) + qniic(i,k)=qnitend(i,k)*dz(i,k)/cldmax(i,k)/ums(k) nsic(i,k)=nstend(i,k)*dz(i,k)/cldmax(i,k)/uns(k) else qniic(i,k) = (rho(i,k-1)*ums(k-1)*qniic(i,k-1)*cldmax(i,k-1)+ & @@ -2820,6 +2940,7 @@ subroutine micro_mg_tend ( & ! divide trop_mozart variables by number of sub-steps to get average over time step nevapr(i,k) = nevapr(i,k)/real(iter) + nevapr2(i,k) = nevapr2(i,k)/real(iter) evapsnow(i,k) = evapsnow(i,k)/real(iter) prain(i,k) = prain(i,k)/real(iter) prodsnow(i,k) = prodsnow(i,k)/real(iter) @@ -2849,6 +2970,7 @@ subroutine micro_mg_tend ( & ! modify to include snow. in prain & evap (diagnostic here: for wet dep) nevapr(i,k) = nevapr(i,k) + evapsnow(i,k) + prer_evap(i,k) = nevapr2(i,k) prain(i,k) = prain(i,k) + prodsnow(i,k) !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc @@ -2950,7 +3072,7 @@ subroutine micro_mg_tend ( & if (dumi(i,k).lt.qsmall) dumni(i,k)=0._r8 end do !!! vertical loop - do n = 1,nstep !! loop over sub-time step to ensure stability + do n = 1,nstep !! loop over sub-time step to ensure stability do k = top_lev,pver if (do_cldice) then @@ -3059,7 +3181,7 @@ subroutine micro_mg_tend ( & ! get new update for variables that includes sedimentation tendency ! note : here dum variables are grid-average, NOT in-cloud - do k=top_lev,pver + do k=top_lev,pver dumc(i,k) = max(qc(i,k)+qctend(i,k)*deltat,0._r8) dumi(i,k) = max(qi(i,k)+qitend(i,k)*deltat,0._r8) @@ -3409,7 +3531,7 @@ subroutine micro_mg_tend ( & if (refl(i,k).gt.minrefl) then refl(i,k)=10._r8*log10(refl(i,k)) - else + else refl(i,k)=-9999._r8 end if @@ -3445,9 +3567,9 @@ subroutine micro_mg_tend ( & qrout2(:,:)=0._r8 qsout2(:,:)=0._r8 nrout2(:,:)=0._r8 -nsout2(:,:)=0._r8 +nsout2(:,:)=0._r8 drout2(:,:)=0._r8 -dsout2(:,:)=0._r8 +dsout2(:,:)=0._r8 freqs(:,:)=0._r8 freqr(:,:)=0._r8 do i = 1,ncol @@ -3498,4 +3620,58 @@ subroutine micro_mg_tend ( & end subroutine micro_mg_tend +!======================================================================== +!UTILITIES +!======================================================================== + +pure subroutine micro_mg_get_cols(ncol, nlev, top_lev, qcn, qin, & + mgncol, mgcols) + + ! Determines which columns microphysics should operate over by + ! checking for non-zero cloud water/ice. + + integer, intent(in) :: ncol ! Number of columns with meaningful data + integer, intent(in) :: nlev ! Number of levels to use + integer, intent(in) :: top_lev ! Top level for microphysics + + real(r8), intent(in) :: qcn(:,:) ! cloud water mixing ratio (kg/kg) + real(r8), intent(in) :: qin(:,:) ! cloud ice mixing ratio (kg/kg) + + integer, intent(out) :: mgncol ! Number of columns MG will use + integer, allocatable, intent(out) :: mgcols(:) ! column indices + + integer :: lev_offset ! top_lev - 1 (defined here for consistency) + logical :: ltrue(ncol) ! store tests for each column + + integer :: i, ii ! column indices + + if (allocated(mgcols)) deallocate(mgcols) + + lev_offset = top_lev - 1 + + ! Using "any" along dimension 2 collapses across levels, but + ! not columns, so we know if water is present at any level + ! in each column. + + ltrue = any(qcn(:ncol,top_lev:(nlev+lev_offset)) >= qsmall, 2) + ltrue = ltrue .or. any(qin(:ncol,top_lev:(nlev+lev_offset)) >= qsmall, 2) + +#if ! defined(CLUBB_BFB_S2) && ! defined(CLUBB_BFB_ALL) + ltrue = .true. ! Effectively still to pass all columns to MG1, as in default model +#endif + + ! Scan for true values to get a usable list of indices. + + mgncol = count(ltrue) + allocate(mgcols(mgncol)) + i = 0 + do ii = 1,ncol + if (ltrue(ii)) then + i = i + 1 + mgcols(i) = ii + end if + end do + +end subroutine micro_mg_get_cols + end module micro_mg1_0 diff --git a/models/atm/cam/src/physics/cam/micro_mg1_5.F90 b/models/atm/cam/src/physics/cam/micro_mg1_5.F90 index fa16d0bd7b73..d3cb06b39453 100644 --- a/models/atm/cam/src/physics/cam/micro_mg1_5.F90 +++ b/models/atm/cam/src/physics/cam/micro_mg1_5.F90 @@ -9,7 +9,7 @@ module micro_mg1_5 ! Contributions from: Peter Caldwell, Xiaohong Liu and Steve Ghan ! Version 2: Development begun: September 2011 ! invoked in CAM by specifying -microphys=mg1.5 -! +! ! for questions contact Hugh Morrison, Andrew Gettelman ! e-mail: morrison@ucar.edu, andrew@ucar.edu ! @@ -47,6 +47,8 @@ module micro_mg1_5 ! subroutine micro_mg_init --> initializes microphysics routine, should be called ! once at start of simulation ! subroutine micro_mg_tend --> main microphysics routine to be called each time step +! this also calls several smaller subroutines to calculate +! microphysical processes and other utilities ! ! List of external functions: ! qsat_water --> for calculating saturation vapor pressure with respect to liquid water @@ -100,14 +102,13 @@ module micro_mg1_5 ! note: number will be adjusted as needed to keep mean size within bounds, ! even when specified droplet or ice number is used -! ***note: Even if constant cloud ice number is set, ice number is allowed -! to evolve based on process rates. This is needed in order to calculate -! the change in mass due to ice nucleation. All other ice microphysical -! processes are consistent with the specified constant ice number if -! this switch is turned on. +! If constant cloud ice number is set (nicons = .true.), +! then all microphysical processes except mass transfer due to ice nucleation +! (mnuccd) are based on the fixed cloud ice number. Calculation of +! mnuccd follows from the prognosed ice crystal number ni. ! nccons = .true. to specify constant cloud droplet number -! cicons = .true. to specify constant cloud ice number +! nicons = .true. to specify constant cloud ice number logical, parameter, public :: nccons = .false. logical, parameter, public :: nicons = .false. @@ -167,10 +168,10 @@ module micro_mg1_5 real(r8), parameter :: eii = 0.1_r8 ! autoconversion size threshold for cloud ice to snow (m) -!real(r8), parameter :: dcs = 250.e-6_r8 +real(r8) :: dcs ! smallest mixing ratio considered in microphysics -real(r8), parameter :: qsmall = 1.e-18_r8 +real(r8), parameter :: qsmall = 1.e-18_r8 ! alternate threshold used for some in-cloud mmr real(r8), parameter :: icsmall = 1.e-8_r8 @@ -180,7 +181,11 @@ module micro_mg1_5 real(r8), parameter :: aimm = 0.66_r8 ! mass of new crystal due to aerosol freezing and growth (kg) -real(r8), parameter :: mi0 = 4._r8/3._r8*pi*rhoi*(10.e-6_r8)*(10.e-6_r8)*(10.e-6_r8) +real(r8), parameter :: mi0 = 4._r8/3._r8*pi*rhoi*(10.e-6_r8)**3 + +! minimum mass of new crystal due to freezing of cloud droplets done +! externally (kg) +real(r8), parameter :: mi0l_min = 4._r8/3._r8*pi*rhow*(4.e-6_r8)**3 !Range of cloudsat reflectivities (dBz) for analytic simulator real(r8), parameter :: csmin = -30._r8 @@ -192,9 +197,6 @@ module micro_mg1_5 ! Constants set in initialization !========================================================= -! autoconversion size threshold for cloud ice to snow (m) -real(r8) :: dcs - ! Set using arguments to micro_mg_init real(r8) :: g ! gravity real(r8) :: r ! dry air gas constant @@ -212,6 +214,7 @@ module micro_mg1_5 ! flags logical :: microp_uniform logical :: do_cldice +logical :: use_hetfrz_classnuc real(r8) :: rhosu ! typical 850mn air density @@ -238,19 +241,9 @@ module micro_mg1_5 real(r8) :: cons27 real(r8) :: cons28 -! Generic interface for packing routines -interface pack_array - module procedure pack_array_1Dr8 - module procedure pack_array_2Dr8 - module procedure pack_array_3Dr8 -end interface +character(len=16) :: micro_mg_precip_frac_method ! type of precipitation fraction method +real(r8) :: micro_mg_berg_eff_factor ! berg efficiency factor -interface unpack_array - module procedure unpack_array_1Dr8 - module procedure unpack_array_1Dr8_arrayfill - module procedure unpack_array_2Dr8 - module procedure unpack_array_2Dr8_arrayfill -end interface !=============================================================================== contains @@ -259,18 +252,18 @@ module micro_mg1_5 subroutine micro_mg_init( & kind, gravit, rair, rh2o, cpair, & tmelt_in, latvap, latice, & - rhmini_in, microp_uniform_in, do_cldice_in, & - errstring, dcs_in) - - !----------------------------------------------------------------------- - ! - ! Purpose: + rhmini_in, micro_mg_dcs, microp_uniform_in, do_cldice_in, use_hetfrz_classnuc_in, & + micro_mg_precip_frac_method_in, micro_mg_berg_eff_factor_in, errstring) + + !----------------------------------------------------------------------- + ! + ! Purpose: ! initialize constants for MG microphysics - ! + ! ! Author: Andrew Gettelman Dec 2005 - ! + ! !----------------------------------------------------------------------- - + integer, intent(in) :: kind ! Kind used for reals real(r8), intent(in) :: gravit real(r8), intent(in) :: rair @@ -280,18 +273,26 @@ subroutine micro_mg_init( & real(r8), intent(in) :: latvap real(r8), intent(in) :: latice real(r8), intent(in) :: rhmini_in ! Minimum rh for ice cloud fraction > 0. + real(r8), intent(in) :: micro_mg_dcs - logical, intent(in) :: microp_uniform_in ! .true. = configure uniform for sub-columns + logical, intent(in) :: microp_uniform_in ! .true. = configure for sub-columns ! .false. = use w/o sub-columns (standard) logical, intent(in) :: do_cldice_in ! .true. = do all processes (standard) ! .false. = skip all processes affecting ! cloud ice - real(r8), intent(in) :: dcs_in !autoconversion size threshold for cloud ice to snow (m) + logical, intent(in) :: use_hetfrz_classnuc_in ! use heterogeneous freezing + + character(len=16),intent(in) :: micro_mg_precip_frac_method_in ! type of precipitation fraction method + real(r8), intent(in) :: micro_mg_berg_eff_factor_in ! berg efficiency factor + character(128), intent(out) :: errstring ! Output status (non-blank for error return) + !----------------------------------------------------------------------- + dcs = micro_mg_dcs + errstring = ' ' if( kind .ne. r8 ) then @@ -307,6 +308,9 @@ subroutine micro_mg_init( & cpp = cpair ! specific heat of dry air tmelt = tmelt_in rhmini = rhmini_in + micro_mg_precip_frac_method = micro_mg_precip_frac_method_in + micro_mg_berg_eff_factor = micro_mg_berg_eff_factor_in + ! latent heats @@ -317,6 +321,7 @@ subroutine micro_mg_init( & ! flags microp_uniform = microp_uniform_in do_cldice = do_cldice_in + use_hetfrz_classnuc = use_hetfrz_classnuc_in ! typical air density at 850 mb @@ -330,15 +335,13 @@ subroutine micro_mg_init( & ! Ice nucleation temperature icenuct = tmelt - 5._r8 - dcs = dcs_in - ! Define constants to help speed up code (this limits calls to gamma function) ! Unused names: cons6, cons15, cons21, cons26 cons1=gamma(1._r8+dsph) cons4=gamma(1._r8+br) cons5=gamma(4._r8+br) - cons7=gamma(1._r8+bs) - cons8=gamma(4._r8+bs) + cons7=gamma(1._r8+bs) + cons8=gamma(4._r8+bs) cons11=gamma(3._r8+bs) cons13=gamma(5._r8/2._r8+br/2._r8) cons14=gamma(5._r8/2._r8+bs/2._r8) @@ -357,52 +360,52 @@ end subroutine micro_mg_init !microphysics routine for each timestep goes here... subroutine micro_mg_tend ( & - mgncol, mgcols, nlev, top_lev, deltatin, & - tn, qn, & + mgncol, nlev, deltatin, & + t, q, & qcn, qin, & ncn, nin, & - relvarn, accre_enhann, & - pn, pdeln, pint, & + relvar, accre_enhan, & + p, pdel, pint, & cldn, liqcldf, icecldf, & - rate1ord_cw2pr_st, naain, npccnin, rndstn, naconin, & - tlato, qvlato, qctendo, qitendo, nctendo, nitendo, & - effco, effco_fn, effio, precto, precio, & - nevapro, evapsnowo, praino, prodsnowo, cmeouto, deffio, & - pgamrado, lamcrado, qsouto, dsouto, rflxo, sflxo, & - qrouto, reff_raino, reff_snowo, & - qcsevapo, qisevapo, qvreso, cmeiout, vtrmco, vtrmio, & - qcsedteno,qisedteno,prao, prco, mnuccco, mnuccto, & - msacwio, psacwso, bergso, bergo, melto, homoo, & - qcreso, prcio, praio, qireso, & - mnuccro, pracso, meltsdto, frzrdto, mnuccdo, & - nrouto, nsouto, reflo, areflo, areflzo, freflo, & - csrflo, acsrflo, fcsrflo, rercldo, & - ncaio, ncalo, qrouto2, qsouto2, nrouto2, nsouto2, & - drouto2, dsouto2, freqso, freqro, nficeo, & - tnd_qsnown, tnd_nsnown, re_icen, & - errstring) + qcsinksum_rate1ord, naai, npccn, rndst, nacon, & + tlat, qvlat, qctend, qitend, nctend, nitend, & + effc, effc_fn, effi, prect, preci, & + nevapr, evapsnow, prain, prodsnow, cmeout, deffi, & + pgamrad, lamcrad, qsout, dsout, rflx, sflx, & + qrout, reff_rain, reff_snow, & + qcsevap, qisevap, qvres, cmeitot, vtrmc, vtrmi, & + qcsedten,qisedten,pratot, prctot, mnuccctot, mnuccttot, & + msacwitot, psacwstot, bergstot, bergtot, melttot, homotot, & + qcrestot, prcitot, praitot, qirestot, & + mnuccrtot, pracstot, meltsdttot, frzrdttot, mnuccdtot, & + nrout, nsout, refl, arefl, areflz, frefl, & + csrfl, acsrfl, fcsrfl, rercld, & + ncai, ncal, qrout2, qsout2, nrout2, nsout2, & + drout2, dsout2, freqs, freqr, nfice, qcrat, & + errstring, & + tnd_qsnow, tnd_nsnow, re_ice, & + prer_evap, & + frzimm, frzcnt, frzdep) !Authors: Hugh Morrison, Andrew Gettelman, NCAR, Peter Caldwell, LLNL ! e-mail: morrison@ucar.edu, andrew@ucar.edu ! input arguments integer, intent(in) :: mgncol ! number of microphysics columns - integer, intent(in) :: mgcols(:) ! list of microphysics columns integer, intent(in) :: nlev ! number of layers - integer, intent(in) :: top_lev ! top level to do microphysics real(r8), intent(in) :: deltatin ! time step (s) - real(r8), intent(in) :: tn(:,:) ! input temperature (K) - real(r8), intent(in) :: qn(:,:) ! input h20 vapor mixing ratio (kg/kg) - real(r8), intent(in) :: relvarn(:,:) ! relative variance of cloud water (-) - real(r8), intent(in) :: accre_enhann(:,:) ! optional accretion enhancement factor (-) + real(r8), intent(in) :: t(:,:) ! input temperature (K) + real(r8), intent(in) :: q(:,:) ! input h20 vapor mixing ratio (kg/kg) + real(r8), intent(in) :: relvar(:,:) ! relative variance of cloud water (-) + real(r8), intent(in) :: accre_enhan(:,:) ! optional accretion enhancement factor (-) ! note: all input cloud variables are grid-averaged real(r8), intent(in) :: qcn(:,:) ! cloud water mixing ratio (kg/kg) real(r8), intent(in) :: qin(:,:) ! cloud ice mixing ratio (kg/kg) real(r8), intent(in) :: ncn(:,:) ! cloud water number conc (1/kg) real(r8), intent(in) :: nin(:,:) ! cloud ice number conc (1/kg) - real(r8), intent(in) :: pn(:,:) ! air pressure (pa) - real(r8), intent(in) :: pdeln(:,:) ! pressure difference across level (pa) + real(r8), intent(in) :: p(:,:) ! air pressure (pa) + real(r8), intent(in) :: pdel(:,:) ! pressure difference across level (pa) ! hm add 11-16-11, interface pressure real(r8), intent(in) :: pint(:,:) ! level interface pressure (pa) real(r8), intent(in) :: cldn(:,:) ! cloud fraction (no units) @@ -410,103 +413,113 @@ subroutine micro_mg_tend ( & real(r8), intent(in) :: icecldf(:,:) ! ice cloud fraction (no units) ! used for scavenging ! Inputs for aerosol activation - real(r8), intent(in) :: naain(:,:) ! ice nucleation number (from microp_aero_ts) (1/kg) - real(r8), intent(in) :: npccnin(:,:) ! ccn activated number tendency (from microp_aero_ts) (1/kg*s) + real(r8), intent(in) :: naai(:,:) ! ice nucleation number (from microp_aero_ts) (1/kg) + real(r8), intent(in) :: npccn(:,:) ! ccn activated number tendency (from microp_aero_ts) (1/kg*s) ! Note that for these variables, the dust bin is assumed to be the last index. ! (For example, in CAM, the last dimension is always size 4.) - real(r8), intent(in) :: rndstn(:,:,:) ! radius of each dust bin, for contact freezing (from microp_aero_ts) (m) - real(r8), intent(in) :: naconin(:,:,:) ! number in each dust bin, for contact freezing (from microp_aero_ts) (1/m^3) - - ! Used with CARMA cirrus microphysics - ! (or similar external microphysics model) - real(r8), intent(in) :: tnd_qsnown(:,:) ! snow mass tendency (kg/kg/s) - real(r8), intent(in) :: tnd_nsnown(:,:) ! snow number tendency (#/kg/s) - real(r8), intent(in) :: re_icen(:,:) ! ice effective radius (m) + real(r8), intent(in) :: rndst(:,:,:) ! radius of each dust bin, for contact freezing (from microp_aero_ts) (m) + real(r8), intent(in) :: nacon(:,:,:) ! number in each dust bin, for contact freezing (from microp_aero_ts) (1/m^3) ! output arguments - real(r8), intent(out) :: rate1ord_cw2pr_st(:,:) ! 1st order rate for + real(r8), intent(out) :: qcsinksum_rate1ord(:,:) ! 1st order rate for ! direct cw to precip conversion - real(r8), intent(out) :: tlato(:,:) ! latent heating rate (W/kg) - real(r8), intent(out) :: qvlato(:,:) ! microphysical tendency qv (1/s) - real(r8), intent(out) :: qctendo(:,:) ! microphysical tendency qc (1/s) - real(r8), intent(out) :: qitendo(:,:) ! microphysical tendency qi (1/s) - real(r8), intent(out) :: nctendo(:,:) ! microphysical tendency nc (1/(kg*s)) - real(r8), intent(out) :: nitendo(:,:) ! microphysical tendency ni (1/(kg*s)) - real(r8), intent(out) :: effco(:,:) ! droplet effective radius (micron) - real(r8), intent(out) :: effco_fn(:,:) ! droplet effective radius, assuming nc = 1.e8 kg-1 - real(r8), intent(out) :: effio(:,:) ! cloud ice effective radius (micron) - real(r8), intent(out) :: precto(:) ! surface precip rate (m/s) - real(r8), intent(out) :: precio(:) ! cloud ice/snow precip rate (m/s) - real(r8), intent(out) :: nevapro(:,:) ! evaporation rate of rain + snow (1/s) - real(r8), intent(out) :: evapsnowo(:,:) ! sublimation rate of snow (1/s) - real(r8), intent(out) :: praino(:,:) ! production of rain + snow (1/s) - real(r8), intent(out) :: prodsnowo(:,:) ! production of snow (1/s) - real(r8), intent(out) :: cmeouto(:,:) ! evap/sub of cloud (1/s) - real(r8), intent(out) :: deffio(:,:) ! ice effective diameter for optics (radiation) (micron) - real(r8), intent(out) :: pgamrado(:,:) ! ice gamma parameter for optics (radiation) (no units) - real(r8), intent(out) :: lamcrado(:,:) ! slope of droplet distribution for optics (radiation) (1/m) - real(r8), intent(out) :: qsouto(:,:) ! snow mixing ratio (kg/kg) - real(r8), intent(out) :: dsouto(:,:) ! snow diameter (m) - real(r8), intent(out) :: rflxo(:,:) ! grid-box average rain flux (kg m^-2 s^-1) - real(r8), intent(out) :: sflxo(:,:) ! grid-box average snow flux (kg m^-2 s^-1) - real(r8), intent(out) :: qrouto(:,:) ! grid-box average rain mixing ratio (kg/kg) - real(r8), intent(out) :: reff_raino(:,:) ! rain effective radius (micron) - real(r8), intent(out) :: reff_snowo(:,:) ! snow effective radius (micron) - real(r8), intent(out) :: qcsevapo(:,:) ! cloud water evaporation due to sedimentation (1/s) - real(r8), intent(out) :: qisevapo(:,:) ! cloud ice sublimation due to sublimation (1/s) - real(r8), intent(out) :: qvreso(:,:) ! residual condensation term to ensure RH < 100% (1/s) - real(r8), intent(out) :: cmeiout(:,:) ! grid-mean cloud ice sub/dep (1/s) - real(r8), intent(out) :: vtrmco(:,:) ! mass-weighted cloud water fallspeed (m/s) - real(r8), intent(out) :: vtrmio(:,:) ! mass-weighted cloud ice fallspeed (m/s) - real(r8), intent(out) :: qcsedteno(:,:) ! qc sedimentation tendency (1/s) - real(r8), intent(out) :: qisedteno(:,:) ! qi sedimentation tendency (1/s) + real(r8), intent(out) :: tlat(:,:) ! latent heating rate (W/kg) + real(r8), intent(out) :: qvlat(:,:) ! microphysical tendency qv (1/s) + real(r8), intent(out) :: qctend(:,:) ! microphysical tendency qc (1/s) + real(r8), intent(out) :: qitend(:,:) ! microphysical tendency qi (1/s) + real(r8), intent(out) :: nctend(:,:) ! microphysical tendency nc (1/(kg*s)) + real(r8), intent(out) :: nitend(:,:) ! microphysical tendency ni (1/(kg*s)) + real(r8), intent(out) :: effc(:,:) ! droplet effective radius (micron) + real(r8), intent(out) :: effc_fn(:,:) ! droplet effective radius, assuming nc = 1.e8 kg-1 + real(r8), intent(out) :: effi(:,:) ! cloud ice effective radius (micron) + real(r8), intent(out) :: prect(:) ! surface precip rate (m/s) + real(r8), intent(out) :: preci(:) ! cloud ice/snow precip rate (m/s) + real(r8), intent(out) :: nevapr(:,:) ! evaporation rate of rain + snow (1/s) + real(r8), intent(out) :: evapsnow(:,:) ! sublimation rate of snow (1/s) + real(r8), intent(out) :: prain(:,:) ! production of rain + snow (1/s) + real(r8), intent(out) :: prodsnow(:,:) ! production of snow (1/s) + real(r8), intent(out) :: cmeout(:,:) ! evap/sub of cloud (1/s) + real(r8), intent(out) :: deffi(:,:) ! ice effective diameter for optics (radiation) (micron) + real(r8), intent(out) :: pgamrad(:,:) ! ice gamma parameter for optics (radiation) (no units) + real(r8), intent(out) :: lamcrad(:,:) ! slope of droplet distribution for optics (radiation) (1/m) + real(r8), intent(out) :: qsout(:,:) ! snow mixing ratio (kg/kg) + real(r8), intent(out) :: dsout(:,:) ! snow diameter (m) + real(r8), intent(out) :: rflx(:,:) ! grid-box average rain flux (kg m^-2 s^-1) + real(r8), intent(out) :: sflx(:,:) ! grid-box average snow flux (kg m^-2 s^-1) + real(r8), intent(out) :: qrout(:,:) ! grid-box average rain mixing ratio (kg/kg) + real(r8), intent(out) :: reff_rain(:,:) ! rain effective radius (micron) + real(r8), intent(out) :: reff_snow(:,:) ! snow effective radius (micron) + real(r8), intent(out) :: qcsevap(:,:) ! cloud water evaporation due to sedimentation (1/s) + real(r8), intent(out) :: qisevap(:,:) ! cloud ice sublimation due to sublimation (1/s) + real(r8), intent(out) :: qvres(:,:) ! residual condensation term to ensure RH < 100% (1/s) + real(r8), intent(out) :: cmeitot(:,:) ! grid-mean cloud ice sub/dep (1/s) + real(r8), intent(out) :: vtrmc(:,:) ! mass-weighted cloud water fallspeed (m/s) + real(r8), intent(out) :: vtrmi(:,:) ! mass-weighted cloud ice fallspeed (m/s) + real(r8), intent(out) :: qcsedten(:,:) ! qc sedimentation tendency (1/s) + real(r8), intent(out) :: qisedten(:,:) ! qi sedimentation tendency (1/s) ! microphysical process rates for output (mixing ratio tendencies) (all have units of 1/s) - real(r8), intent(out) :: prao(:,:) ! accretion of cloud by rain - real(r8), intent(out) :: prco(:,:) ! autoconversion of cloud to rain - real(r8), intent(out) :: mnuccco(:,:) ! mixing ratio tend due to immersion freezing - real(r8), intent(out) :: mnuccto(:,:) ! mixing ratio tend due to contact freezing - real(r8), intent(out) :: msacwio(:,:) ! mixing ratio tend due to H-M splintering - real(r8), intent(out) :: psacwso(:,:) ! collection of cloud water by snow - real(r8), intent(out) :: bergso(:,:) ! bergeron process on snow - real(r8), intent(out) :: bergo(:,:) ! bergeron process on cloud ice - real(r8), intent(out) :: melto(:,:) ! melting of cloud ice - real(r8), intent(out) :: homoo(:,:) ! homogeneous freezing cloud water - real(r8), intent(out) :: qcreso(:,:) ! residual cloud condensation due to removal of excess supersat - real(r8), intent(out) :: prcio(:,:) ! autoconversion of cloud ice to snow - real(r8), intent(out) :: praio(:,:) ! accretion of cloud ice by snow - real(r8), intent(out) :: qireso(:,:) ! residual ice deposition due to removal of excess supersat - real(r8), intent(out) :: mnuccro(:,:) ! mixing ratio tendency due to heterogeneous freezing of rain to snow (1/s) - real(r8), intent(out) :: pracso(:,:) ! mixing ratio tendency due to accretion of rain by snow (1/s) - real(r8), intent(out) :: meltsdto(:,:) ! latent heating rate due to melting of snow (W/kg) - real(r8), intent(out) :: frzrdto(:,:) ! latent heating rate due to homogeneous freezing of rain (W/kg) - real(r8), intent(out) :: mnuccdo(:,:) ! mass tendency from ice nucleation - real(r8), intent(out) :: nrouto(:,:) ! rain number concentration (1/m3) - real(r8), intent(out) :: nsouto(:,:) ! snow number concentration (1/m3) - real(r8), intent(out) :: reflo(:,:) ! analytic radar reflectivity - real(r8), intent(out) :: areflo(:,:) ! average reflectivity will zero points outside valid range - real(r8), intent(out) :: areflzo(:,:) ! average reflectivity in z. - real(r8), intent(out) :: freflo(:,:) ! fractional occurrence of radar reflectivity - real(r8), intent(out) :: csrflo(:,:) ! cloudsat reflectivity - real(r8), intent(out) :: acsrflo(:,:) ! cloudsat average - real(r8), intent(out) :: fcsrflo(:,:) ! cloudsat fractional occurrence of radar reflectivity - real(r8), intent(out) :: rercldo(:,:) ! effective radius calculation for rain + cloud - real(r8), intent(out) :: ncaio(:,:) ! output number conc of ice nuclei available (1/m3) - real(r8), intent(out) :: ncalo(:,:) ! output number conc of CCN (1/m3) - real(r8), intent(out) :: qrouto2(:,:) ! copy of qrout as used to compute drout2 - real(r8), intent(out) :: qsouto2(:,:) ! copy of qsout as used to compute dsout2 - real(r8), intent(out) :: nrouto2(:,:) ! copy of nrout as used to compute drout2 - real(r8), intent(out) :: nsouto2(:,:) ! copy of nsout as used to compute dsout2 - real(r8), intent(out) :: drouto2(:,:) ! mean rain particle diameter (m) - real(r8), intent(out) :: dsouto2(:,:) ! mean snow particle diameter (m) - real(r8), intent(out) :: freqso(:,:) ! fractional occurrence of snow - real(r8), intent(out) :: freqro(:,:) ! fractional occurrence of rain - real(r8), intent(out) :: nficeo(:,:) ! fractional occurrence of ice - - character(128), intent(out) :: errstring ! output status (non-blank for error return) + real(r8), intent(out) :: pratot(:,:) ! accretion of cloud by rain + real(r8), intent(out) :: prctot(:,:) ! autoconversion of cloud to rain + real(r8), intent(out) :: mnuccctot(:,:) ! mixing ratio tend due to immersion freezing + real(r8), intent(out) :: mnuccttot(:,:) ! mixing ratio tend due to contact freezing + real(r8), intent(out) :: msacwitot(:,:) ! mixing ratio tend due to H-M splintering + real(r8), intent(out) :: psacwstot(:,:) ! collection of cloud water by snow + real(r8), intent(out) :: bergstot(:,:) ! bergeron process on snow + real(r8), intent(out) :: bergtot(:,:) ! bergeron process on cloud ice + real(r8), intent(out) :: melttot(:,:) ! melting of cloud ice + real(r8), intent(out) :: homotot(:,:) ! homogeneous freezing cloud water + real(r8), intent(out) :: qcrestot(:,:) ! residual cloud condensation due to removal of excess supersat + real(r8), intent(out) :: prcitot(:,:) ! autoconversion of cloud ice to snow + real(r8), intent(out) :: praitot(:,:) ! accretion of cloud ice by snow + real(r8), intent(out) :: qirestot(:,:) ! residual ice deposition due to removal of excess supersat + real(r8), intent(out) :: mnuccrtot(:,:) ! mixing ratio tendency due to heterogeneous freezing of rain to snow (1/s) + real(r8), intent(out) :: pracstot(:,:) ! mixing ratio tendency due to accretion of rain by snow (1/s) + real(r8), intent(out) :: meltsdttot(:,:) ! latent heating rate due to melting of snow (W/kg) + real(r8), intent(out) :: frzrdttot(:,:) ! latent heating rate due to homogeneous freezing of rain (W/kg) + real(r8), intent(out) :: mnuccdtot(:,:) ! mass tendency from ice nucleation + real(r8), intent(out) :: nrout(:,:) ! rain number concentration (1/m3) + real(r8), intent(out) :: nsout(:,:) ! snow number concentration (1/m3) + real(r8), intent(out) :: refl(:,:) ! analytic radar reflectivity + real(r8), intent(out) :: arefl(:,:) ! average reflectivity will zero points outside valid range + real(r8), intent(out) :: areflz(:,:) ! average reflectivity in z. + real(r8), intent(out) :: frefl(:,:) ! fractional occurrence of radar reflectivity + real(r8), intent(out) :: csrfl(:,:) ! cloudsat reflectivity + real(r8), intent(out) :: acsrfl(:,:) ! cloudsat average + real(r8), intent(out) :: fcsrfl(:,:) ! cloudsat fractional occurrence of radar reflectivity + real(r8), intent(out) :: rercld(:,:) ! effective radius calculation for rain + cloud + real(r8), intent(out) :: ncai(:,:) ! output number conc of ice nuclei available (1/m3) + real(r8), intent(out) :: ncal(:,:) ! output number conc of CCN (1/m3) + real(r8), intent(out) :: qrout2(:,:) ! copy of qrout as used to compute drout2 + real(r8), intent(out) :: qsout2(:,:) ! copy of qsout as used to compute dsout2 + real(r8), intent(out) :: nrout2(:,:) ! copy of nrout as used to compute drout2 + real(r8), intent(out) :: nsout2(:,:) ! copy of nsout as used to compute dsout2 + real(r8), intent(out) :: drout2(:,:) ! mean rain particle diameter (m) + real(r8), intent(out) :: dsout2(:,:) ! mean snow particle diameter (m) + real(r8), intent(out) :: freqs(:,:) ! fractional occurrence of snow + real(r8), intent(out) :: freqr(:,:) ! fractional occurrence of rain + real(r8), intent(out) :: nfice(:,:) ! fractional occurrence of ice + real(r8), intent(out) :: qcrat(:,:) ! limiter for qc process rates (1=no limit --> 0. no qc) + + real(r8), intent(out) :: prer_evap(:,:) + + character(128), intent(out) :: errstring ! output status (non-blank for error return) + + ! Tendencies calculated by external schemes that can replace MG's native + ! process tendencies. + ! Used with CARMA cirrus microphysics + ! (or similar external microphysics model) + real(r8), intent(in), pointer :: tnd_qsnow(:,:) ! snow mass tendency (kg/kg/s) + real(r8), intent(in), pointer :: tnd_nsnow(:,:) ! snow number tendency (#/kg/s) + real(r8), intent(in), pointer :: re_ice(:,:) ! ice effective radius (m) + + ! From external ice nucleation. + real(r8), intent(in), pointer :: frzimm(:,:) ! Number tendency due to immersion freezing (1/cm3) + real(r8), intent(in), pointer :: frzcnt(:,:) ! Number tendency due to contact freezing (1/cm3) + real(r8), intent(in), pointer :: frzdep(:,:) ! Number tendency due to deposition nucleation (1/cm3) ! local workspace ! all units mks unless otherwise stated @@ -514,122 +527,14 @@ subroutine micro_mg_tend ( & ! parameters real(r8), parameter :: mincld = 0.0001_r8 ! minimum allowed cloud fraction real(r8), parameter :: cdnl = 0.e6_r8 ! cloud droplet number limiter - ! assign number of sub-steps to iter - ! use 2 sub-steps, following tests described in MG2008 - integer, parameter :: iter = 2 ! local copies of input variables - real(r8) :: q(mgncol,nlev) ! water vapor mixing ratio (kg/kg) - real(r8) :: t(mgncol,nlev) ! temperature (K) real(r8) :: qc(mgncol,nlev) ! cloud liquid mixing ratio (kg/kg) real(r8) :: qi(mgncol,nlev) ! cloud ice mixing ratio (kg/kg) real(r8) :: nc(mgncol,nlev) ! cloud liquid number concentration (1/kg) real(r8) :: ni(mgncol,nlev) ! cloud liquid number concentration (1/kg) - real(r8) :: p(mgncol,nlev) ! pressure (Pa) - real(r8) :: pdel(mgncol,nlev) ! pressure difference across level (Pa) - real(r8) :: relvar(mgncol,nlev) ! relative variance of cloud water (-) - real(r8) :: accre_enhan(mgncol,nlev) ! optional accretion enhancement factor (-) - - real(r8) :: naai(mgncol,nlev) ! ice nucleation number (from microp_aero_ts) (1/kg) - real(r8) :: npccn(mgncol,nlev) ! ccn activated number tendency (from microp_aero_ts) (1/kg*s) - - real(r8), allocatable :: rndst(:,:,:) - real(r8), allocatable :: nacon(:,:,:) - - real(r8) :: tnd_qsnow(mgncol,nlev) ! snow mass tendency (kg/kg/s) - real(r8) :: tnd_nsnow(mgncol,nlev) ! snow number tendency (#/kg/s) - real(r8) :: re_ice(mgncol,nlev) ! ice effective radius (m) - - ! Packed copies of output variables - real(r8) :: tlat(mgncol,nlev) ! latent heating rate (W/kg) - real(r8) :: qvlat(mgncol,nlev) ! microphysical tendency qv (1/s) - real(r8) :: qctend(mgncol,nlev) ! microphysical tendency qc (1/s) - real(r8) :: qitend(mgncol,nlev) ! microphysical tendency qi (1/s) - real(r8) :: nctend(mgncol,nlev) ! microphysical tendency nc (1/(kg*s)) - real(r8) :: nitend(mgncol,nlev) ! microphysical tendency ni (1/(kg*s)) - - real(r8) :: effc(mgncol,nlev) ! droplet effective radius (micron) - real(r8) :: effc_fn(mgncol,nlev) ! droplet effective radius, assuming nc = 1.e8 kg-1 - real(r8) :: effi(mgncol,nlev) ! cloud ice effective radius (micron) - - real(r8) :: prect(mgncol) ! surface precip rate (m/s) - real(r8) :: preci(mgncol) ! cloud ice/snow precip rate (m/s) - - real(r8) :: nevapr(mgncol,nlev) ! evaporation rate of rain + snow (1/s) - real(r8) :: evapsnow(mgncol,nlev) ! sublimation rate of snow (1/s) - real(r8) :: prain(mgncol,nlev) ! production of rain + snow (1/s) - real(r8) :: prodsnow(mgncol,nlev) ! production of snow (1/s) - real(r8) :: cmeout(mgncol,nlev) ! evap/sub of cloud (1/s) - real(r8) :: deffi(mgncol,nlev) ! ice effective diameter for optics (radiation) (micron) - real(r8) :: pgamrad(mgncol,nlev) ! ice gamma parameter for optics (radiation) (no units) - real(r8) :: lamcrad(mgncol,nlev) ! slope of droplet distribution for optics (radiation) (1/m) - - - real(r8) :: qsout(mgncol,nlev) ! snow mixing ratio (kg/kg) - real(r8) :: qsout2(mgncol,nlev) ! copy of qsout as used to compute dsout2 - real(r8) :: nsout(mgncol,nlev) ! snow number concentration (1/m3) - real(r8) :: nsout2(mgncol,nlev) ! copy of nsout as used to compute dsout2 - real(r8) :: dsout(mgncol,nlev) ! snow diameter (m) - real(r8) :: dsout2(mgncol,nlev) ! mean snow particle diameter (m) - - real(r8) :: qrout(mgncol,nlev) ! grid-box average rain mixing ratio (kg/kg) - real(r8) :: qrout2(mgncol,nlev) ! copy of qrout as used to compute drout2 - real(r8) :: nrout(mgncol,nlev) ! rain number concentration (1/m3) - real(r8) :: nrout2(mgncol,nlev) ! copy of nrout as used to compute drout2 - real(r8) :: drout2(mgncol,nlev) ! mean rain particle diameter (m) - - real(r8) :: reff_rain(mgncol,nlev) ! rain effective radius (micron) - real(r8) :: reff_snow(mgncol,nlev) ! snow effective radius (micron) - - real(r8) :: freqs(mgncol,nlev) ! fractional occurrence of snow - real(r8) :: freqr(mgncol,nlev) ! fractional occurrence of rain - - real(r8) :: rflx(mgncol,nlev+1) ! grid-box average rain flux (kg m^-2 s^-1) - real(r8) :: sflx(mgncol,nlev+1) ! grid-box average snow flux (kg m^-2 s^-1) - - real(r8) :: qcsevap(mgncol,nlev) ! cloud water evaporation due to sedimentation (1/s) - real(r8) :: qisevap(mgncol,nlev) ! cloud ice sublimation due to sublimation (1/s) - real(r8) :: qvres(mgncol,nlev) ! residual condensation term to ensure RH < 100% (1/s) - real(r8) :: cmeitot(mgncol,nlev) ! grid-mean cloud ice sub/dep (1/s) - real(r8) :: vtrmc(mgncol,nlev) ! mass-weighted cloud water fallspeed (m/s) - real(r8) :: vtrmi(mgncol,nlev) ! mass-weighted cloud ice fallspeed (m/s) - real(r8) :: qcsedten(mgncol,nlev) ! qc sedimentation tendency (1/s) - real(r8) :: qisedten(mgncol,nlev) ! qi sedimentation tendency (1/s) - - real(r8) :: pratot(mgncol,nlev) ! accretion of cloud by rain - real(r8) :: prctot(mgncol,nlev) ! autoconversion of cloud to rain - real(r8) :: mnuccctot(mgncol,nlev) ! mixing ratio tend due to immersion freezing - real(r8) :: mnuccttot(mgncol,nlev) ! mixing ratio tend due to contact freezing - real(r8) :: msacwitot(mgncol,nlev) ! mixing ratio tend due to H-M splintering - real(r8) :: psacwstot(mgncol,nlev) ! collection of cloud water by snow - real(r8) :: bergstot(mgncol,nlev) ! bergeron process on snow - real(r8) :: bergtot(mgncol,nlev) ! bergeron process on cloud ice - real(r8) :: melttot(mgncol,nlev) ! melting of cloud ice - real(r8) :: homotot(mgncol,nlev) ! homogeneous freezing cloud water - real(r8) :: qcrestot(mgncol,nlev) ! residual cloud condensation due to removal of excess supersat - real(r8) :: prcitot(mgncol,nlev) ! autoconversion of cloud ice to snow - real(r8) :: praitot(mgncol,nlev) ! accretion of cloud ice by snow - real(r8) :: qirestot(mgncol,nlev) ! residual ice deposition due to removal of excess supersat - real(r8) :: mnuccrtot(mgncol,nlev) ! mixing ratio tendency due to heterogeneous freezing of rain to snow (1/s) - real(r8) :: pracstot(mgncol,nlev) ! mixing ratio tendency due to accretion of rain by snow (1/s) - real(r8) :: mnuccdtot(mgncol,nlev) ! mass tendency from ice nucleation - real(r8) :: meltsdttot(mgncol,nlev) ! latent heating rate due to melting of snow (W/kg) - real(r8) :: frzrdttot(mgncol,nlev) ! latent heating rate due to homogeneous freezing of rain (W/kg) - - real(r8) :: refl(mgncol,nlev) ! analytic radar reflectivity - real(r8) :: arefl(mgncol,nlev) ! average reflectivity will zero points outside valid range - real(r8) :: areflz(mgncol,nlev) ! average reflectivity in z. - real(r8) :: frefl(mgncol,nlev) ! fractional occurrence of radar reflectivity - real(r8) :: csrfl(mgncol,nlev) ! cloudsat reflectivity - real(r8) :: acsrfl(mgncol,nlev) ! cloudsat average - real(r8) :: fcsrfl(mgncol,nlev) ! cloudsat fractional occurrence of radar reflectivity - - real(r8) :: rercld(mgncol,nlev) ! effective radius calculation for rain + cloud - - real(r8) :: nfice(mgncol,nlev) ! fractional occurrence of ice - - real(r8) :: ncai(mgncol,nlev) ! output number conc of ice nuclei available (1/m3) - real(r8) :: ncal(mgncol,nlev) ! output number conc of CCN (1/m3) + + real(r8) :: nevapr2(mgncol,nlev) ! general purpose variables real(r8) :: deltat ! sub-time step (s) @@ -639,16 +544,6 @@ subroutine micro_mg_tend ( & real(r8) :: int_to_mid(mgncol, nlev) ! Coefficients for linear interpolation from ! interface to mid-level - ! temporary variables for sub-stepping - real(r8) :: tlat1(mgncol,nlev) - real(r8) :: qvlat1(mgncol,nlev) - real(r8) :: qctend1(mgncol,nlev) - real(r8) :: qitend1(mgncol,nlev) - real(r8) :: nctend1(mgncol,nlev) - real(r8) :: nitend1(mgncol,nlev) - real(r8) :: prect1(mgncol) - real(r8) :: preci1(mgncol) - ! physical properties of the air at a given point real(r8) :: rho(mgncol,nlev) ! density (kg m-3) real(r8) :: dv(mgncol,nlev) ! diffusivity of water vapor @@ -691,12 +586,11 @@ subroutine micro_mg_tend ( & real(r8) :: lamr(mgncol,nlev) ! slope real(r8) :: n0r(mgncol,nlev) ! intercept - ! combined size of precip & cloud drops - integer :: arcld(mgncol, nlev) ! averaging control flag - ! Rates/tendencies due to: - ! deposition/sublimation of cloud ice - real(r8) :: cmei(mgncol,nlev) + ! deposition of cloud ice + real(r8) :: vap_dep(mgncol,nlev) ! deposition from vapor to ice PMC 12/3/12 + ! sublimation of cloud ice + real(r8) :: ice_sublim(mgncol,nlev) ! sublimation from ice to vapor PMC 12/3/12 ! ice nucleation real(r8) :: nnuccd(mgncol,nlev) ! number rate from deposition/cond.-freezing real(r8) :: mnuccd(mgncol,nlev) ! mass mixing ratio @@ -706,9 +600,12 @@ subroutine micro_mg_tend ( & ! contact freezing of cloud water real(r8) :: mnucct(mgncol,nlev) ! mass mixing ratio real(r8) :: nnucct(mgncol,nlev) ! number concentration + ! deposition nucleation in mixed-phase clouds (from external scheme) + real(r8) :: mnudep(mgncol,nlev) ! mass mixing ratio + real(r8) :: nnudep(mgncol,nlev) ! number concentration ! HM ice multiplication real(r8) :: msacwi(mgncol,nlev) ! mass mixing ratio - real(r8) :: nsacwi(mgncol,nlev) ! number conc + real(r8) :: nsacwi(mgncol,nlev) ! number concentration ! autoconversion of cloud droplets real(r8) :: prc(mgncol,nlev) ! mass mixing ratio real(r8) :: nprc(mgncol,nlev) ! number concentration (rain) @@ -761,6 +658,9 @@ subroutine micro_mg_tend ( & real(r8) :: acn(mgncol,nlev) ! cloud droplet real(r8) :: ain(mgncol,nlev) ! cloud ice + ! Mass of liquid droplets used with external heterogeneous freezing. + real(r8) :: mi0l(mgncol) + ! saturation vapor pressures real(r8) :: esl(mgncol,nlev) ! liquid real(r8) :: esi(mgncol,nlev) ! ice @@ -769,7 +669,7 @@ subroutine micro_mg_tend ( & ! saturation vapor mixing ratios real(r8) :: qvl(mgncol,nlev) ! liquid real(r8) :: qvi(mgncol,nlev) ! ice - real(r8) :: qsn ! checking for RH after rain evap + real(r8) :: qvn ! checking for RH after rain evap ! relative humidity real(r8) :: relhum(mgncol,nlev) @@ -803,8 +703,7 @@ subroutine micro_mg_tend ( & real(r8) :: qstot(mgncol) ! snow mixing ratio real(r8) :: nstot(mgncol) ! snow number concentration - ! for calculation of rate1ord_cw2pr_st - real(r8) :: qcsinksum_rate1ord(mgncol,nlev) ! sum over iterations of cw to precip sink + ! for calculation of rate1ord real(r8) :: qcsum_rate1ord(mgncol,nlev) ! sum over iterations of cloud water real(r8) :: rainrt(mgncol,nlev) ! rain rate for reflectivity calculation @@ -812,15 +711,15 @@ subroutine micro_mg_tend ( & ! dummy variables real(r8) :: dum real(r8) :: dum1 + real(r8) :: dum2 ! dummies for checking RH real(r8) :: qtmp real(r8) :: ttmp + real(r8) :: qtmp1 + real(r8) :: ttmp1 ! dummies for conservation check - real(r8) :: qce ! qc - real(r8) :: qie ! qi - real(r8) :: nce ! nc - real(r8) :: nie ! ni real(r8) :: ratio + real(r8) :: tmpfrz ! dummies for in-cloud variables real(r8) :: dumc(mgncol,nlev) ! qc real(r8) :: dumnc(mgncol,nlev) ! nc @@ -833,66 +732,48 @@ subroutine micro_mg_tend ( & ! loop array variables ! "i" and "k" are column/level iterators for internal (MG) variables - ! "ii" and "kk" are used for indices into input/output buffers - ! "it" is substepping variable - ! "n" is used for other iterations (currently just sedimentation) - integer i, ii, k, kk, it, n + ! "n" is used for other looping (currently just sedimentation) + integer i, k, n - ! number of iterations for loops over "n" + ! number of sub-steps for loops over "n" (for sedimentation) integer nstep + ! Whether or not to limit evaporation/sublimation of precip at each grid + ! point. + logical :: limit_precip_evap_sublim + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ! default return error message errstring = ' ' + if (.not. (do_cldice .or. & + (associated(tnd_qsnow) .and. associated(tnd_nsnow) .and. associated(re_ice)))) then + errstring = "MG's native cloud ice processes are disabled, but & + &no replacement values were passed in." + end if + + if (use_hetfrz_classnuc .and. (.not. & + (associated(frzimm) .and. associated(frzcnt) .and. associated(frzdep)))) then + errstring = "External heterogeneous freezing is enabled, but the & + &required tendencies were not all passed in." + end if + ! Process inputs - ! assign variable deltat for sub-stepping... + ! assign variable deltat to deltatin deltat = deltatin - call pack_array( qn, mgcols, top_lev, q) - call pack_array( tn, mgcols, top_lev, t) - call pack_array( qcn, mgcols, top_lev, qc) - call pack_array( qin, mgcols, top_lev, qi) - call pack_array( ncn, mgcols, top_lev, nc) - call pack_array( nin, mgcols, top_lev, ni) - call pack_array( pn, mgcols, top_lev, p) - call pack_array( pdeln, mgcols, top_lev, pdel) - call pack_array( relvarn, mgcols, top_lev, relvar) - call pack_array(accre_enhann, mgcols, top_lev, accre_enhan) - - call pack_array( naain, mgcols, top_lev, naai) - call pack_array(npccnin, mgcols, top_lev, npccn) - - ! These are allocated instead of used as automatic arrays - ! purely to work around a PGI bug. - allocate(rndst(mgncol,nlev,size(rndstn,3))) - allocate(nacon(mgncol,nlev,size(rndstn,3))) - call pack_array( rndstn, mgcols, top_lev, rndst) - call pack_array(naconin, mgcols, top_lev, nacon) - - if (.not. do_cldice) then - call pack_array(tnd_qsnown, mgcols, top_lev, tnd_qsnow) - call pack_array(tnd_nsnown, mgcols, top_lev, tnd_nsnow) - call pack_array( re_icen, mgcols, top_lev, re_ice) - end if - - ! Some inputs are only used once, to create a reference array that is - ! used repeatedly later. Rather than bothering to pack these, just - ! set the local reference directly from the inputs. + ! Copies of input concentrations that may be changed internally. + qc = qcn + nc = ncn + qi = qin + ni = nin ! pint: used to set int_to_mid ! interface to mid-level linear interpolation do k = 1,nlev - do i = 1, mgncol - ! Set ii and kk to values that correspond to i and k. - ii = mgcols(i) - kk = k + top_lev - 1 - - int_to_mid(i,k) = (p(i,k) - pint(ii,kk))/ & - (pint(ii,kk+1) - pint(ii,kk)) - end do + int_to_mid(:,k) = (p(:,k) - pint(:,k)) / (pint(:,k+1) - pint(:,k)) end do ! cldn: used to set cldm, unused for subcolumns @@ -921,17 +802,9 @@ subroutine micro_mg_tend ( & else ! get cloud fraction, check for minimum - - do k = 1,nlev - do i = 1, mgncol - ii = mgcols(i) - kk = k + top_lev - 1 - - cldm(i,k) = max(cldn(ii,kk),mincld) - lcldm(i,k) = max(liqcldf(ii,kk),mincld) - icldm(i,k) = max(icecldf(ii,kk),mincld) - end do - end do + cldm = max(cldn,mincld) + lcldm = max(liqcldf,mincld) + icldm = max(icecldf,mincld) end if ! Initialize local variables @@ -976,74 +849,13 @@ subroutine micro_mg_tend ( & end do end do - where (qvl <= 0.0_r8) - relhum = q - elsewhere - relhum = q / min(1.0_r8,qvl) - end where + relhum = q / max(qvl, qsmall) !=============================================== - ! Processes done before substepping - !=============================================== - - ! Initial deposition/sublimation of ice - !=========================================== - - if (do_cldice) then - - call ice_deposition_sublimation_init(deltat, t, q, qc, qi, ni, & - lcldm, icldm, naai, rho, dv, & - esl, esi, qvl, qvi, relhum, & - berg, cmei) - - else - berg = 0._r8 - cmei = 0._r8 - end if ! end do_cldice - - !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - ! droplet activation - ! hm, modify 5/12/11 - ! get provisional droplet number after activation. This is used for - ! all microphysical process calculations, for consistency with update of - ! droplet mass before microphysics - - ! calculate potential for droplet activation if cloud water is present - ! tendency from activation (npccn) is read in from companion routine - - ! output activated liquid and ice (convert from #/kg -> #/m3) - !-------------------------------------------------- - where (qc >= qsmall) - nc = nc + npccn*deltat - ncal = max(nc/lcldm,cdnl/rho)*rho ! sghan minimum in #/cm3 - elsewhere - ncal = 0._r8 - end where - - where (t < icenuct) - ncai = naai*rho - elsewhere - ncai = 0._r8 - end where - - !INITIALIZE STUFF FOR SUBSTEPPING - !=============================================== - - ! get sub-step time step - deltat=deltat/real(iter) ! hm, set mtime here to avoid answer-changing mtime=deltat - ! initialize tendencies to zero - tlat1 = 0._r8 - qvlat1 = 0._r8 - qctend1 = 0._r8 - qitend1 = 0._r8 - nctend1 = 0._r8 - nitend1 = 0._r8 - - ! initialize microphysics output qcsevap=0._r8 qisevap=0._r8 @@ -1078,7 +890,7 @@ subroutine micro_mg_tend ( & sflx=0._r8 ! initialize precip output - + qrout=0._r8 qsout=0._r8 nrout=0._r8 @@ -1089,139 +901,122 @@ subroutine micro_mg_tend ( & ! initialize rain size rercld=0._r8 - arcld = 0 - qcsinksum_rate1ord = 0._r8 - qcsum_rate1ord = 0._r8 + qcsinksum_rate1ord = 0._r8 + qcsum_rate1ord = 0._r8 ! initialize variables for trop_mozart nevapr = 0._r8 + nevapr2 = 0._r8 evapsnow = 0._r8 prain = 0._r8 prodsnow = 0._r8 cmeout = 0._r8 - prect1 = 0._r8 - preci1 = 0._r8 - cldmax = mincld lamc=0._r8 + ! initialize microphysical tendencies - !*********DO SUBSTEPPING!*************** - !============================================ - substepping: do it=1,iter + tlat=0._r8 + qvlat=0._r8 + qctend=0._r8 + qitend=0._r8 + qstend = 0._r8 + qrtend = 0._r8 + nctend=0._r8 + nitend=0._r8 + nrtend = 0._r8 + nstend = 0._r8 - ! initialize sub-step microphysical tendencies + ! initialize diagnostic precipitation to zero + qcic = 0._r8 + qiic = 0._r8 + qsic = 0._r8 + qric = 0._r8 - tlat=0._r8 - qvlat=0._r8 - qctend=0._r8 - qitend=0._r8 - qstend = 0._r8 - qrtend = 0._r8 - nctend=0._r8 - nitend=0._r8 - nrtend = 0._r8 - nstend = 0._r8 + ncic = 0._r8 + niic = 0._r8 + nsic = 0._r8 + nric = 0._r8 - ! initialize diagnostic precipitation to zero - qcic = 0._r8 - qiic = 0._r8 - qsic = 0._r8 - qric = 0._r8 + ! initialize precip at surface - ncic = 0._r8 - niic = 0._r8 - nsic = 0._r8 - nric = 0._r8 + prect = 0._r8 + preci = 0._r8 - ! initialize precip at surface + ! initialize vertically-integrated rain and snow tendencies - prect = 0._r8 - preci = 0._r8 + qrtot = 0._r8 + nrtot = 0._r8 + qstot = 0._r8 + nstot = 0._r8 - ! initialize vertically-integrated rain and snow tendencies + ! initialize precip fallspeeds to zero + ums = 0._r8 + uns = 0._r8 + umr = 0._r8 + unr = 0._r8 - qrtot = 0._r8 - nrtot = 0._r8 - qstot = 0._r8 - nstot = 0._r8 - - ! recalculate saturation vapor pressure for liquid and ice - do k = 1, nlev - do i = 1, mgncol - - call qsat_water(t(i,k), p(i,k), esl(i,k), qvl(i,k)) - - ! hm fix, make sure when above freezing that esi=esl, not active yet - if (t(i,k) >= tmelt) then - esi(i,k)=esl(i,k) - qvi(i,k)=qvl(i,k) - else - call qsat_ice(t(i,k), p(i,k), esi(i,k), qvi(i,k)) - end if - - end do - end do - - where (qvl <= 0.0_r8) - relhum = q - elsewhere - relhum = q / min(1.0_r8,qvl) - end where + ! initialize limiter for output + qcrat = 1._r8 - ! decrease in number concentration due to sublimation/evap - !------------------------------------------------------- - ! divide by cloud fraction to get in-cloud decrease - ! don't reduce Nc due to bergeron process + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! droplet activation + ! hm, modify 5/12/11 + ! get provisional droplet number after activation. This is used for + ! all microphysical process calculations, for consistency with update of + ! droplet mass before microphysics - where (cmei < 0._r8 .and. qi > qsmall .and. icldm > mincld) - nsubi = cmei / qi * ni / icldm - elsewhere - nsubi = 0._r8 - end where + ! calculate potential for droplet activation if cloud water is present + ! tendency from activation (npccn) is read in from companion routine - nsubc = 0._r8 + ! output activated liquid and ice (convert from #/kg -> #/m3) + !-------------------------------------------------- + where (qc >= qsmall) + nc = max(nc + npccn*deltat, cdnl*lcldm/rho) + ncal = nc*rho/lcldm ! sghan minimum in #/cm3 + elsewhere + ncal = 0._r8 + end where - ! ice nucleation if activated nuclei exist at t<-5C AND rhmini + 5% - !------------------------------------------------------- + where (t < icenuct) + ncai = naai*rho + elsewhere + ncai = 0._r8 + end where - if (do_cldice) then - where (naai > 0._r8 .and. t < icenuct .and. & - relhum*esl/esi > rhmini+0.05_r8) + !=============================================== - !if NAAI > 0. then set numice = naai (as before) - !note: this is gridbox averaged - ! hm, modify to use mtime - nnuccd = (naai-ni/icldm)/mtime*icldm - nnuccd = max(nnuccd,0._r8) - nimax = naai*icldm + ! ice nucleation if activated nuclei exist at t<-5C AND rhmini + 5% + !------------------------------------------------------- - !Calc mass of new particles using new crystal mass... - !also this will be multiplied by mtime as nnuccd is... + if (do_cldice) then + where (naai > 0._r8 .and. t < icenuct .and. & + relhum*esl/esi > rhmini+0.05_r8) - mnuccd = nnuccd * mi0 + !if NAAI > 0. then set numice = naai (as before) + !note: this is gridbox averaged + ! hm, modify to use mtime + nnuccd = (naai-ni/icldm)/mtime*icldm + nnuccd = max(nnuccd,0._r8) + nimax = naai*icldm - ! add mnuccd to cmei.... - cmei = cmei + mnuccd - - ! limit cmei - !------------------------------------------------------- - cmei = min(cmei,(q-qvi)/calc_ab(t, qvi, xxls)/deltat) + !Calc mass of new particles using new crystal mass... + !also this will be multiplied by mtime as nnuccd is... - ! limit for roundoff error - cmei = cmei * omsm + mnuccd = nnuccd * mi0 - elsewhere - nnuccd = 0._r8 - nimax = 0._r8 - mnuccd = 0._r8 - end where + elsewhere + nnuccd = 0._r8 + nimax = 0._r8 + mnuccd = 0._r8 + end where - end if + end if + !============================================================================= pre_vert_loop: do k=1,nlev pre_col_loop: do i=1,mgncol @@ -1231,7 +1026,7 @@ subroutine micro_mg_tend ( & ! for microphysical process calculations ! units are kg/kg for mixing ratio, 1/kg for number conc - if (qc(i,k) - berg(i,k)*deltat.ge.qsmall) then + if (qc(i,k).ge.qsmall) then ! limit in-cloud values to 0.005 kg/kg qcic(i,k)=min(qc(i,k)/lcldm(i,k),5.e-3_r8) ncic(i,k)=max(nc(i,k)/lcldm(i,k),0._r8) @@ -1243,11 +1038,9 @@ subroutine micro_mg_tend ( & else qcic(i,k)=0._r8 ncic(i,k)=0._r8 - - berg(i,k)=qc(i,k)/deltat*omsm end if - if (qi(i,k)+(cmei(i,k)+berg(i,k))*deltat.ge.qsmall) then + if (qi(i,k).ge.qsmall) then ! limit in-cloud values to 0.005 kg/kg qiic(i,k)=min(qi(i,k)/icldm(i,k),5.e-3_r8) niic(i,k)=max(ni(i,k)/icldm(i,k),0._r8) @@ -1259,27 +1052,12 @@ subroutine micro_mg_tend ( & else qiic(i,k)=0._r8 niic(i,k)=0._r8 - - if (do_cldice) then - cmei(i,k)=(-qi(i,k)/deltat-berg(i,k))*omsm - end if end if end do pre_col_loop end do pre_vert_loop - ! add to cme output - cmeout = cmeout + cmei - - !========================================================= - ! Main microphysical loop - !========================================================= - - ! initialize precip fallspeeds to zero - ums = 0._r8 - uns = 0._r8 - umr = 0._r8 - unr = 0._r8 + !======================================================================== ! for sub-columns cldm has already been set to 1 if cloud ! water or ice is present, so cldmax will be correctly set below @@ -1289,16 +1067,37 @@ subroutine micro_mg_tend ( & micro_vert_loop: do k=1,nlev - ! calculate precip fraction based on maximum overlap assumption + if (trim(micro_mg_precip_frac_method) == 'in_cloud') then + + do i=1, mgncol + + if (k .eq. 1) then + cldmax(i,k)=cldm(i,k) + else + + if (qc(i,k).ge.qsmall.or.qi(i,k).ge.qsmall) then + cldmax(i,k)=cldm(i,k) + else + cldmax(i,k)=cldmax(i,k-1) + end if + + endif + + enddo + else if(trim(micro_mg_precip_frac_method) == 'max_overlap') then + + ! calculate precip fraction based on maximum overlap assumption + + ! if rain or snow mix ratios are smaller than threshold, + ! then leave cldmax as cloud fraction at current level + if (k /= 1) then + where (qric(:,k-1).ge.qsmall .or. qsic(:,k-1).ge.qsmall) + cldmax(:,k)=max(cldmax(:,k-1),cldmax(:,k)) + end where + end if + + endif - ! if rain or snow mix ratios are smaller than threshold, - ! then leave cldmax as cloud fraction at current level - if (k /= 1) then - where (qric(:,k-1).ge.qsmall .or. qsic(:,k-1).ge.qsmall) - cldmax(:,k)=max(cldmax(:,k-1),cldmax(:,k)) - end where - end if - do i = 1, mgncol !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc @@ -1387,7 +1186,7 @@ subroutine micro_mg_tend ( & nric(:,k)=0._r8 end where - ! make sure number concentration is a positive number to avoid + ! make sure number concentration is a positive number to avoid ! taking root of negative later nric(:,k)=max(nric(:,k),0._r8) @@ -1415,7 +1214,7 @@ subroutine micro_mg_tend ( & ! add autoconversion to flux from level above to get provisional snow mixing ratio ! and number concentration (qsic and nsic) - ! hm 11-16-11 modify for mid-point method, see comments above + ! hm 11-16-11 modify for mid-point-type method, see comments above if (k == 1) then dum=(asn(i,k)*cons25) @@ -1451,7 +1250,7 @@ subroutine micro_mg_tend ( & nsic(:,k)=0._r8 end where - ! make sure number concentration is a positive number to avoid + ! make sure number concentration is a positive number to avoid ! taking root of negative later nsic(:,k)=max(nsic(:,k),0._r8) @@ -1493,34 +1292,66 @@ subroutine micro_mg_tend ( & end where if (do_cldice) then + if (.not. use_hetfrz_classnuc) then - ! heterogeneous freezing of cloud water - !---------------------------------------------- + ! heterogeneous freezing of cloud water + !---------------------------------------------- - call immersion_freezing(t(:,k), pgam(:,k), lamc(:,k), cdist1(:,k), qcic(:,k), & - relvar(:,k), mnuccc(:,k), nnuccc(:,k)) + call immersion_freezing(t(:,k), pgam(:,k), lamc(:,k), cdist1(:,k), qcic(:,k), & + relvar(:,k), mnuccc(:,k), nnuccc(:,k)) - ! make sure number of droplets frozen does not exceed available ice nuclei concentration - ! this prevents 'runaway' droplet freezing + ! make sure number of droplets frozen does not exceed available ice nuclei concentration + ! this prevents 'runaway' droplet freezing - where (qcic(:,k).ge.qsmall .and. t(:,k).lt.269.15_r8) - where (nnuccc(:,k)*lcldm(:,k).gt.nnuccd(:,k)) - ! scale mixing ratio of droplet freezing with limit - mnuccc(:,k)=mnuccc(:,k)*(nnuccd(:,k)/(nnuccc(:,k)*lcldm(:,k))) - nnuccc(:,k)=nnuccd(:,k)/lcldm(:,k) + where (qcic(:,k).ge.qsmall .and. t(:,k).lt.269.15_r8) + where (nnuccc(:,k)*lcldm(:,k).gt.nnuccd(:,k)) + ! scale mixing ratio of droplet freezing with limit + mnuccc(:,k)=mnuccc(:,k)*(nnuccd(:,k)/(nnuccc(:,k)*lcldm(:,k))) + nnuccc(:,k)=nnuccd(:,k)/lcldm(:,k) + end where end where - end where - call contact_freezing(t(:,k), p(:,k), rndst(:,k,:), nacon(:,k,:), & - pgam(:,k), lamc(:,k), cdist1(:,k), qcic(:,k), & - relvar(:,k), mnucct(:,k), nnucct(:,k)) + call contact_freezing(t(:,k), p(:,k), rndst(:,k,:), nacon(:,k,:), & + pgam(:,k), lamc(:,k), cdist1(:,k), qcic(:,k), & + relvar(:,k), mnucct(:,k), nnucct(:,k)) + + mnudep(:,k)=0._r8 + nnudep(:,k)=0._r8 + + else + + mi0l = qcic(:,k)/max(ncic(:,k), 1.0e6_r8/rho(:,k)) + mi0l = max(mi0l_min, mi0l) + + where (qcic(:,k) >= qsmall) + nnuccc(:,k) = frzimm(:,k)*1.0e6_r8/rho(:,k) + mnuccc(:,k) = nnuccc(:,k)*mi0l + + nnucct(:,k) = frzcnt(:,k)*1.0e6_r8/rho(:,k) + mnucct(:,k) = nnucct(:,k)*mi0l + nnudep(:,k) = frzdep(:,k)*1.0e6_r8/rho(:,k) + mnudep(:,k) = nnudep(:,k)*mi0 + elsewhere + nnuccc(:,k) = 0._r8 + mnuccc(:,k) = 0._r8 + + nnucct(:,k) = 0._r8 + mnucct(:,k) = 0._r8 + + nnudep(:,k) = 0._r8 + mnudep(:,k) = 0._r8 + end where + + end if else - mnuccc(:,k)=0._r8 - nnuccc(:,k)=0._r8 - mnucct(:,k)=0._r8 - nnucct(:,k)=0._r8 + mnuccc(:,k)=0._r8 + nnuccc(:,k)=0._r8 + mnucct(:,k)=0._r8 + nnucct(:,k)=0._r8 + mnudep(:,k)=0._r8 + nnudep(:,k)=0._r8 end if call snow_self_aggregation(t(:,k), rho(:,k), asn(:,k), qsic(:,k), nsic(:,k), & @@ -1556,17 +1387,38 @@ subroutine micro_mg_tend ( & prai(:,k) = 0._r8 nprai(:,k) = 0._r8 end if - + call evaporate_sublimate_precip(deltat, t(:,k), p(:,k), rho(:,k), & dv(:,k), mu(:,k), sc(:,k), q(:,k), qvl(:,k), qvi(:,k), & lcldm(:,k), cldmax(:,k), arn(:,k), asn(:,k), qcic(:,k), qiic(:,k), & - qric(:,k), qsic(:,k), lamr(:,k), n0r(:,k), lams(:,k), n0s(:,k), cmei(:,k), & + qric(:,k), qsic(:,k), lamr(:,k), n0r(:,k), lams(:,k), n0s(:,k), & pre(:,k), prds(:,k)) - call bergeron_process(t(:,k), rho(:,k), dv(:,k), mu(:,k), sc(:,k), & + call bergeron_process_snow(t(:,k), rho(:,k), dv(:,k), mu(:,k), sc(:,k), & qvl(:,k), qvi(:,k), asn(:,k), qcic(:,k), qsic(:,k), lams(:,k), n0s(:,k), & bergs(:,k)) + !+++PMC 12/3/12 - NEW VAPOR DEP/SUBLIMATION GOES HERE!!! + if (do_cldice) then + + call ice_deposition_sublimation(deltat, t(:,k), q(:,k), qc(:,k), qi(:,k), ni(:,k), & + lcldm(:,k),icldm(:,k), naai(:,k), rho(:,k), dv(:,k), qvl(:,k), qvi(:,k), & + berg(:,k), vap_dep(:,k), ice_sublim(:,k)) + + where (vap_dep(:,k) < 0._r8 .and. qi(:,k) > qsmall .and. icldm(:,k) > mincld) + nsubi(:,k) = vap_dep(:,k) / qi(:,k) * ni(:,k) / icldm(:,k) + elsewhere + nsubi(:,k) = 0._r8 + end where + + ! bergeron process should not reduce nc unless + ! all ql is removed (which is handled elsewhere) + !in fact, nothing in this entire file makes nsubc nonzero. + nsubc(:,k) = 0._r8 + + end if !do_cldice + !---PMC 12/3/12 + ! Big "administration" loop enforces conservation, updates variables ! that accumulate over substeps, and sets output variables. @@ -1576,42 +1428,128 @@ subroutine micro_mg_tend ( & ! in case microphysical process rates are large !=================================================================== - ! make sure to use end-of-time step values for cloud water, ice, due - ! condensation/deposition - ! note: for check on conservation, processes are multiplied by omsm ! to prevent problems due to round off error - qce=(qc(i,k) - berg(i,k)*deltat) - nce=nc(i,k) - qie=(qi(i,k)+(cmei(i,k)+berg(i,k))*deltat) - nie=(ni(i,k)+nnuccd(i,k)*deltat) - ! conservation of qc !------------------------------------------------------------------- - dum = (prc(i,k)+pra(i,k)+mnuccc(i,k)+mnucct(i,k)+msacwi(i,k)+ & - psacws(i,k)+bergs(i,k))*lcldm(i,k)*deltat - - if (dum.gt.qce) then - ratio = qce/deltat/lcldm(i,k)/(prc(i,k)+pra(i,k)+mnuccc(i,k)+mnucct(i,k)+msacwi(i,k)+psacws(i,k)+bergs(i,k))*omsm + dum = ((prc(i,k)+pra(i,k)+mnuccc(i,k)+mnucct(i,k)+msacwi(i,k)+ & + psacws(i,k)+bergs(i,k))*lcldm(i,k)+berg(i,k))*deltat + if (dum.gt.qc(i,k)) then + ratio = qc(i,k)/deltat/((prc(i,k)+pra(i,k)+mnuccc(i,k)+mnucct(i,k)+ & + msacwi(i,k)+psacws(i,k)+bergs(i,k))*lcldm(i,k)+berg(i,k))*omsm prc(i,k) = prc(i,k)*ratio pra(i,k) = pra(i,k)*ratio mnuccc(i,k) = mnuccc(i,k)*ratio - mnucct(i,k) = mnucct(i,k)*ratio - msacwi(i,k) = msacwi(i,k)*ratio + mnucct(i,k) = mnucct(i,k)*ratio + msacwi(i,k) = msacwi(i,k)*ratio psacws(i,k) = psacws(i,k)*ratio bergs(i,k) = bergs(i,k)*ratio + berg(i,k) = berg(i,k)*ratio + qcrat(i,k) = ratio + else + qcrat(i,k) = 1._r8 end if + !PMC 12/3/12: ratio is also frac of step w/ liquid. + !thus we apply berg for "ratio" of timestep and vapor + !deposition for the remaining frac of the timestep. + if (qc(i,k) >= qsmall) then + vap_dep(i,k) = vap_dep(i,k)*(1._r8-qcrat(i,k)) + end if + + !================================================================= + ! apply limiter to ensure that ice/snow sublimation and rain evap + ! don't push conditions into supersaturation, and ice deposition/nucleation don't + ! push conditions into sub-saturation + ! note this is done after qc conservation since we don't know how large + ! vap_dep is before then + ! estimates are only approximate since other process terms haven't been limited + ! for conservation yet + + ! first limit ice deposition/nucleation vap_dep + mnuccd + dum1 = vap_dep(i,k) + mnuccd(i,k) + if (dum1 > 1.e-20_r8) then + dum = (q(i,k)-qvi(i,k))/(1._r8 + cons28*qvi(i,k)/(cpp*rv*t(i,k)**2))/deltat + dum = max(dum,0._r8) + if (dum1 > dum) then + dum1=mnuccd(i,k)/(vap_dep(i,k)+mnuccd(i,k)) + ! don't divide by cloud fraction since grid-mean rate + mnuccd(i,k)=dum*dum1/deltat + + ! don't divide by cloud fraction since grid-mean rate + vap_dep(i,k)=dum*(1._r8-dum1)/deltat + end if + end if + + ! next limit ice and snow sublimation and rain evaporation + ! get estimate of q and t at end of time step + ! don't include other microphysical processes since they haven't + ! been limited via conservation checks yet + + if ((pre(i,k)+prds(i,k))*cldmax(i,k)+ice_sublim(i,k) < -1.e-20_r8) then + + qtmp=q(i,k)-(ice_sublim(i,k)+vap_dep(i,k)+mnuccd(i,k)+ & + (pre(i,k)+prds(i,k))*cldmax(i,k))*deltat + ttmp=t(i,k)+((pre(i,k)*cldmax(i,k))*xxlv+ & + (prds(i,k)*cldmax(i,k)+vap_dep(i,k)+ice_sublim(i,k)+mnuccd(i,k))*xxls)*deltat/cpp + + ! If the unlimited tendencies are so large that ttmp is + ! extremely low, qsat_water may hit a floating point + ! exception, so just automatically limit temperatures below + ! 50 K to prevent this. + if (ttmp <= 50._r8) then + limit_precip_evap_sublim = .true. + else + ! Else, check to see if we are pushing temperature down + ! and q up enough to become super-saturated. + call qsat_water(ttmp, p(i,k), esn, qvn) + limit_precip_evap_sublim = (qtmp > qvn) + end if + + ! modify ice/precip evaporation rate if q > qsat + if (limit_precip_evap_sublim) then + + dum1=pre(i,k)*cldmax(i,k)/((pre(i,k)+prds(i,k))*cldmax(i,k)+ice_sublim(i,k)) + dum2=prds(i,k)*cldmax(i,k)/((pre(i,k)+prds(i,k))*cldmax(i,k)+ice_sublim(i,k)) + ! recalculate q and t after vap_dep and mnuccd but without evap or sublim + qtmp=q(i,k)-(vap_dep(i,k)+mnuccd(i,k))*deltat + ttmp=t(i,k)+((vap_dep(i,k)+mnuccd(i,k))*xxls)*deltat/cpp + + ! use rhw to allow ice supersaturation + call qsat_water(ttmp, p(i,k), esn, qvn) + + dum=(qtmp-qvn)/(1._r8 + cons27*qvn/(cpp*rv*ttmp**2)) + dum=min(dum,0._r8) + + ! modify rates if needed, divide by cldmax to get local (in-precip) value + pre(i,k)=dum*dum1/deltat/cldmax(i,k) + + ! do separately using RHI for prds and ice_sublim + call qsat_ice(ttmp, p(i,k), esn, qvn) + + dum=(qtmp-qvn)/(1._r8 + cons28*qvn/(cpp*rv*ttmp**2)) + dum=min(dum,0._r8) + + ! modify rates if needed, divide by cldmax to get local (in-precip) value + prds(i,k) = dum*dum2/deltat/cldmax(i,k) + + ! don't divide ice_sublim by cloud fraction since it is grid-averaged + dum1 = (1._r8-dum1-dum2) + ice_sublim(i,k) = dum*dum1/deltat + end if + end if + + !=================================================================== ! conservation of nc !------------------------------------------------------------------- dum = (nprc1(i,k)+npra(i,k)+nnuccc(i,k)+nnucct(i,k)+ & npsacws(i,k)-nsubc(i,k))*lcldm(i,k)*deltat - if (dum.gt.nce) then - ratio = nce/deltat/((nprc1(i,k)+npra(i,k)+nnuccc(i,k)+nnucct(i,k)+& + if (dum.gt.nc(i,k)) then + ratio = nc(i,k)/deltat/((nprc1(i,k)+npra(i,k)+nnuccc(i,k)+nnucct(i,k)+& npsacws(i,k)-nsubc(i,k))*lcldm(i,k))*omsm nprc1(i,k) = nprc1(i,k)*ratio @@ -1626,33 +1564,40 @@ subroutine micro_mg_tend ( & ! conservation of qi !------------------------------------------------------------------- - dum = ((-mnuccc(i,k)-mnucct(i,k)-msacwi(i,k))*lcldm(i,k)+(prci(i,k)+ & - prai(i,k))*icldm(i,k))*deltat - - if (dum.gt.qie) then + dum = ((-mnuccc(i,k)-mnucct(i,k)-mnudep(i,k)-msacwi(i,k))*lcldm(i,k)+(prci(i,k)+ & + prai(i,k))*icldm(i,k)-ice_sublim(i,k)-vap_dep(i,k)-berg(i,k)-mnuccd(i,k))*deltat - ratio = (qie/deltat+(mnuccc(i,k)+mnucct(i,k)+msacwi(i,k))*lcldm(i,k))/ & - ((prci(i,k)+prai(i,k))*icldm(i,k))*omsm + if (dum.gt.qi(i,k)) then + ratio = (qi(i,k)/deltat+vap_dep(i,k)+berg(i,k)+mnuccd(i,k)+ & + (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k))*lcldm(i,k))/ & + ((prci(i,k)+prai(i,k))*icldm(i,k)-ice_sublim(i,k))*omsm prci(i,k) = prci(i,k)*ratio prai(i,k) = prai(i,k)*ratio + ice_sublim(i,k) = ice_sublim(i,k)*ratio end if ! conservation of ni !------------------------------------------------------------------- - dum = ((-nnucct(i,k)-nsacwi(i,k))*lcldm(i,k)+(nprci(i,k)+ & - nprai(i,k)-nsubi(i,k))*icldm(i,k))*deltat - - if (dum.gt.nie) then + if (use_hetfrz_classnuc) then + tmpfrz = nnuccc(i,k) + else + tmpfrz = 0._r8 + end if + dum = ((-nnucct(i,k)-tmpfrz-nnudep(i,k)-nsacwi(i,k))*lcldm(i,k)+(nprci(i,k)+ & + nprai(i,k)-nsubi(i,k))*icldm(i,k)-nnuccd(i,k))*deltat - ratio = (nie/deltat+(nnucct(i,k)+nsacwi(i,k))*lcldm(i,k))/ & + if (dum.gt.ni(i,k)) then + ratio = (ni(i,k)/deltat+nnuccd(i,k)+ & + (nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k))*lcldm(i,k))/ & ((nprci(i,k)+nprai(i,k)-nsubi(i,k))*icldm(i,k))*omsm nprci(i,k) = nprci(i,k)*ratio nprai(i,k) = nprai(i,k)*ratio nsubi(i,k) = nsubi(i,k)*ratio end if + end if - ! for precipitation conservation, use logic that vertical integral + ! for precipitation conservation, use logic that vertical integral ! of tendency from current level to top of model (i.e., qrtot) cannot be negative ! conservation of rain mixing rat @@ -1663,7 +1608,7 @@ subroutine micro_mg_tend ( & if (-pre(i,k)+pracs(i,k)+mnuccr(i,k).ge.qsmall) then ratio = (qrtot(i)/(dz(i,k)*rho(i,k))+(prc(i,k)+pra(i,k))*lcldm(i,k))/& - ((-pre(i,k)+pracs(i,k)+mnuccr(i,k))*cldmax(i,k))*omsm + ((-pre(i,k)+pracs(i,k)+mnuccr(i,k))*cldmax(i,k))*omsm pre(i,k) = pre(i,k)*ratio pracs(i,k) = pracs(i,k)*ratio @@ -1728,25 +1673,26 @@ subroutine micro_mg_tend ( & ! get tendencies due to microphysical conversion processes !========================================================== - ! note: tendencies are multiplied by appropriate cloud/precip + ! note: tendencies are multiplied by appropriate cloud/precip ! fraction to get grid-scale values - ! note: cmei is already grid-average values + ! note: vap_dep is already grid-average values - qvlat(i,k) = qvlat(i,k)-(pre(i,k)+prds(i,k))*cldmax(i,k)-cmei(i,k) + qvlat(i,k) = qvlat(i,k)-(pre(i,k)+prds(i,k))*cldmax(i,k)-& + vap_dep(i,k)-ice_sublim(i,k)-mnuccd(i,k)-mnudep(i,k)*lcldm(i,k) tlat(i,k) = tlat(i,k)+((pre(i,k)*cldmax(i,k)) & - *xxlv+(prds(i,k)*cldmax(i,k)+cmei(i,k))*xxls+ & + *xxlv+(prds(i,k)*cldmax(i,k)+vap_dep(i,k)+ice_sublim(i,k)+mnuccd(i,k)+mnudep(i,k)*lcldm(i,k))*xxls+ & ((bergs(i,k)+psacws(i,k)+mnuccc(i,k)+mnucct(i,k)+msacwi(i,k))*lcldm(i,k)+(mnuccr(i,k)+ & pracs(i,k))*cldmax(i,k)+berg(i,k))*xlf) qctend(i,k) = qctend(i,k)+ & - (-pra(i,k)-prc(i,k)-mnuccc(i,k)-mnucct(i,k)-msacwi(i,k)- & + (-pra(i,k)-prc(i,k)-mnuccc(i,k)-mnucct(i,k)-msacwi(i,k)- & psacws(i,k)-bergs(i,k))*lcldm(i,k)-berg(i,k) if (do_cldice) then qitend(i,k) = qitend(i,k)+ & - (mnuccc(i,k)+mnucct(i,k)+msacwi(i,k))*lcldm(i,k)+(-prci(i,k)- & - prai(i,k))*icldm(i,k)+cmei(i,k)+berg(i,k) + (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k))*lcldm(i,k)+(-prci(i,k)- & + prai(i,k))*icldm(i,k)+vap_dep(i,k)+berg(i,k)+ice_sublim(i,k)+mnuccd(i,k) end if qrtend(i,k) = qrtend(i,k)+ & @@ -1757,8 +1703,10 @@ subroutine micro_mg_tend ( & (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k)+(prds(i,k)+ & pracs(i,k)+mnuccr(i,k))*cldmax(i,k) + cmeout(i,k) = cmeout(i,k) + vap_dep(i,k) + ice_sublim(i,k) + mnuccd(i,k) + ! add output for cmei (accumulate) - cmeitot(i,k) = cmeitot(i,k) + cmei(i,k) + cmeitot(i,k) = cmeitot(i,k) + vap_dep(i,k) + ice_sublim(i,k) + mnuccd(i,k) ! assign variables for trop_mozart, these are grid-average !------------------------------------------------------------------- @@ -1766,6 +1714,7 @@ subroutine micro_mg_tend ( & evapsnow(i,k) = evapsnow(i,k)-prds(i,k)*cldmax(i,k) nevapr(i,k) = nevapr(i,k)-pre(i,k)*cldmax(i,k) + nevapr2(i,k) = nevapr2(i,k)-pre(i,k)*cldmax(i,k) ! change to make sure prain is positive: do not remove snow from ! prain used for wet deposition @@ -1778,35 +1727,43 @@ subroutine micro_mg_tend ( & ! to rain and snow (1/s), for later use in aerosol wet removal routine ! previously, wetdepa used (prain/qc) for this, and the qc in wetdepa may be smaller than the qc ! used to calculate pra, prc, ... in this routine - ! qcsinksum_rate1ord = sum over iterations{ rate of direct transfer of cloud water to rain & snow } + ! qcsinksum_rate1ord = { rate of direct transfer of cloud water to rain & snow } ! (no cloud ice or bergeron terms) - ! qcsum_rate1ord = sum over iterations{ qc used in calculation of the transfer terms } + ! qcsum_rate1ord = { qc used in calculation of the transfer terms } - qcsinksum_rate1ord(i,k) = qcsinksum_rate1ord(i,k) + (pra(i,k)+prc(i,k)+psacws(i,k))*lcldm(i,k) - qcsum_rate1ord(i,k) = qcsum_rate1ord(i,k) + qc(i,k) + qcsinksum_rate1ord(i,k) = qcsinksum_rate1ord(i,k) + (pra(i,k)+prc(i,k)+psacws(i,k))*lcldm(i,k) + qcsum_rate1ord(i,k) = qcsum_rate1ord(i,k) + qc(i,k) ! microphysics output, note this is grid-averaged pratot(i,k)=pratot(i,k)+pra(i,k)*lcldm(i,k) prctot(i,k)=prctot(i,k)+prc(i,k)*lcldm(i,k) mnuccctot(i,k)=mnuccctot(i,k)+mnuccc(i,k)*lcldm(i,k) mnuccttot(i,k)=mnuccttot(i,k)+mnucct(i,k)*lcldm(i,k) - mnuccdtot(i,k)=mnuccdtot(i,k)+mnuccd(i,k)*lcldm(i,k) msacwitot(i,k)=msacwitot(i,k)+msacwi(i,k)*lcldm(i,k) psacwstot(i,k)=psacwstot(i,k)+psacws(i,k)*lcldm(i,k) bergstot(i,k)=bergstot(i,k)+bergs(i,k)*lcldm(i,k) + bergtot(i,k)=bergtot(i,k)+berg(i,k) + prcitot(i,k)=prcitot(i,k)+prci(i,k)*icldm(i,k) praitot(i,k)=praitot(i,k)+prai(i,k)*icldm(i,k) - mnuccrtot(i,k)=mnuccrtot(i,k)+mnuccr(i,k)*cldmax(i,k) + mnuccdtot(i,k)=mnuccdtot(i,k)+mnuccd(i,k)*icldm(i,k) + pracstot(i,k)=pracstot(i,k)+pracs(i,k)*cldmax(i,k) + mnuccrtot(i,k)=mnuccrtot(i,k)+mnuccr(i,k)*cldmax(i,k) nctend(i,k) = nctend(i,k)+& - (-nnuccc(i,k)-nnucct(i,k)-npsacws(i,k)+nsubc(i,k) & + (-nnuccc(i,k)-nnucct(i,k)-npsacws(i,k)+nsubc(i,k) & -npra(i,k)-nprc1(i,k))*lcldm(i,k) if (do_cldice) then + if (use_hetfrz_classnuc) then + tmpfrz = nnuccc(i,k) + else + tmpfrz = 0._r8 + end if nitend(i,k) = nitend(i,k)+ nnuccd(i,k)+ & - (nnucct(i,k)+nsacwi(i,k))*lcldm(i,k)+(nsubi(i,k)-nprci(i,k)- & + (nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k))*lcldm(i,k)+(nsubi(i,k)-nprci(i,k)- & nprai(i,k))*icldm(i,k) end if @@ -1827,7 +1784,7 @@ subroutine micro_mg_tend ( & end if end do - + ! End of "administration" loop ! get final values for precipitation q and N, based on @@ -1976,7 +1933,7 @@ subroutine micro_mg_tend ( & ! if rain/snow mix ratio is zero so should number concentration !========================================================= - + if (qsic(i,k) < qsmall) then qsic(i,k)=0._r8 nsic(i,k)=0._r8 @@ -1987,7 +1944,7 @@ subroutine micro_mg_tend ( & nric(i,k)=0._r8 end if - ! make sure number concentration is a positive number to avoid + ! make sure number concentration is a positive number to avoid ! taking root of negative nric(i,k)=max(nric(i,k),0._r8) @@ -2035,12 +1992,11 @@ subroutine micro_mg_tend ( & end do micro_vert_loop ! end k loop - ! sum over sub-step for average process rates !----------------------------------------------------- - ! convert rain/snow q and N for output to history, note, + ! convert rain/snow q and N for output to history, note, ! output is for gridbox average - ! calculate precip fluxes and adding them to summing sub-stepping variables + ! calculate precip fluxes ! calculate the precip flux (kg/m2/s) as mixingratio(kg/kg)*airdensity(kg/m3)*massweightedfallspeed(m/s) ! --------------------------------------------------------------------- @@ -2061,13 +2017,13 @@ subroutine micro_mg_tend ( & ! Calculate rercld ! calculate mean size of combined rain and cloud water - + ! hm 11-22-11 modify to interpolate rain from interface to mid-point ! logic is to interpolate rain mass and number, then recalculate PSD ! parameters to get relevant parameters for mean size ! interpolate rain mass and number, store in dummy variables - + ! calculate n0r and lamr from interpolated mid-point rain mass and number ! divide by precip fraction to get in-precip (local) values of ! rain mass and number, divide by rhow to get rain number in kg^-1 @@ -2075,7 +2031,7 @@ subroutine micro_mg_tend ( & call size_dist_param_rain(dumr, dumnr, lamr, n0r) call calc_rercld(lamr, n0r, lamc, cdist1, pgam, dumr, qcic, & - arcld, rercld) + rercld) nsout(:,1) = nsout(:,1) + & (int_to_mid(:,1)*nsic(:,1)*cldmax(:,1)*rho(:,1)) @@ -2086,116 +2042,25 @@ subroutine micro_mg_tend ( & sflx(:,2:) = sflx(:,2:) + (qsic*rho*ums*cldmax) - ! Sum into other variables that accumulate over substeps. - tlat1 = tlat1 + tlat - t = t + tlat*deltat/cpp - - qvlat1 = qvlat1 + qvlat - q = q + qvlat*deltat - - qctend1 = qctend1 + qctend - qc = qc + qctend*deltat - - qitend1 = qitend1 + qitend - qi = qi + qitend*deltat - - nctend1 = nctend1 + nctend - nc = nc + nctend*deltat - - nitend1 = nitend1 + nitend - ni = ni + nitend*deltat - - prect1 = prect1 + prect - preci1 = preci1 + preci - - end do substepping ! it loop, sub-step - - ! divide rain radius over substeps for average - where (arcld > 0) rercld = rercld/arcld - - ! convert dt from sub-step back to full time step - !------------------------------------------------------------------- - deltat = deltatin - - ! assign variables back to start-of-timestep values before updating after sub-steps + ! assign variables back to start-of-timestep values + !hm note: only nc is modified above (droplet activation tendency is added on) + !hm thus only nc needs to be assigned to start-of-timestep values !================================================================================ - - call pack_array(qn, mgcols, top_lev, q) - call pack_array(tn, mgcols, top_lev, t) - call pack_array(qcn, mgcols, top_lev, qc) - call pack_array(ncn, mgcols, top_lev, nc) - call pack_array(qin, mgcols, top_lev, qi) - call pack_array(nin, mgcols, top_lev, ni) - !............................................................................. + nc = ncn - ! divide precip rate by number of sub-steps to get average over time step - - prect = prect1/real(iter) - preci = preci1/real(iter) + !............................................................................. - ! divide microphysical tendencies by number of sub-steps to get average over time step !================================================================================ - tlat = tlat1/real(iter) - qvlat = qvlat1/real(iter) - qctend = qctend1/real(iter) - qitend = qitend1/real(iter) - nctend = nctend1/real(iter) - nitend = nitend1/real(iter) - ! Re-apply droplet activation tendency nctend = nctend + npccn - rainrt = rainrt/real(iter) - - ! divide by number of sub-steps to find final values - rflx = rflx/real(iter) - sflx = sflx/real(iter) - - ! divide output precip q and N by number of sub-steps to get average over time step - !================================================================================ - - qrout = qrout/real(iter) - qsout = qsout/real(iter) - nrout = nrout/real(iter) - nsout = nsout/real(iter) - - ! divide trop_mozart variables by number of sub-steps to get average over time step - !================================================================================ - - nevapr = nevapr/real(iter) - evapsnow = evapsnow/real(iter) - prain = prain/real(iter) - prodsnow = prodsnow/real(iter) - ! modify to include snow. in prain & evap (diagnostic here: for wet dep) nevapr = nevapr + evapsnow + prer_evap = nevapr2 prain = prain + prodsnow - cmeout = cmeout/real(iter) - - cmeitot = cmeitot/real(iter) - meltsdttot = meltsdttot/real(iter) - frzrdttot = frzrdttot /real(iter) - - ! microphysics output - pratot=pratot/real(iter) - prctot=prctot/real(iter) - mnuccctot=mnuccctot/real(iter) - mnuccttot=mnuccttot/real(iter) - msacwitot=msacwitot/real(iter) - psacwstot=psacwstot/real(iter) - bergstot=bergstot/real(iter) - bergtot=bergtot/real(iter) - prcitot=prcitot/real(iter) - praitot=praitot/real(iter) - - mnuccrtot=mnuccrtot/real(iter) - pracstot =pracstot /real(iter) - - mnuccdtot=mnuccdtot/real(iter) - sed_col_loop: do i=1,mgncol do k=1,nlev @@ -2203,7 +2068,7 @@ subroutine micro_mg_tend ( & ! calculate sedimentation for cloud water and ice !================================================================================ - ! update in-cloud cloud mixing ratio and number concentration + ! update in-cloud cloud mixing ratio and number concentration ! with microphysical tendencies to calculate sedimentation, assign to dummy vars ! note: these are in-cloud values***, hence we divide by cloud fraction @@ -2376,7 +2241,7 @@ subroutine micro_mg_tend ( & end do !! k loop ! units below are m/s - ! cloud water/ice sedimentation flux at surface + ! cloud water/ice sedimentation flux at surface ! is added to precip flux at surface to get total precip (cloud + precip water) ! rate @@ -2478,7 +2343,7 @@ subroutine micro_mg_tend ( & end if end if - ! remove any excess over-saturation, which is possible due to non-linearity when adding + ! remove any excess over-saturation, which is possible due to non-linearity when adding ! together all microphysical processes !----------------------------------------------------------------- ! follow code similar to old CAM scheme @@ -2487,12 +2352,12 @@ subroutine micro_mg_tend ( & ttmp=t(i,k)+tlat(i,k)/cpp*deltat ! use rhw to allow ice supersaturation - call qsat_water(ttmp, p(i,k), esn, qsn) - qsn = min(qsn,1._r8) + call qsat_water(ttmp, p(i,k), esn, qvn) + qvn = min(qvn,1._r8) - if (qtmp > qsn .and. qsn > 0) then + if (qtmp > qvn .and. qvn > 0) then ! expression below is approximate since there may be ice deposition - dum = (qtmp-qsn)/(1._r8+cons27*qsn/(cpp*rv*ttmp**2))/deltat + dum = (qtmp-qvn)/(1._r8+cons27*qvn/(cpp*rv*ttmp**2))/deltat ! add to output cme cmeout(i,k) = cmeout(i,k)+dum ! now add to tendencies, partition between liquid and ice based on temperature @@ -2506,8 +2371,8 @@ subroutine micro_mg_tend ( & dum1=(268.15_r8-ttmp)/30._r8 end if - dum = (qtmp-qsn)/(1._r8+(xxls*dum1+xxlv*(1._r8-dum1))**2 & - *qsn/(cpp*rv*ttmp**2))/deltat + dum = (qtmp-qvn)/(1._r8+(xxls*dum1+xxlv*(1._r8-dum1))**2 & + *qvn/(cpp*rv*ttmp**2))/deltat qctend(i,k)=qctend(i,k)+dum*(1._r8-dum1) ! for output qcrestot(i,k)=dum*(1._r8-dum1) @@ -2591,7 +2456,7 @@ subroutine micro_mg_tend ( & nctend(i,k)=(ncnst/rho(i,k)*lcldm(i,k)-nc(i,k))/deltat - end if + end if dum = dumnc(i,k) @@ -2639,6 +2504,7 @@ subroutine micro_mg_tend ( & !================================================================================= if (qc(i,k)+qctend(i,k)*deltat.lt.qsmall) nctend(i,k)=-nc(i,k)/deltat if (do_cldice .and. qi(i,k)+qitend(i,k)*deltat.lt.qsmall) nitend(i,k)=-ni(i,k)/deltat + end do end do sed_col_loop! i loop @@ -2667,10 +2533,10 @@ subroutine micro_mg_tend ( & nrout2 = nrout * cldmax ! The avg_diameter call does the actual calculation; other diameter ! outputs are just drout2 times constants. - drout2 = avg_diameter(qrout, nrout, rho, rhow) * cldmax + drout2 = avg_diameter(qrout, nrout, rho, rhow) freqr = cldmax - reff_rain=1.5_r8*drout2*1.e6_r8 + reff_rain=1.5_r8*drout2*1.e6_r8 elsewhere qrout2 = 0._r8 nrout2 = 0._r8 @@ -2690,8 +2556,6 @@ subroutine micro_mg_tend ( & dsout=3._r8*rhosn/917._r8*dsout2 - dsout2 = dsout2 * cldmax - reff_snow=1.5_r8*dsout2*1.e6_r8 elsewhere dsout = 0._r8 @@ -2718,7 +2582,7 @@ subroutine micro_mg_tend ( & end if if (qi(i,k).ge.qsmall) then dum1=(qi(i,k)*rho(i,k)/icldm(i,k)*1000._r8/0.1_r8)**(1._r8/0.63_r8)*icldm(i,k)/cldmax(i,k) - else + else dum1=0._r8 end if @@ -2751,16 +2615,16 @@ subroutine micro_mg_tend ( & !output reflectivity in Z. areflz(i,k)=refl(i,k) * cldmax(i,k) - ! convert back to DBz + ! convert back to DBz - if (refl(i,k).gt.minrefl) then + if (refl(i,k).gt.minrefl) then refl(i,k)=10._r8*log10(refl(i,k)) else refl(i,k)=-9999._r8 end if !set averaging flag - if (refl(i,k).gt.mindbz) then + if (refl(i,k).gt.mindbz) then arefl(i,k)=refl(i,k) * cldmax(i,k) frefl(i,k)=cldmax(i,k) else @@ -2774,7 +2638,7 @@ subroutine micro_mg_tend ( & csrfl(i,k)=min(csmax,refl(i,k)) !set averaging flag - if (csrfl(i,k).gt.csmin) then + if (csrfl(i,k).gt.csmin) then acsrfl(i,k)=refl(i,k) * cldmax(i,k) fcsrfl(i,k)=cldmax(i,k) else @@ -2794,111 +2658,9 @@ subroutine micro_mg_tend ( & nfice=0._r8 end where - ! Unpack all outputs - ! Avoid zero/near-zero division. qcsinksum_rate1ord = qcsinksum_rate1ord/max(qcsum_rate1ord,1.0e-30_r8) - call unpack_array(qcsinksum_rate1ord, mgcols, top_lev, 0._r8, rate1ord_cw2pr_st) - - call unpack_array(tlat, mgcols, top_lev, 0._r8, tlato) - call unpack_array(qvlat, mgcols, top_lev, 0._r8, qvlato) - - call unpack_array(qctend, mgcols, top_lev, 0._r8, qctendo) - call unpack_array(qitend, mgcols, top_lev, 0._r8, qitendo) - - ! Note that where there is no water, we set nctend and nitend to remove number - ! concentration as well. - call unpack_array(nctend, mgcols, top_lev, -ncn/deltat, nctendo) - if (do_cldice) then - call unpack_array(nitend, mgcols, top_lev, -nin/deltat, nitendo) - else - call unpack_array(nitend, mgcols, top_lev, 0._r8, nitendo) - end if - - call unpack_array(effc, mgcols, top_lev, 10._r8, effco) - call unpack_array(effc_fn, mgcols, top_lev, 10._r8, effco_fn) - call unpack_array(effi, mgcols, top_lev, 25._r8, effio) - - call unpack_array(prect, mgcols, 0._r8, precto) - call unpack_array(preci, mgcols, 0._r8, precio) - - call unpack_array(nevapr, mgcols, top_lev, 0._r8, nevapro) - call unpack_array(evapsnow, mgcols, top_lev, 0._r8, evapsnowo) - call unpack_array(prain, mgcols, top_lev, 0._r8, praino) - call unpack_array(prodsnow, mgcols, top_lev, 0._r8, prodsnowo) - call unpack_array(cmeout, mgcols, top_lev, 0._r8, cmeouto) - - call unpack_array(lamcrad, mgcols, top_lev, 0._r8, lamcrado) - call unpack_array(pgamrad, mgcols, top_lev, 0._r8, pgamrado) - call unpack_array(deffi, mgcols, top_lev, 0._r8, deffio) - - call unpack_array(qsout, mgcols, top_lev, 0._r8, qsouto) - call unpack_array(qsout2, mgcols, top_lev, 0._r8, qsouto2) - call unpack_array(nsout, mgcols, top_lev, 0._r8, nsouto) - call unpack_array(nsout2, mgcols, top_lev, 0._r8, nsouto2) - call unpack_array(dsout, mgcols, top_lev, 0._r8, dsouto) - call unpack_array(dsout2, mgcols, top_lev, 0._r8, dsouto2) - - call unpack_array(qrout, mgcols, top_lev, 0._r8, qrouto) - call unpack_array(qrout2, mgcols, top_lev, 0._r8, qrouto2) - call unpack_array(nrout, mgcols, top_lev, 0._r8, nrouto) - call unpack_array(nrout2, mgcols, top_lev, 0._r8, nrouto2) - call unpack_array(drout2, mgcols, top_lev, 0._r8, drouto2) - - call unpack_array(reff_rain, mgcols, top_lev, 0._r8, reff_raino) - call unpack_array(reff_snow, mgcols, top_lev, 0._r8, reff_snowo) - - call unpack_array(freqs, mgcols, top_lev, 0._r8, freqso) - call unpack_array(freqr, mgcols, top_lev, 0._r8, freqro) - - call unpack_array(rflx, mgcols, top_lev, 0._r8, rflxo) - call unpack_array(sflx, mgcols, top_lev, 0._r8, sflxo) - - call unpack_array(qcsevap, mgcols, top_lev, 0._r8, qcsevapo) - call unpack_array(qisevap, mgcols, top_lev, 0._r8, qisevapo) - call unpack_array(qvres, mgcols, top_lev, 0._r8, qvreso) - call unpack_array(cmeitot, mgcols, top_lev, 0._r8, cmeiout) - call unpack_array(vtrmc, mgcols, top_lev, 0._r8, vtrmco) - call unpack_array(vtrmi, mgcols, top_lev, 0._r8, vtrmio) - call unpack_array(qcsedten, mgcols, top_lev, 0._r8, qcsedteno) - call unpack_array(qisedten, mgcols, top_lev, 0._r8, qisedteno) - - call unpack_array(pratot, mgcols,top_lev, 0._r8, prao) - call unpack_array(prctot, mgcols,top_lev, 0._r8, prco) - call unpack_array(mnuccctot, mgcols,top_lev, 0._r8, mnuccco) - call unpack_array(mnuccttot, mgcols,top_lev, 0._r8, mnuccto) - call unpack_array(msacwitot, mgcols,top_lev, 0._r8, msacwio) - call unpack_array(psacwstot, mgcols,top_lev, 0._r8, psacwso) - call unpack_array(bergstot, mgcols,top_lev, 0._r8, bergso) - call unpack_array(bergtot, mgcols,top_lev, 0._r8, bergo) - call unpack_array(melttot, mgcols,top_lev, 0._r8, melto) - call unpack_array(homotot, mgcols,top_lev, 0._r8, homoo) - call unpack_array(qcrestot, mgcols,top_lev, 0._r8, qcreso) - call unpack_array(prcitot, mgcols,top_lev, 0._r8, prcio) - call unpack_array(praitot, mgcols,top_lev, 0._r8, praio) - call unpack_array(qirestot, mgcols,top_lev, 0._r8, qireso) - call unpack_array(mnuccrtot, mgcols,top_lev, 0._r8, mnuccro) - call unpack_array(pracstot, mgcols,top_lev, 0._r8, pracso) - call unpack_array(mnuccdtot, mgcols,top_lev, 0._r8, mnuccdo) - call unpack_array(meltsdttot, mgcols,top_lev, 0._r8, meltsdto) - call unpack_array(frzrdttot, mgcols,top_lev, 0._r8, frzrdto) - - call unpack_array(refl, mgcols, top_lev, -9999._r8, reflo) - call unpack_array(arefl, mgcols, top_lev, 0._r8, areflo) - call unpack_array(areflz, mgcols, top_lev, 0._r8, areflzo) - call unpack_array(frefl, mgcols, top_lev, 0._r8, freflo) - call unpack_array(csrfl, mgcols, top_lev, -9999._r8, csrflo) - call unpack_array(acsrfl, mgcols, top_lev, 0._r8, acsrflo) - call unpack_array(fcsrfl, mgcols, top_lev, 0._r8, fcsrflo) - - call unpack_array(rercld, mgcols, top_lev, 0._r8, rercldo) - - call unpack_array(nfice, mgcols, top_lev, 0._r8, nficeo) - - call unpack_array(ncai, mgcols, top_lev, 0._r8, ncaio) - call unpack_array(ncal, mgcols, top_lev, 0._r8, ncalo) - end subroutine micro_mg_tend !======================================================================== @@ -3009,7 +2771,6 @@ elemental subroutine size_dist_param_ice(qiic, niic, lami, n0i) ! local parameters real(r8), parameter :: lammaxi = 1._r8/10.e-6_r8 - real(r8) :: lammini lammini = 1._r8/(2._r8*dcs) @@ -3021,7 +2782,7 @@ elemental subroutine size_dist_param_ice(qiic, niic, lami, n0i) lami = (cons1*ci*niic/qiic)**(1._r8/dsph) n0i = niic * lami - + ! check for slope ! adjust vars if (lami < lammini) then @@ -3066,7 +2827,7 @@ elemental subroutine size_dist_param_rain(qric, nric, lamr, n0r) lamr = (cr*nric/qric)**(1._r8/3._r8) n0r = nric * lamr - + ! check for slope ! adjust vars @@ -3109,7 +2870,7 @@ elemental subroutine size_dist_param_snow(qsic, nsic, lams, n0s) lams = (cons1*cs*nsic/qsic)**(1._r8/dsph) n0s = nsic * lams - + ! check for slope ! adjust vars if (lams < lammins) then @@ -3121,7 +2882,7 @@ elemental subroutine size_dist_param_snow(qsic, nsic, lams, n0s) n0s = lams**(dsph+1._r8) * qsic/(cs*cons1) nsic = n0s/lams end if - + else lams = 0._r8 n0s = 0._r8 @@ -3132,8 +2893,9 @@ end subroutine size_dist_param_snow real(r8) elemental function avg_diameter(q, n, rho_air, rho_sub) ! Finds the average diameter of particles given their density, and ! mass/number concentrations in the air. + ! Assumes that diameter follows an exponential distribution. real(r8), intent(in) :: q ! mass mixing ratio - real(r8), intent(in) :: n ! number concentration + real(r8), intent(in) :: n ! number concentration (per volume) real(r8), intent(in) :: rho_air ! local density of the air real(r8), intent(in) :: rho_sub ! density of the particle substance @@ -3158,193 +2920,89 @@ end function var_coef !======================================================================== ! Initial ice deposition and sublimation loop. ! Run before the main loop +! This subroutine written by Peter Caldwell -elemental subroutine ice_deposition_sublimation_init(deltat, t, q, qc, qi, ni, & - lcldm, icldm, naai, rho, dv, & - esl, esi, qvl, qvi, relhum, & - berg, cmei) +elemental subroutine ice_deposition_sublimation(deltat, t, qv, qc, qi, ni, lcldm, & + icldm, naai, rho, dv,qvl, qvi, & + berg, vap_dep, ice_sublim) - ! Inputs + !INPUT VARS: + !=============================================== real(r8), intent(in) :: deltat - real(r8), intent(in) :: t - real(r8), intent(in) :: q - + real(r8), intent(in) :: qv real(r8), intent(in) :: qc real(r8), intent(in) :: qi real(r8), intent(in) :: ni - real(r8), intent(in) :: lcldm real(r8), intent(in) :: icldm - real(r8), intent(in) :: naai real(r8), intent(in) :: rho real(r8), intent(in) :: dv - - real(r8), intent(in) :: esl - real(r8), intent(in) :: esi real(r8), intent(in) :: qvl real(r8), intent(in) :: qvi - real(r8), intent(in) :: relhum - - ! Outputs - real(r8), intent(out) :: berg - real(r8), intent(out) :: cmei - - ! Internal variables + !OUTPUT VARS: + !=============================================== + real(r8), intent(out) :: vap_dep !ice deposition (cell-ave value) + real(r8), intent(out) :: ice_sublim !ice sublimation (cell-ave value) + real(r8), intent(out) :: berg !bergeron enhancement (cell-ave value) + !INTERNAL VARS: + !=============================================== + real(r8) :: ab + real(r8) :: epsi real(r8) :: qiic real(r8) :: niic - - real(r8) :: prd ! provisional deposition rate of cloud ice at water sat - real(r8) :: bergtsf ! bergeron timescale to remove all liquid - real(r8) :: rhin ! modified RH for vapor deposition - - real(r8) :: epsi ! 1/sat relaxation timescale for ice - - real(r8) :: ab + real(r8) :: dum real(r8) :: lami real(r8) :: n0i - real(r8) :: dum - - ! initialize bergeron process to zero - berg = 0._r8 - - ! Initialize CME components - cmei = 0._r8 - - if (t < icenuct) then - ! provisional nucleation rate - dum = max((naai - ni/icldm)/deltat*icldm,0._r8) - else - dum = 0._r8 - end if - ! get in-cloud qi and ni after nucleation - qiic = (qi + dum*deltat*mi0)/icldm - niic = (ni + dum*deltat)/icldm - - ! hm add 6/2/11 switch for specification of cloud ice number - if (nicons) niic = ninst/rho - !ICE DEPOSITION: - !============================================= - !if ice exists - if (t < tmelt .and. qi >= qsmall) then + if (qi>=qsmall) then - ab = calc_ab(t, qvi, xxls) + !GET IN-CLOUD qi, ni + !=============================================== + qiic = qi/icldm + niic = ni/icldm - ! get ice size distribution parameters + !Compute linearized condensational heating correction + ab=calc_ab(t, qvi, xxls) + !Get slope and intercept of gamma distn for ice. call size_dist_param_ice(qiic, niic, lami, n0i) - + !Get depletion timescale=1/eps epsi = 2._r8*pi*n0i*rho*Dv/(lami*lami) - - !if liquid exists - if (qc >= qsmall) then - - ! calculate Bergeron process - berg = epsi*(qvl-qvi)/ab - - ! multiply by cloud fraction - berg = berg*min(icldm,lcldm) - - ! Must be positive - if (berg <= 0._r8) then - berg = 0._r8 - else - !BERGERON LIMITING WHEN ALL LIQUID DEPLETED IN 1 TIMESTEP - !------------------------------------------------------------- - - bergtsf = (qc/berg) / deltat ! bergeron time scale (fraction of timestep) - - if (bergtsf < 1._r8) then - berg = qc/deltat - - rhin = (1.0_r8 + relhum) / 2._r8 - !assume RH for frac of step w/ no liq is 1/2 way btwn cldy & cell-ave RH. - - if ((rhin*esl/esi) > 1._r8) then !if ice saturated (but all liquid evap'd) - prd = epsi*(rhin*qvl-qvi)/ab - - ! multiply by cloud fraction assuming liquid/ice maximum overlap - prd = prd*min(icldm,lcldm) - - ! add to cmei - cmei = cmei + (prd * (1._r8- bergtsf)) - end if ! rhin - - end if - - end if - end if + !Compute deposition/sublimation + vap_dep = epsi/ab*(qv - qvi) + + !Make this a grid-averaged quantity + vap_dep=vap_dep*icldm - !Ice deposition in frac of cell with no liquid - !------------------------------------------------------------- - ! store liquid cloud fraction in 'dum' - if (qc >= qsmall) then - dum = lcldm + !Split into deposition or sublimation. + if (t<273.15_r8 .and. vap_dep>0._r8) then + ice_sublim=0._r8 else - ! for case of no liquid, need to set liquid cloud fraction to zero - dum = 0._r8 + !hm, make ice_sublim negative for consistency with other evap/sub processes + ice_sublim=min(vap_dep,0._r8) + vap_dep=0._r8 end if - if (icldm > dum) then - - ! set RH to grid-mean value for pure ice cloud - rhin = relhum - - if ((rhin*esl/esi) > 1._r8) then !if rh over ice>ice saturation. - - prd = epsi*(rhin*qvl-qvi)/ab - - ! multiply by relevant cloud fraction for pure ice cloud - ! assuming maximum overlap of liquid/ice - prd = prd*(icldm-dum) !apply to ice-only part of cld. - cmei = cmei + prd - - end if ! rhin - end if ! qc or icldm > lcldm - - !if grid-mean is ice saturated & qi formed in non-liq cld part, - !limit ice formation to avoid mean becoming undersaturated. - !------------------------------------------------------------- - if(cmei > 0.0_r8 .and. (relhum*esl/esi) > 1._r8 ) & - ! max berg is val which removes all ice supersaturation from vapor phase. - cmei=min(cmei,(q-qvl*esi/esl)/ab/deltat) - - end if ! end ice exists and t < tmelt - - !ICE SUBLIMATION: - !========================================= - !If ice-subsaturated and ice exists: - - if ((relhum*esl/esi) < 1._r8 .and. qiic >= qsmall ) then + !sublimation occurs @ any T. Not so for berg. + if (T<273.15_r8) then - ab = calc_ab(t, qvi, xxls) + !Compute bergeron rate assuming cloud for whole step. + berg = max(epsi/ab*(qvl - qvi), 0._r8) + else !T>frz + berg=0._r8 + end if !Tqsmall - epsi = 2._r8*pi*n0i*rho*Dv/(lami*lami) - - ! modify for ice fraction below - prd = epsi*(relhum*qvl-qvi)/ab * icldm - cmei=min(prd,0._r8) - - endif !subsaturated and ice exists - - ! sublimation should not exceed available ice - cmei = max(cmei, -qi/deltat) - - ! sublimation should not increase grid mean rhi above 1.0 - if(cmei < 0.0_r8 .and. (relhum*esl/esi) < 1._r8 ) & - cmei=min(0._r8,max(cmei,(q-qvl*esi/esl)/ab/deltat)) - - ! limit cmei due for roundoff error - cmei = cmei*omsm - -end subroutine ice_deposition_sublimation_init +end subroutine ice_deposition_sublimation !======================================================================== ! autoconversion of cloud liquid water to rain @@ -3353,7 +3011,7 @@ end subroutine ice_deposition_sublimation_init elemental subroutine kk2000_liq_autoconversion(qcic, ncic, rho, relvar, & prc, nprc, nprc1) - + real(r8), intent(in) :: qcic real(r8), intent(in) :: ncic real(r8), intent(in) :: rho @@ -3379,11 +3037,11 @@ elemental subroutine kk2000_liq_autoconversion(qcic, ncic, rho, relvar, & ! nprc is increase in rain number conc due to autoconversion ! nprc1 is decrease in cloud droplet conc due to autoconversion - + ! assume exponential sub-grid distribution of qc, resulting in additional ! factor related to qcvar below ! hm switch for sub-columns, don't include sub-grid qc - + prc = prc_coef * & 1350._r8 * qcic**2.47_r8 * (ncic/1.e6_r8*rho)**(-1.79_r8) nprc = prc/nprc_denom @@ -3407,7 +3065,7 @@ elemental subroutine ice_autoconversion(t, qiic, lami, n0i, prci, nprci) real(r8), intent(in) :: qiic real(r8), intent(in) :: lami real(r8), intent(in) :: n0i - + real(r8), intent(out) :: prci real(r8), intent(out) :: nprci @@ -3419,7 +3077,7 @@ elemental subroutine ice_autoconversion(t, qiic, lami, n0i, prci, nprci) prci = pi*rhoi*n0i/(6._r8*180._r8)* & (cons23/lami+3._r8*cons24/lami**2+ & - 6._r8*dcs/lami**3+6._r8/lami**4)*exp(-lami*dcs) + 6._r8*dcs/lami**3+6._r8/lami**4)*exp(-lami*dcs) else prci=0._r8 @@ -3444,14 +3102,14 @@ elemental subroutine immersion_freezing(t, pgam, lamc, cdist1, qcic, & ! MMR of in-cloud liquid water real(r8), intent(in) :: qcic - + ! Relative variance of cloud water real(r8), intent(in) :: relvar ! Output tendencies real(r8), intent(out) :: mnuccc ! MMR real(r8), intent(out) :: nnuccc ! Number - + ! Coefficients that will be omitted for sub-columns real(r8) :: dum, dum1 @@ -3488,7 +3146,7 @@ end subroutine immersion_freezing pure subroutine contact_freezing (t, p, rndst, nacon, pgam, lamc, cdist1, qcic, & relvar, mnucct, nnucct) - + real(r8), intent(in) :: t(:) ! Temperature real(r8), intent(in) :: p(:) ! Pressure real(r8), intent(in) :: rndst(:,:) ! Radius (for multiple dust bins) @@ -3501,7 +3159,7 @@ pure subroutine contact_freezing (t, p, rndst, nacon, pgam, lamc, cdist1, qcic, ! MMR of in-cloud liquid water real(r8), intent(in) :: qcic(:) - + ! Relative cloud water variance real(r8), intent(in) :: relvar(:) @@ -3659,7 +3317,7 @@ elemental subroutine accrete_cloud_water_snow(t, rho, asn, uns, mu, qcic, ncic, end subroutine accrete_cloud_water_snow -! add secondary ice production due to accretion of droplets by snow +! add secondary ice production due to accretion of droplets by snow !=================================================================== ! (Hallet-Mossop process) (from Cotton et al., 1986) @@ -3795,7 +3453,7 @@ elemental subroutine accrete_cloud_water_rain(qric, qcic, ncic, & ! Cloud droplets real(r8), intent(in) :: qcic ! MMR real(r8), intent(in) :: ncic ! Number - + ! SGS variability real(r8), intent(in) :: relvar real(r8), intent(in) :: accre_enhan @@ -3870,7 +3528,7 @@ elemental subroutine accrete_cloud_ice_snow(t, rho, asn, qiic, niic, qsic, & ! Snow size parameters real(r8), intent(in) :: lams - real(r8), intent(in) :: n0s + real(r8), intent(in) :: n0s ! Output tendencies real(r8), intent(out) :: prai ! MMR @@ -3897,7 +3555,8 @@ end subroutine accrete_cloud_ice_snow ! except for transfer of cloud water to snow through bergeron process elemental subroutine evaporate_sublimate_precip(deltat, t, p, rho, dv, mu, sc, q, qvl, qvi, & - lcldm, cldmax, arn, asn, qcic, qiic, qric, qsic, lamr, n0r, lams, n0s, cmei, pre, prds) + lcldm, cldmax, arn, asn, qcic, qiic, qric, qsic, lamr, n0r, lams, n0s, & + pre, prds) real(r8), intent(in) :: deltat ! timestep @@ -3931,16 +3590,13 @@ elemental subroutine evaporate_sublimate_precip(deltat, t, p, rho, dv, mu, sc, q real(r8), intent(in) :: lams real(r8), intent(in) :: n0s - ! cloud ice sublimation/deposition tendency - real(r8), intent(in) :: cmei - ! Output tendencies real(r8), intent(out) :: pre real(r8), intent(out) :: prds ! checking for RH after rain evap real(r8) :: esn ! saturation pressure - real(r8) :: qsn ! saturation humidity + real(r8) :: qvn ! saturation humidity real(r8) :: qclr ! water vapor mixing ratio in clear air real(r8) :: ab ! correction to account for latent heat @@ -3966,8 +3622,8 @@ elemental subroutine evaporate_sublimate_precip(deltat, t, p, rho, dv, mu, sc, q if (cldmax > dum) then ! calculate q for out-of-cloud region - qsn = min(qvl,1._r8) - qclr=(q-dum*qsn)/(1._r8-dum) + qvn = min(qvl,1._r8) + qclr=(q-dum*qvn)/(1._r8-dum) ! evaporation of rain if (qric.ge.qsmall) then @@ -4006,50 +3662,6 @@ elemental subroutine evaporate_sublimate_precip(deltat, t, p, rho, dv, mu, sc, q prds = 0._r8 end if - ! make sure RH not pushed above 100% due to rain evaporation/snow sublimation - ! get updated RH at end of time step based on cloud water/ice condensation/evap - - qtmp=q-(cmei+(pre+prds)*cldmax)*deltat - ttmp=t+((pre*cldmax)*xxlv+ & - (cmei+prds*cldmax)*xxls)*deltat/cpp - - !limit range of temperatures! - ttmp=max(180._r8,min(ttmp,323._r8)) - - ! use rhw to allow ice supersaturation - call qsat_water(ttmp, p, esn, qsn) - qsn=min(qsn,1._r8) - - ! modify precip evaporation rate if q > qsat - if (qtmp.gt.qsn) then - if (pre+prds.lt.-1.e-20_r8) then - dum1=pre/(pre+prds) - ! recalculate q and t after cloud water cond but without precip evap - qtmp=q-(cmei)*deltat - ttmp=t+(cmei*xxls)*deltat/cpp - ! use rhw to allow ice supersaturation - call qsat_water(ttmp, p, esn, qsn) - qsn=min(qsn,1._r8) - - dum=(qtmp-qsn)/(1._r8 + cons27*qsn/(cpp*rv*ttmp**2)) - dum=min(dum,0._r8) - - ! modify rates if needed, divide by cldmax to get local (in-precip) value - pre=dum*dum1/deltat/cldmax - - ! do separately using RHI for prds.... - ! use rhi to allow ice supersaturation - call qsat_ice(ttmp, p, esn, qsn) - qsn=min(qsn,1._r8) - - dum=(qtmp-qsn)/(1._r8 + cons28*qsn/(cpp*rv*ttmp**2)) - dum=min(dum,0._r8) - - ! modify rates if needed, divide by cldmax to get local (in-precip) value - prds=dum*(1._r8-dum1)/deltat/cldmax - end if - end if - else prds = 0._r8 pre = 0._r8 @@ -4060,7 +3672,7 @@ end subroutine evaporate_sublimate_precip ! bergeron process - evaporation of droplets and deposition onto snow !=================================================================== -elemental subroutine bergeron_process(t, rho, dv, mu, sc, qvl, qvi, asn, & +elemental subroutine bergeron_process_snow(t, rho, dv, mu, sc, qvl, qvi, asn, & qcic, qsic, lams, n0s, bergs) real(r8), intent(in) :: t ! temperature @@ -4100,14 +3712,14 @@ elemental subroutine bergeron_process(t, rho, dv, mu, sc, qvl, qvi, asn, & bergs = 0._r8 end if -end subroutine bergeron_process +end subroutine bergeron_process_snow !======================================================================== !OUTPUT CALCULATIONS !======================================================================== elemental subroutine calc_rercld(lamr, n0r, lamc, cdist1, pgam, dumr, qcic, & - arcld, rercld) + rercld) real(r8), intent(in) :: lamr ! rain size parameter (slope) real(r8), intent(in) :: n0r ! rain size parameter (intercept) real(r8), intent(in) :: lamc ! size distribution parameter (slope) @@ -4116,7 +3728,6 @@ elemental subroutine calc_rercld(lamr, n0r, lamc, cdist1, pgam, dumr, qcic, & real(r8), intent(in) :: dumr ! in-cloud rain mass mixing ratio real(r8), intent(in) :: qcic ! in-cloud cloud liquid - integer, intent(inout) :: arcld ! number of substeps rercld has been through real(r8), intent(inout) :: rercld ! effective radius calculation for rain + cloud ! combined size of precip & cloud drops @@ -4136,7 +3747,6 @@ elemental subroutine calc_rercld(lamr, n0r, lamc, cdist1, pgam, dumr, qcic, & if (Atmp > 0._r8) then rercld = rercld + 3._r8 *(dumr + qcic) / (4._r8 * rhow * Atmp) - arcld = arcld+1 end if end subroutine calc_rercld @@ -4178,7 +3788,7 @@ pure subroutine micro_mg_get_cols(ncol, nlev, top_lev, qcn, qin, & ltrue = ltrue .or. any(qin(:ncol,top_lev:(nlev+lev_offset)) >= qsmall, 2) ! Scan for true values to get a usable list of indices. - + mgncol = count(ltrue) allocate(mgcols(mgncol)) i = 0 @@ -4204,154 +3814,4 @@ pure function interp_to_mid(orig_val, weights) result(new_val) end function interp_to_mid -! Subroutines to pack arrays into smaller, contiguous pieces -!======================================================================== -! Rank 1 array of reals, columns only -pure subroutine pack_array_1Dr8(old_array, cols, new_array) - ! Inputs - real(r8), intent(in) :: old_array(:) ! Array to be packed - integer, intent(in) :: cols(:) ! List of columns to include - - ! Output - real(r8), intent(out) :: new_array(:) - - ! Attempt to speed up packing if it is unnecessary. - if (size(new_array) == size(old_array)) then - new_array = old_array - else - new_array = old_array(cols) - end if - -end subroutine pack_array_1Dr8 - -! Rank 2 array of reals, columns and levels -pure subroutine pack_array_2Dr8(old_array, cols, top_lev, new_array) - ! Inputs - real(r8), intent(in) :: old_array(:,:) ! Array to be packed - integer, intent(in) :: cols(:) ! List of columns to include - integer, intent(in) :: top_lev ! First level to use - - ! Output - real(r8), intent(out) :: new_array(:,:) - - ! Attempt to speed up packing if it is unnecessary. - if (size(new_array) == size(old_array)) then - new_array = old_array - else - new_array = old_array(cols, top_lev:) - end if - -end subroutine pack_array_2Dr8 - -! Rank 3 array of reals, assume last index is extra -pure subroutine pack_array_3Dr8(old_array, cols, top_lev, new_array) - ! Inputs - real(r8), intent(in) :: old_array(:,:,:) ! Array to be packed - integer, intent(in) :: cols(:) ! List of columns to include - integer, intent(in) :: top_lev ! First level to use - - ! Output - real(r8), intent(out) :: new_array(:,:,:) - - ! Attempt to speed up packing if it is unnecessary. - if (size(new_array) == size(old_array)) then - new_array = old_array - else - new_array = old_array(cols, top_lev:,:) - end if - -end subroutine pack_array_3Dr8 - -! Subroutines to unpack arrays for output -!======================================================================== -! Rank 1 array of reals, columns only -pure subroutine unpack_array_1Dr8(old_array, cols, fill, new_array) - ! Inputs - real(r8), intent(in) :: old_array(:) ! Array to be packed - integer, intent(in) :: cols(:) ! List of columns to include - real(r8), intent(in) :: fill ! Value with which to fill unused - ! sections of new_array. - - ! Output - real(r8), intent(out) :: new_array(:) - - ! Attempt to speed up packing if it is unnecessary. - if (size(new_array) == size(old_array)) then - new_array = old_array - else - new_array = fill - - new_array(cols) = old_array - end if - -end subroutine unpack_array_1Dr8 - -! Rank 1 array of reals, columns only, "fill" value is an array -pure subroutine unpack_array_1Dr8_arrayfill(old_array, cols, fill, new_array) - ! Inputs - real(r8), intent(in) :: old_array(:) ! Array to be packed - integer, intent(in) :: cols(:) ! List of columns to include - real(r8), intent(in) :: fill(:) ! Value with which to fill unused - ! sections of new_array. - - ! Output - real(r8), intent(out) :: new_array(:) - - ! Attempt to speed up packing if it is unnecessary. - if (size(new_array) == size(old_array)) then - new_array = old_array - else - new_array = fill - - new_array(cols) = old_array - end if - -end subroutine unpack_array_1Dr8_arrayfill - -! Rank 2 array of reals, columns and levels -pure subroutine unpack_array_2Dr8(old_array, cols, top_lev, fill, new_array) - ! Inputs - real(r8), intent(in) :: old_array(:,:) ! Array to be packed - integer, intent(in) :: cols(:) ! List of columns to include - integer, intent(in) :: top_lev ! First level to use - real(r8), intent(in) :: fill ! Value with which to fill unused - ! sections of new_array. - - ! Output - real(r8), intent(out) :: new_array(:,:) - - ! Attempt to speed up packing if it is unnecessary. - if (size(new_array) == size(old_array)) then - new_array = old_array - else - new_array = fill - - new_array(cols, top_lev:) = old_array - end if - -end subroutine unpack_array_2Dr8 - -! Rank 2 array of reals, columns and levels, "fill" value is an array -pure subroutine unpack_array_2Dr8_arrayfill(old_array, cols, top_lev, fill, new_array) - ! Inputs - real(r8), intent(in) :: old_array(:,:) ! Array to be packed - integer, intent(in) :: cols(:) ! List of columns to include - integer, intent(in) :: top_lev ! First level to use - real(r8), intent(in) :: fill(:,:) ! Value with which to fill unused - ! sections of new_array. - - ! Output - real(r8), intent(out) :: new_array(:,:) - - ! Attempt to speed up packing if it is unnecessary. - if (size(new_array) == size(old_array)) then - new_array = old_array - else - new_array = fill - - new_array(cols, top_lev:) = old_array - end if - -end subroutine unpack_array_2Dr8_arrayfill - end module micro_mg1_5 diff --git a/models/atm/cam/src/physics/cam/micro_mg2_0.F90 b/models/atm/cam/src/physics/cam/micro_mg2_0.F90 new file mode 100644 index 000000000000..3c458c767cb8 --- /dev/null +++ b/models/atm/cam/src/physics/cam/micro_mg2_0.F90 @@ -0,0 +1,2962 @@ +module micro_mg2_0 + +!--------------------------------------------------------------------------------- +! Purpose: +! MG microphysics version 2.0 - Update of MG microphysics with +! prognostic precipitation. +! +! Author: Andrew Gettelman, Hugh Morrison. +! Contributions from: Peter Caldwell, Xiaohong Liu and Steve Ghan +! Version 2 history: Sep 2011: Development begun. +! Feb 2013: Added of prognostic precipitation. +! invoked in CAM by specifying -microphys=mg2.0 +! +! for questions contact Hugh Morrison, Andrew Gettelman +! e-mail: morrison@ucar.edu, andrew@ucar.edu +!--------------------------------------------------------------------------------- +! +! NOTE: Modified to allow other microphysics packages (e.g. CARMA) to do ice +! microphysics in cooperation with the MG liquid microphysics. This is +! controlled by the do_cldice variable. +! +! If do_cldice is false, then MG microphysics should not update CLDICE or +! NUMICE; it is assumed that the other microphysics scheme will have updated +! CLDICE and NUMICE. The other microphysics should handle the following +! processes that would have been done by MG: +! - Detrainment (liquid and ice) +! - Homogeneous ice nucleation +! - Heterogeneous ice nucleation +! - Bergeron process +! - Melting of ice +! - Freezing of cloud drops +! - Autoconversion (ice -> snow) +! - Growth/Sublimation of ice +! - Sedimentation of ice +! +! This option has not been updated since the introduction of prognostic +! precipitation, and probably should be adjusted to cover snow as well. +! +!--------------------------------------------------------------------------------- +! Based on micro_mg (restructuring of former cldwat2m_micro) +! Author: Andrew Gettelman, Hugh Morrison. +! Contributions from: Xiaohong Liu and Steve Ghan +! December 2005-May 2010 +! Description in: Morrison and Gettelman, 2008. J. Climate (MG2008) +! Gettelman et al., 2010 J. Geophys. Res. - Atmospheres (G2010) +! for questions contact Hugh Morrison, Andrew Gettelman +! e-mail: morrison@ucar.edu, andrew@ucar.edu +!--------------------------------------------------------------------------------- +! Code comments added by HM, 093011 +! General code structure: +! +! Code is divided into two main subroutines: +! subroutine micro_mg_init --> initializes microphysics routine, should be called +! once at start of simulation +! subroutine micro_mg_tend --> main microphysics routine to be called each time step +! this also calls several smaller subroutines to calculate +! microphysical processes and other utilities +! +! List of external functions: +! qsat_water --> for calculating saturation vapor pressure with respect to liquid water +! qsat_ice --> for calculating saturation vapor pressure with respect to ice +! gamma --> standard mathematical gamma function +! ......................................................................... +! List of inputs through use statement in fortran90: +! Variable Name Description Units +! ......................................................................... +! gravit acceleration due to gravity m s-2 +! rair dry air gas constant for air J kg-1 K-1 +! tmelt temperature of melting point for water K +! cpair specific heat at constant pressure for dry air J kg-1 K-1 +! rh2o gas constant for water vapor J kg-1 K-1 +! latvap latent heat of vaporization J kg-1 +! latice latent heat of fusion J kg-1 +! qsat_water external function for calculating liquid water +! saturation vapor pressure/humidity - +! qsat_ice external function for calculating ice +! saturation vapor pressure/humidity pa +! rhmini relative humidity threshold parameter for +! nucleating ice - +! ......................................................................... +! NOTE: List of all inputs/outputs passed through the call/subroutine statement +! for micro_mg_tend is given below at the start of subroutine micro_mg_tend. +!--------------------------------------------------------------------------------- + +! Procedures required: +! 1) An implementation of the gamma function (if not intrinsic). +! 2) saturation vapor pressure and specific humidity over water +! 3) svp over ice + +#ifndef HAVE_GAMMA_INTRINSICS +use shr_spfn_mod, only: gamma => shr_spfn_gamma +#endif + +use wv_sat_methods, only: & + qsat_water => wv_sat_qsat_water, & + qsat_ice => wv_sat_qsat_ice + +! Parameters from the utilities module. +use micro_mg_utils, only: & + r8, & + pi, & + omsm, & + qsmall, & + mincld, & + rhosn, & + rhoi, & + rhow, & + rhows, & + ac, bc, & + ai, bi, & + ar, br, & + as, bs, & + mi0, & + rising_factorial + +implicit none +private +save + +public :: & + micro_mg_init, & + micro_mg_get_cols, & + micro_mg_tend + +! switch for specification rather than prediction of droplet and crystal number +! note: number will be adjusted as needed to keep mean size within bounds, +! even when specified droplet or ice number is used + +! If constant cloud ice number is set (nicons = .true.), +! then all microphysical processes except mass transfer due to ice nucleation +! (mnuccd) are based on the fixed cloud ice number. Calculation of +! mnuccd follows from the prognosed ice crystal number ni. + +! nccons = .true. to specify constant cloud droplet number +! nicons = .true. to specify constant cloud ice number + +logical, parameter, public :: nccons = .false. +logical, parameter, public :: nicons = .false. + +!========================================================= +! Private module parameters +!========================================================= + +! parameters for specified ice and droplet number concentration +! note: these are local in-cloud values, not grid-mean +real(r8), parameter :: ncnst = 100.e6_r8 ! droplet num concentration when nccons=.true. (m-3) +real(r8), parameter :: ninst = 0.1e6_r8 ! ice num concentration when nicons=.true. (m-3) + +!Range of cloudsat reflectivities (dBz) for analytic simulator +real(r8), parameter :: csmin = -30._r8 +real(r8), parameter :: csmax = 26._r8 +real(r8), parameter :: mindbz = -99._r8 +real(r8), parameter :: minrefl = 1.26e-10_r8 ! minrefl = 10._r8**(mindbz/10._r8) + +! autoconversion size threshold for cloud ice to snow (m) +real(r8) :: dcs + +! minimum mass of new crystal due to freezing of cloud droplets done +! externally (kg) +real(r8), parameter :: mi0l_min = 4._r8/3._r8*pi*rhow*(4.e-6_r8)**3 + +!========================================================= +! Constants set in initialization +!========================================================= + +! Set using arguments to micro_mg_init +real(r8) :: g ! gravity +real(r8) :: r ! dry air gas constant +real(r8) :: rv ! water vapor gas constant +real(r8) :: cpp ! specific heat of dry air +real(r8) :: tmelt ! freezing point of water (K) + +! latent heats of: +real(r8) :: xxlv ! vaporization +real(r8) :: xlf ! freezing +real(r8) :: xxls ! sublimation + +real(r8) :: rhmini ! Minimum rh for ice cloud fraction > 0. + +! flags +logical :: microp_uniform +logical :: do_cldice +logical :: use_hetfrz_classnuc + +real(r8) :: rhosu ! typical 850mn air density + +real(r8) :: icenuct ! ice nucleation temperature: currently -5 degrees C + +real(r8) :: snowmelt ! what temp to melt all snow: currently 2 degrees C +real(r8) :: rainfrze ! what temp to freeze all rain: currently -5 degrees C + +! additional constants to help speed up code +real(r8) :: gamma_br_plus1 +real(r8) :: gamma_br_plus4 +real(r8) :: gamma_bs_plus1 +real(r8) :: gamma_bs_plus4 +real(r8) :: gamma_bi_plus1 +real(r8) :: gamma_bi_plus4 +real(r8) :: xxlv_squared +real(r8) :: xxls_squared + +character(len=16) :: micro_mg_precip_frac_method ! type of precipitation fraction method +real(r8) :: micro_mg_berg_eff_factor ! berg efficiency factor + +logical :: allow_sed_supersat ! Allow supersaturated conditions after sedimentation loop + +!=============================================================================== +contains +!=============================================================================== + +subroutine micro_mg_init( & + kind, gravit, rair, rh2o, cpair, & + tmelt_in, latvap, latice, & + rhmini_in, micro_mg_dcs, & + microp_uniform_in, do_cldice_in, use_hetfrz_classnuc_in, & + micro_mg_precip_frac_method_in, micro_mg_berg_eff_factor_in, & + allow_sed_supersat_in, errstring) + + use micro_mg_utils, only: micro_mg_utils_init + + !----------------------------------------------------------------------- + ! + ! Purpose: + ! initialize constants for MG microphysics + ! + ! Author: Andrew Gettelman Dec 2005 + ! + !----------------------------------------------------------------------- + + integer, intent(in) :: kind ! Kind used for reals + real(r8), intent(in) :: gravit + real(r8), intent(in) :: rair + real(r8), intent(in) :: rh2o + real(r8), intent(in) :: cpair + real(r8), intent(in) :: tmelt_in ! Freezing point of water (K) + real(r8), intent(in) :: latvap + real(r8), intent(in) :: latice + real(r8), intent(in) :: rhmini_in ! Minimum rh for ice cloud fraction > 0. + real(r8), intent(in) :: micro_mg_dcs + + logical, intent(in) :: microp_uniform_in ! .true. = configure uniform for sub-columns + ! .false. = use w/o sub-columns (standard) + logical, intent(in) :: do_cldice_in ! .true. = do all processes (standard) + ! .false. = skip all processes affecting + ! cloud ice + logical, intent(in) :: use_hetfrz_classnuc_in ! use heterogeneous freezing + + character(len=16),intent(in) :: micro_mg_precip_frac_method_in ! type of precipitation fraction method + real(r8), intent(in) :: micro_mg_berg_eff_factor_in ! berg efficiency factor + logical, intent(in) :: allow_sed_supersat_in ! allow supersaturated conditions after sedimentation loop + + + character(128), intent(out) :: errstring ! Output status (non-blank for error return) + + !----------------------------------------------------------------------- + + dcs = micro_mg_dcs + + ! Initialize subordinate utilities module. + call micro_mg_utils_init(kind, rh2o, cpair, tmelt_in, latvap, latice, & + dcs, errstring) + + if (trim(errstring) /= "") return + + ! declarations for MG code (transforms variable names) + + g= gravit ! gravity + r= rair ! dry air gas constant: note units(phys_constants are in J/K/kmol) + rv= rh2o ! water vapor gas constant + cpp = cpair ! specific heat of dry air + tmelt = tmelt_in + rhmini = rhmini_in + micro_mg_precip_frac_method = micro_mg_precip_frac_method_in + micro_mg_berg_eff_factor = micro_mg_berg_eff_factor_in + allow_sed_supersat = allow_sed_supersat_in + + ! latent heats + + xxlv = latvap ! latent heat vaporization + xlf = latice ! latent heat freezing + xxls = xxlv + xlf ! latent heat of sublimation + + ! flags + microp_uniform = microp_uniform_in + do_cldice = do_cldice_in + use_hetfrz_classnuc = use_hetfrz_classnuc_in + + ! typical air density at 850 mb + + rhosu = 85000._r8/(rair * tmelt) + + ! Maximum temperature at which snow is allowed to exist + snowmelt = tmelt + 2._r8 + ! Minimum temperature at which rain is allowed to exist + rainfrze = tmelt - 40._r8 + + ! Ice nucleation temperature + icenuct = tmelt - 5._r8 + + ! Define constants to help speed up code (this limits calls to gamma function) + gamma_br_plus1=gamma(1._r8+br) + gamma_br_plus4=gamma(4._r8+br) + gamma_bs_plus1=gamma(1._r8+bs) + gamma_bs_plus4=gamma(4._r8+bs) + gamma_bi_plus1=gamma(1._r8+bi) + gamma_bi_plus4=gamma(4._r8+bi) + xxlv_squared=xxlv**2 + xxls_squared=xxls**2 + +end subroutine micro_mg_init + +!=============================================================================== +!microphysics routine for each timestep goes here... + +subroutine micro_mg_tend ( & + mgncol, nlev, deltatin, & + t, q, & + qcn, qin, & + ncn, nin, & + qrn, qsn, & + nrn, nsn, & + relvar, accre_enhan, & + p, pdel, & + cldn, liqcldf, icecldf, & + qcsinksum_rate1ord, & + naai, npccn, & + rndst, nacon, & + tlat, qvlat, & + qctend, qitend, & + nctend, nitend, & + qrtend, qstend, & + nrtend, nstend, & + effc, effc_fn, effi, & + prect, preci, & + nevapr, evapsnow, & + prain, prodsnow, & + cmeout, deffi, & + pgamrad, lamcrad, & + qsout, dsout, & + rflx, sflx, qrout, & + reff_rain, reff_snow, & + qcsevap, qisevap, qvres, & + cmeitot, vtrmc, vtrmi, & + umr, ums, & + qcsedten, qisedten, & + qrsedten, qssedten, & + pratot, prctot, & + mnuccctot, mnuccttot, msacwitot, & + psacwstot, bergstot, bergtot, & + melttot, homotot, & + qcrestot, prcitot, praitot, & + qirestot, mnuccrtot, pracstot, & + meltsdttot, frzrdttot, mnuccdtot, & + nrout, nsout, & + refl, arefl, areflz, & + frefl, csrfl, acsrfl, & + fcsrfl, rercld, & + ncai, ncal, & + qrout2, qsout2, & + nrout2, nsout2, & + drout2, dsout2, & + freqs, freqr, & + nfice, qcrat, & + errstring, & ! Below arguments are "optional" (pass null pointers to omit). + tnd_qsnow, tnd_nsnow, re_ice, & + prer_evap, & + frzimm, frzcnt, frzdep) + + ! Constituent properties. + use micro_mg_utils, only: & + mg_liq_props, & + mg_ice_props, & + mg_rain_props, & + mg_snow_props + + ! Size calculation functions. + use micro_mg_utils, only: & + size_dist_param_liq, & + size_dist_param_basic, & + avg_diameter + + ! Microphysical processes. + use micro_mg_utils, only: & + ice_deposition_sublimation, & + kk2000_liq_autoconversion, & + ice_autoconversion, & + immersion_freezing, & + contact_freezing, & + snow_self_aggregation, & + accrete_cloud_water_snow, & + secondary_ice_production, & + accrete_rain_snow, & + heterogeneous_rain_freezing, & + accrete_cloud_water_rain, & + self_collection_rain, & + accrete_cloud_ice_snow, & + evaporate_sublimate_precip, & + bergeron_process_snow + + !Authors: Hugh Morrison, Andrew Gettelman, NCAR, Peter Caldwell, LLNL + ! e-mail: morrison@ucar.edu, andrew@ucar.edu + + ! input arguments + integer, intent(in) :: mgncol ! number of microphysics columns + integer, intent(in) :: nlev ! number of layers + real(r8), intent(in) :: deltatin ! time step (s) + real(r8), intent(in) :: t(:,:) ! input temperature (K) + real(r8), intent(in) :: q(:,:) ! input h20 vapor mixing ratio (kg/kg) + + ! note: all input cloud variables are grid-averaged + real(r8), intent(in) :: qcn(:,:) ! cloud water mixing ratio (kg/kg) + real(r8), intent(in) :: qin(:,:) ! cloud ice mixing ratio (kg/kg) + real(r8), intent(in) :: ncn(:,:) ! cloud water number conc (1/kg) + real(r8), intent(in) :: nin(:,:) ! cloud ice number conc (1/kg) + + real(r8), intent(in) :: qrn(:,:) ! rain mixing ratio (kg/kg) + real(r8), intent(in) :: qsn(:,:) ! snow mixing ratio (kg/kg) + real(r8), intent(in) :: nrn(:,:) ! rain number conc (1/kg) + real(r8), intent(in) :: nsn(:,:) ! snow number conc (1/kg) + + real(r8), intent(in) :: relvar(:,:) ! cloud water relative variance (-) + real(r8), intent(in) :: accre_enhan(:,:) ! optional accretion + ! enhancement factor (-) + + real(r8), intent(in) :: p(:,:) ! air pressure (pa) + real(r8), intent(in) :: pdel(:,:) ! pressure difference across level (pa) + + real(r8), intent(in) :: cldn(:,:) ! cloud fraction (no units) + real(r8), intent(in) :: liqcldf(:,:) ! liquid cloud fraction (no units) + real(r8), intent(in) :: icecldf(:,:) ! ice cloud fraction (no units) + ! used for scavenging + ! Inputs for aerosol activation + real(r8), intent(in) :: naai(:,:) ! ice nucleation number (from microp_aero_ts) (1/kg) + real(r8), intent(in) :: npccn(:,:) ! ccn activated number tendency (from microp_aero_ts) (1/kg*s) + + ! Note that for these variables, the dust bin is assumed to be the last index. + ! (For example, in CAM, the last dimension is always size 4.) + real(r8), intent(in) :: rndst(:,:,:) ! radius of each dust bin, for contact freezing (from microp_aero_ts) (m) + real(r8), intent(in) :: nacon(:,:,:) ! number in each dust bin, for contact freezing (from microp_aero_ts) (1/m^3) + + ! output arguments + + real(r8), intent(out) :: qcsinksum_rate1ord(:,:) ! 1st order rate for + ! direct cw to precip conversion + real(r8), intent(out) :: tlat(:,:) ! latent heating rate (W/kg) + real(r8), intent(out) :: qvlat(:,:) ! microphysical tendency qv (1/s) + real(r8), intent(out) :: qctend(:,:) ! microphysical tendency qc (1/s) + real(r8), intent(out) :: qitend(:,:) ! microphysical tendency qi (1/s) + real(r8), intent(out) :: nctend(:,:) ! microphysical tendency nc (1/(kg*s)) + real(r8), intent(out) :: nitend(:,:) ! microphysical tendency ni (1/(kg*s)) + + real(r8), intent(out) :: qrtend(:,:) ! microphysical tendency qr (1/s) + real(r8), intent(out) :: qstend(:,:) ! microphysical tendency qs (1/s) + real(r8), intent(out) :: nrtend(:,:) ! microphysical tendency nr (1/(kg*s)) + real(r8), intent(out) :: nstend(:,:) ! microphysical tendency ns (1/(kg*s)) + + real(r8), intent(out) :: effc(:,:) ! droplet effective radius (micron) + real(r8), intent(out) :: effc_fn(:,:) ! droplet effective radius, assuming nc = 1.e8 kg-1 + real(r8), intent(out) :: effi(:,:) ! cloud ice effective radius (micron) + real(r8), intent(out) :: prect(:) ! surface precip rate (m/s) + real(r8), intent(out) :: preci(:) ! cloud ice/snow precip rate (m/s) + real(r8), intent(out) :: nevapr(:,:) ! evaporation rate of rain + snow (1/s) + real(r8), intent(out) :: evapsnow(:,:) ! sublimation rate of snow (1/s) + real(r8), intent(out) :: prain(:,:) ! production of rain + snow (1/s) + real(r8), intent(out) :: prodsnow(:,:) ! production of snow (1/s) + real(r8), intent(out) :: cmeout(:,:) ! evap/sub of cloud (1/s) + real(r8), intent(out) :: deffi(:,:) ! ice effective diameter for optics (radiation) (micron) + real(r8), intent(out) :: pgamrad(:,:) ! ice gamma parameter for optics (radiation) (no units) + real(r8), intent(out) :: lamcrad(:,:) ! slope of droplet distribution for optics (radiation) (1/m) + real(r8), intent(out) :: qsout(:,:) ! snow mixing ratio (kg/kg) + real(r8), intent(out) :: dsout(:,:) ! snow diameter (m) + real(r8), intent(out) :: rflx(:,:) ! grid-box average rain flux (kg m^-2 s^-1) + real(r8), intent(out) :: sflx(:,:) ! grid-box average snow flux (kg m^-2 s^-1) + real(r8), intent(out) :: qrout(:,:) ! grid-box average rain mixing ratio (kg/kg) + real(r8), intent(out) :: reff_rain(:,:) ! rain effective radius (micron) + real(r8), intent(out) :: reff_snow(:,:) ! snow effective radius (micron) + real(r8), intent(out) :: qcsevap(:,:) ! cloud water evaporation due to sedimentation (1/s) + real(r8), intent(out) :: qisevap(:,:) ! cloud ice sublimation due to sublimation (1/s) + real(r8), intent(out) :: qvres(:,:) ! residual condensation term to ensure RH < 100% (1/s) + real(r8), intent(out) :: cmeitot(:,:) ! grid-mean cloud ice sub/dep (1/s) + real(r8), intent(out) :: vtrmc(:,:) ! mass-weighted cloud water fallspeed (m/s) + real(r8), intent(out) :: vtrmi(:,:) ! mass-weighted cloud ice fallspeed (m/s) + real(r8), intent(out) :: umr(:,:) ! mass weighted rain fallspeed (m/s) + real(r8), intent(out) :: ums(:,:) ! mass weighted snow fallspeed (m/s) + real(r8), intent(out) :: qcsedten(:,:) ! qc sedimentation tendency (1/s) + real(r8), intent(out) :: qisedten(:,:) ! qi sedimentation tendency (1/s) + real(r8), intent(out) :: qrsedten(:,:) ! qr sedimentation tendency (1/s) + real(r8), intent(out) :: qssedten(:,:) ! qs sedimentation tendency (1/s) + + ! microphysical process rates for output (mixing ratio tendencies) (all have units of 1/s) + real(r8), intent(out) :: pratot(:,:) ! accretion of cloud by rain + real(r8), intent(out) :: prctot(:,:) ! autoconversion of cloud to rain + real(r8), intent(out) :: mnuccctot(:,:) ! mixing ratio tend due to immersion freezing + real(r8), intent(out) :: mnuccttot(:,:) ! mixing ratio tend due to contact freezing + real(r8), intent(out) :: msacwitot(:,:) ! mixing ratio tend due to H-M splintering + real(r8), intent(out) :: psacwstot(:,:) ! collection of cloud water by snow + real(r8), intent(out) :: bergstot(:,:) ! bergeron process on snow + real(r8), intent(out) :: bergtot(:,:) ! bergeron process on cloud ice + real(r8), intent(out) :: melttot(:,:) ! melting of cloud ice + real(r8), intent(out) :: homotot(:,:) ! homogeneous freezing cloud water + real(r8), intent(out) :: qcrestot(:,:) ! residual cloud condensation due to removal of excess supersat + real(r8), intent(out) :: prcitot(:,:) ! autoconversion of cloud ice to snow + real(r8), intent(out) :: praitot(:,:) ! accretion of cloud ice by snow + real(r8), intent(out) :: qirestot(:,:) ! residual ice deposition due to removal of excess supersat + real(r8), intent(out) :: mnuccrtot(:,:) ! mixing ratio tendency due to heterogeneous freezing of rain to snow (1/s) + real(r8), intent(out) :: pracstot(:,:) ! mixing ratio tendency due to accretion of rain by snow (1/s) + real(r8), intent(out) :: meltsdttot(:,:) ! latent heating rate due to melting of snow (W/kg) + real(r8), intent(out) :: frzrdttot(:,:) ! latent heating rate due to homogeneous freezing of rain (W/kg) + real(r8), intent(out) :: mnuccdtot(:,:) ! mass tendency from ice nucleation + real(r8), intent(out) :: nrout(:,:) ! rain number concentration (1/m3) + real(r8), intent(out) :: nsout(:,:) ! snow number concentration (1/m3) + real(r8), intent(out) :: refl(:,:) ! analytic radar reflectivity + real(r8), intent(out) :: arefl(:,:) ! average reflectivity will zero points outside valid range + real(r8), intent(out) :: areflz(:,:) ! average reflectivity in z. + real(r8), intent(out) :: frefl(:,:) ! fractional occurrence of radar reflectivity + real(r8), intent(out) :: csrfl(:,:) ! cloudsat reflectivity + real(r8), intent(out) :: acsrfl(:,:) ! cloudsat average + real(r8), intent(out) :: fcsrfl(:,:) ! cloudsat fractional occurrence of radar reflectivity + real(r8), intent(out) :: rercld(:,:) ! effective radius calculation for rain + cloud + real(r8), intent(out) :: ncai(:,:) ! output number conc of ice nuclei available (1/m3) + real(r8), intent(out) :: ncal(:,:) ! output number conc of CCN (1/m3) + real(r8), intent(out) :: qrout2(:,:) ! copy of qrout as used to compute drout2 + real(r8), intent(out) :: qsout2(:,:) ! copy of qsout as used to compute dsout2 + real(r8), intent(out) :: nrout2(:,:) ! copy of nrout as used to compute drout2 + real(r8), intent(out) :: nsout2(:,:) ! copy of nsout as used to compute dsout2 + real(r8), intent(out) :: drout2(:,:) ! mean rain particle diameter (m) + real(r8), intent(out) :: dsout2(:,:) ! mean snow particle diameter (m) + real(r8), intent(out) :: freqs(:,:) ! fractional occurrence of snow + real(r8), intent(out) :: freqr(:,:) ! fractional occurrence of rain + real(r8), intent(out) :: nfice(:,:) ! fractional occurrence of ice + real(r8), intent(out) :: qcrat(:,:) ! limiter for qc process rates (1=no limit --> 0. no qc) + + real(r8), intent(out) :: prer_evap(:,:) + + character(128), intent(out) :: errstring ! output status (non-blank for error return) + + ! Tendencies calculated by external schemes that can replace MG's native + ! process tendencies. + + ! Used with CARMA cirrus microphysics + ! (or similar external microphysics model) + real(r8), intent(in), pointer :: tnd_qsnow(:,:) ! snow mass tendency (kg/kg/s) + real(r8), intent(in), pointer :: tnd_nsnow(:,:) ! snow number tendency (#/kg/s) + real(r8), intent(in), pointer :: re_ice(:,:) ! ice effective radius (m) + + ! From external ice nucleation. + real(r8), intent(in), pointer :: frzimm(:,:) ! Number tendency due to immersion freezing (1/cm3) + real(r8), intent(in), pointer :: frzcnt(:,:) ! Number tendency due to contact freezing (1/cm3) + real(r8), intent(in), pointer :: frzdep(:,:) ! Number tendency due to deposition nucleation (1/cm3) + + ! local workspace + ! all units mks unless otherwise stated + + ! local copies of input variables + real(r8) :: qc(mgncol,nlev) ! cloud liquid mixing ratio (kg/kg) + real(r8) :: qi(mgncol,nlev) ! cloud ice mixing ratio (kg/kg) + real(r8) :: nc(mgncol,nlev) ! cloud liquid number concentration (1/kg) + real(r8) :: ni(mgncol,nlev) ! cloud liquid number concentration (1/kg) + real(r8) :: qr(mgncol,nlev) ! rain mixing ratio (kg/kg) + real(r8) :: qs(mgncol,nlev) ! snow mixing ratio (kg/kg) + real(r8) :: nr(mgncol,nlev) ! rain number concentration (1/kg) + real(r8) :: ns(mgncol,nlev) ! snow number concentration (1/kg) + + ! general purpose variables + real(r8) :: deltat ! sub-time step (s) + real(r8) :: mtime ! the assumed ice nucleation timescale + + ! physical properties of the air at a given point + real(r8) :: rho(mgncol,nlev) ! density (kg m-3) + real(r8) :: dv(mgncol,nlev) ! diffusivity of water vapor + real(r8) :: mu(mgncol,nlev) ! viscosity + real(r8) :: sc(mgncol,nlev) ! schmidt number + real(r8) :: rhof(mgncol,nlev) ! density correction factor for fallspeed + + ! cloud fractions + real(r8) :: precip_frac(mgncol,nlev) ! precip fraction assuming maximum overlap + real(r8) :: cldm(mgncol,nlev) ! cloud fraction + real(r8) :: icldm(mgncol,nlev) ! ice cloud fraction + real(r8) :: lcldm(mgncol,nlev) ! liq cloud fraction + + ! mass mixing ratios + real(r8) :: qcic(mgncol,nlev) ! in-cloud cloud liquid + real(r8) :: qiic(mgncol,nlev) ! in-cloud cloud ice + real(r8) :: qsic(mgncol,nlev) ! in-precip snow + real(r8) :: qric(mgncol,nlev) ! in-precip rain + + ! number concentrations + real(r8) :: ncic(mgncol,nlev) ! in-cloud droplet + real(r8) :: niic(mgncol,nlev) ! in-cloud cloud ice + real(r8) :: nsic(mgncol,nlev) ! in-precip snow + real(r8) :: nric(mgncol,nlev) ! in-precip rain + ! maximum allowed ni value + real(r8) :: nimax(mgncol,nlev) + + ! Size distribution parameters for: + ! cloud ice + real(r8) :: lami(mgncol,nlev) ! slope + real(r8) :: n0i(mgncol,nlev) ! intercept + ! cloud liquid + real(r8) :: lamc(mgncol,nlev) ! slope + real(r8) :: pgam(mgncol,nlev) ! spectral width parameter + ! snow + real(r8) :: lams(mgncol,nlev) ! slope + real(r8) :: n0s(mgncol,nlev) ! intercept + ! rain + real(r8) :: lamr(mgncol,nlev) ! slope + real(r8) :: n0r(mgncol,nlev) ! intercept + + ! Rates/tendencies due to: + + ! Instantaneous snow melting + real(r8) :: minstsm(mgncol,nlev) ! mass mixing ratio + real(r8) :: ninstsm(mgncol,nlev) ! number concentration + ! Instantaneous rain freezing + real(r8) :: minstrf(mgncol,nlev) ! mass mixing ratio + real(r8) :: ninstrf(mgncol,nlev) ! number concentration + + ! deposition of cloud ice + real(r8) :: vap_dep(mgncol,nlev) ! deposition from vapor to ice PMC 12/3/12 + ! sublimation of cloud ice + real(r8) :: ice_sublim(mgncol,nlev) ! sublimation from ice to vapor PMC 12/3/12 + ! ice nucleation + real(r8) :: nnuccd(mgncol,nlev) ! number rate from deposition/cond.-freezing + real(r8) :: mnuccd(mgncol,nlev) ! mass mixing ratio + ! freezing of cloud water + real(r8) :: mnuccc(mgncol,nlev) ! mass mixing ratio + real(r8) :: nnuccc(mgncol,nlev) ! number concentration + ! contact freezing of cloud water + real(r8) :: mnucct(mgncol,nlev) ! mass mixing ratio + real(r8) :: nnucct(mgncol,nlev) ! number concentration + ! deposition nucleation in mixed-phase clouds (from external scheme) + real(r8) :: mnudep(mgncol,nlev) ! mass mixing ratio + real(r8) :: nnudep(mgncol,nlev) ! number concentration + ! ice multiplication + real(r8) :: msacwi(mgncol,nlev) ! mass mixing ratio + real(r8) :: nsacwi(mgncol,nlev) ! number concentration + ! autoconversion of cloud droplets + real(r8) :: prc(mgncol,nlev) ! mass mixing ratio + real(r8) :: nprc(mgncol,nlev) ! number concentration (rain) + real(r8) :: nprc1(mgncol,nlev) ! number concentration (cloud droplets) + ! self-aggregation of snow + real(r8) :: nsagg(mgncol,nlev) ! number concentration + ! self-collection of rain + real(r8) :: nragg(mgncol,nlev) ! number concentration + ! collection of droplets by snow + real(r8) :: psacws(mgncol,nlev) ! mass mixing ratio + real(r8) :: npsacws(mgncol,nlev) ! number concentration + ! collection of rain by snow + real(r8) :: pracs(mgncol,nlev) ! mass mixing ratio + real(r8) :: npracs(mgncol,nlev) ! number concentration + ! freezing of rain + real(r8) :: mnuccr(mgncol,nlev) ! mass mixing ratio + real(r8) :: nnuccr(mgncol,nlev) ! number concentration + ! freezing of rain to form ice (mg add 4/26/13) + real(r8) :: mnuccri(mgncol,nlev) ! mass mixing ratio + real(r8) :: nnuccri(mgncol,nlev) ! number concentration + ! accretion of droplets by rain + real(r8) :: pra(mgncol,nlev) ! mass mixing ratio + real(r8) :: npra(mgncol,nlev) ! number concentration + ! autoconversion of cloud ice to snow + real(r8) :: prci(mgncol,nlev) ! mass mixing ratio + real(r8) :: nprci(mgncol,nlev) ! number concentration + ! accretion of cloud ice by snow + real(r8) :: prai(mgncol,nlev) ! mass mixing ratio + real(r8) :: nprai(mgncol,nlev) ! number concentration + ! evaporation of rain + real(r8) :: pre(mgncol,nlev) ! mass mixing ratio + ! sublimation of snow + real(r8) :: prds(mgncol,nlev) ! mass mixing ratio + ! number evaporation + real(r8) :: nsubi(mgncol,nlev) ! cloud ice + real(r8) :: nsubc(mgncol,nlev) ! droplet + real(r8) :: nsubs(mgncol,nlev) ! snow + real(r8) :: nsubr(mgncol,nlev) ! rain + ! bergeron process + real(r8) :: berg(mgncol,nlev) ! mass mixing ratio (cloud ice) + real(r8) :: bergs(mgncol,nlev) ! mass mixing ratio (snow) + + + ! fallspeeds + ! number-weighted + real(r8) :: uns(mgncol,nlev) ! snow + real(r8) :: unr(mgncol,nlev) ! rain + ! air density corrected fallspeed parameters + real(r8) :: arn(mgncol,nlev) ! rain + real(r8) :: asn(mgncol,nlev) ! snow + real(r8) :: acn(mgncol,nlev) ! cloud droplet + real(r8) :: ain(mgncol,nlev) ! cloud ice + + ! Mass of liquid droplets used with external heterogeneous freezing. + real(r8) :: mi0l(mgncol) + + ! saturation vapor pressures + real(r8) :: esl(mgncol,nlev) ! liquid + real(r8) :: esi(mgncol,nlev) ! ice + real(r8) :: esn ! checking for RH after rain evap + + ! saturation vapor mixing ratios + real(r8) :: qvl(mgncol,nlev) ! liquid + real(r8) :: qvi(mgncol,nlev) ! ice + real(r8) :: qvn ! checking for RH after rain evap + + ! relative humidity + real(r8) :: relhum(mgncol,nlev) + + ! parameters for cloud water and cloud ice sedimentation calculations + real(r8) :: fc(nlev) + real(r8) :: fnc(nlev) + real(r8) :: fi(nlev) + real(r8) :: fni(nlev) + + real(r8) :: fr(nlev) + real(r8) :: fnr(nlev) + real(r8) :: fs(nlev) + real(r8) :: fns(nlev) + + real(r8) :: faloutc(nlev) + real(r8) :: faloutnc(nlev) + real(r8) :: falouti(nlev) + real(r8) :: faloutni(nlev) + + real(r8) :: faloutr(nlev) + real(r8) :: faloutnr(nlev) + real(r8) :: falouts(nlev) + real(r8) :: faloutns(nlev) + + real(r8) :: faltndc + real(r8) :: faltndnc + real(r8) :: faltndi + real(r8) :: faltndni + real(r8) :: faltndqie + real(r8) :: faltndqce + + real(r8) :: faltndr + real(r8) :: faltndnr + real(r8) :: faltnds + real(r8) :: faltndns + + real(r8) :: rainrt(mgncol,nlev) ! rain rate for reflectivity calculation + + ! dummy variables + real(r8) :: dum + real(r8) :: dum1 + real(r8) :: dum2 + ! dummies for checking RH + real(r8) :: qtmp + real(r8) :: ttmp + ! dummies for conservation check + real(r8) :: ratio + real(r8) :: tmpfrz + ! dummies for in-cloud variables + real(r8) :: dumc(mgncol,nlev) ! qc + real(r8) :: dumnc(mgncol,nlev) ! nc + real(r8) :: dumi(mgncol,nlev) ! qi + real(r8) :: dumni(mgncol,nlev) ! ni + real(r8) :: dumr(mgncol,nlev) ! rain mixing ratio + real(r8) :: dumnr(mgncol,nlev) ! rain number concentration + real(r8) :: dums(mgncol,nlev) ! snow mixing ratio + real(r8) :: dumns(mgncol,nlev) ! snow number concentration + ! Array dummy variable + real(r8) :: dum_2D(mgncol,nlev) + + ! loop array variables + ! "i" and "k" are column/level iterators for internal (MG) variables + ! "n" is used for other looping (currently just sedimentation) + integer i, k, n + + ! number of sub-steps for loops over "n" (for sedimentation) + integer nstep + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + ! default return error message + errstring = ' ' + + if (.not. (do_cldice .or. & + (associated(tnd_qsnow) .and. associated(tnd_nsnow) .and. associated(re_ice)))) then + errstring = "MG's native cloud ice processes are disabled, but & + &no replacement values were passed in." + end if + + if (use_hetfrz_classnuc .and. (.not. & + (associated(frzimm) .and. associated(frzcnt) .and. associated(frzdep)))) then + errstring = "External heterogeneous freezing is enabled, but the & + &required tendencies were not all passed in." + end if + + ! Process inputs + + ! assign variable deltat to deltatin + deltat = deltatin + + ! Copies of input concentrations that may be changed internally. + qc = qcn + nc = ncn + qi = qin + ni = nin + qr = qrn + nr = nrn + qs = qsn + ns = nsn + + ! cldn: used to set cldm, unused for subcolumns + ! liqcldf: used to set lcldm, unused for subcolumns + ! icecldf: used to set icldm, unused for subcolumns + + if (microp_uniform) then + ! subcolumns, set cloud fraction variables to one + ! if cloud water or ice is present, if not present + ! set to mincld (mincld used instead of zero, to prevent + ! possible division by zero errors). + + where (qc >= qsmall) + lcldm = 1._r8 + elsewhere + lcldm = mincld + end where + + where (qi >= qsmall) + icldm = 1._r8 + elsewhere + icldm = mincld + end where + + cldm = max(icldm, lcldm) + + else + ! get cloud fraction, check for minimum + cldm = max(cldn,mincld) + lcldm = max(liqcldf,mincld) + icldm = max(icecldf,mincld) + end if + + ! Initialize local variables + + ! local physical properties + rho = p/(r*t) + dv = 8.794E-5_r8 * t**1.81_r8 / p + mu = 1.496E-6_r8 * t**1.5_r8 / (t + 120._r8) + sc = mu/(rho*dv) + + ! air density adjustment for fallspeed parameters + ! includes air density correction factor to the + ! power of 0.54 following Heymsfield and Bansemer 2007 + + rhof=(rhosu/rho)**0.54_r8 + + arn=ar*rhof + asn=as*rhof + acn=g*rhow/(18._r8*mu) + ain=ai*(rhosu/rho)**0.35_r8 + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! Get humidity and saturation vapor pressures + + do k=1,nlev + do i=1,mgncol + + call qsat_water(t(i,k), p(i,k), esl(i,k), qvl(i,k)) + + ! make sure when above freezing that esi=esl, not active yet + if (t(i,k) >= tmelt) then + esi(i,k)=esl(i,k) + qvi(i,k)=qvl(i,k) + else + call qsat_ice(t(i,k), p(i,k), esi(i,k), qvi(i,k)) + end if + + end do + end do + + relhum = q / max(qvl, qsmall) + + !=============================================== + + ! set mtime here to avoid answer-changing + mtime=deltat + + ! initialize microphysics output + qcsevap=0._r8 + qisevap=0._r8 + qvres =0._r8 + cmeitot =0._r8 + vtrmc =0._r8 + vtrmi =0._r8 + qcsedten =0._r8 + qisedten =0._r8 + qrsedten =0._r8 + qssedten =0._r8 + + pratot=0._r8 + prctot=0._r8 + mnuccctot=0._r8 + mnuccttot=0._r8 + msacwitot=0._r8 + psacwstot=0._r8 + bergstot=0._r8 + bergtot=0._r8 + melttot=0._r8 + homotot=0._r8 + qcrestot=0._r8 + prcitot=0._r8 + praitot=0._r8 + qirestot=0._r8 + mnuccrtot=0._r8 + pracstot=0._r8 + meltsdttot=0._r8 + frzrdttot=0._r8 + mnuccdtot=0._r8 + + rflx=0._r8 + sflx=0._r8 + + ! initialize precip output + + qrout=0._r8 + qsout=0._r8 + nrout=0._r8 + nsout=0._r8 + + ! for refl calc + rainrt = 0._r8 + + ! initialize rain size + rercld=0._r8 + + qcsinksum_rate1ord = 0._r8 + + ! initialize variables for trop_mozart + nevapr = 0._r8 + prer_evap = 0._r8 + evapsnow = 0._r8 + prain = 0._r8 + prodsnow = 0._r8 + cmeout = 0._r8 + + precip_frac = mincld + + lamc=0._r8 + + ! initialize microphysical tendencies + + tlat=0._r8 + qvlat=0._r8 + qctend=0._r8 + qitend=0._r8 + qstend = 0._r8 + qrtend = 0._r8 + nctend=0._r8 + nitend=0._r8 + nrtend = 0._r8 + nstend = 0._r8 + + ! initialize in-cloud and in-precip quantities to zero + qcic = 0._r8 + qiic = 0._r8 + qsic = 0._r8 + qric = 0._r8 + + ncic = 0._r8 + niic = 0._r8 + nsic = 0._r8 + nric = 0._r8 + + ! initialize precip at surface + + prect = 0._r8 + preci = 0._r8 + + ! initialize precip fallspeeds to zero + ums = 0._r8 + uns = 0._r8 + umr = 0._r8 + unr = 0._r8 + + ! initialize limiter for output + qcrat = 1._r8 + + ! Many outputs have to be initialized here at the top to work around + ! ifort problems, even if they are always overwritten later. + effc = 10._r8 + lamcrad = 0._r8 + pgamrad = 0._r8 + effc_fn = 10._r8 + effi = 25._r8 + deffi = 50._r8 + + qrout2 = 0._r8 + nrout2 = 0._r8 + drout2 = 0._r8 + qsout2 = 0._r8 + nsout2 = 0._r8 + dsout = 0._r8 + dsout2 = 0._r8 + + freqr = 0._r8 + freqs = 0._r8 + + reff_rain = 0._r8 + reff_snow = 0._r8 + + refl = -9999._r8 + arefl = 0._r8 + areflz = 0._r8 + frefl = 0._r8 + csrfl = 0._r8 + acsrfl = 0._r8 + fcsrfl = 0._r8 + + ncal = 0._r8 + ncai = 0._r8 + + nfice = 0._r8 + + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! droplet activation + ! get provisional droplet number after activation. This is used for + ! all microphysical process calculations, for consistency with update of + ! droplet mass before microphysics + + ! calculate potential for droplet activation if cloud water is present + ! tendency from activation (npccn) is read in from companion routine + + ! output activated liquid and ice (convert from #/kg -> #/m3) + !-------------------------------------------------- + where (qc >= qsmall) + nc = max(nc + npccn*deltat, 0._r8) + ncal = nc*rho/lcldm ! sghan minimum in #/cm3 + elsewhere + ncal = 0._r8 + end where + + where (t < icenuct) + ncai = naai*rho + elsewhere + ncai = 0._r8 + end where + + !=============================================== + + ! ice nucleation if activated nuclei exist at t<-5C AND rhmini + 5% + !------------------------------------------------------- + + if (do_cldice) then + where (naai > 0._r8 .and. t < icenuct .and. & + relhum*esl/esi > rhmini+0.05_r8) + + !if NAAI > 0. then set numice = naai (as before) + !note: this is gridbox averaged + nnuccd = (naai-ni/icldm)/mtime*icldm + nnuccd = max(nnuccd,0._r8) + nimax = naai*icldm + + !Calc mass of new particles using new crystal mass... + !also this will be multiplied by mtime as nnuccd is... + + mnuccd = nnuccd * mi0 + + elsewhere + nnuccd = 0._r8 + nimax = 0._r8 + mnuccd = 0._r8 + end where + + end if + + + !============================================================================= + pre_vert_loop: do k=1,nlev + + pre_col_loop: do i=1,mgncol + + ! calculate instantaneous precip processes (melting and homogeneous freezing) + + ! melting of snow at +2 C + + if (t(i,k) > snowmelt) then + if (qs(i,k) > 0._r8) then + + ! make sure melting snow doesn't reduce temperature below threshold + dum = -xlf/cpp*qs(i,k) + if (t(i,k)+dum < snowmelt) then + dum = (t(i,k)-snowmelt)*cpp/xlf + dum = dum/qs(i,k) + dum = max(0._r8,dum) + dum = min(1._r8,dum) + else + dum = 1._r8 + end if + + minstsm(i,k) = dum*qs(i,k) + ninstsm(i,k) = dum*ns(i,k) + + dum1=-xlf*minstsm(i,k)/deltat + tlat(i,k)=tlat(i,k)+dum1 + meltsdttot(i,k)=meltsdttot(i,k) + dum1 + + qs(i,k) = max(qs(i,k) - minstsm(i,k), 0._r8) + ns(i,k) = max(ns(i,k) - ninstsm(i,k), 0._r8) + qr(i,k) = max(qr(i,k) + minstsm(i,k), 0._r8) + nr(i,k) = max(nr(i,k) + ninstsm(i,k), 0._r8) + end if + end if + + ! freezing of rain at -5 C + + if (t(i,k) < rainfrze) then + + if (qr(i,k) > 0._r8) then + + ! make sure freezing rain doesn't increase temperature above threshold + dum = xlf/cpp*qr(i,k) + if (t(i,k)+dum > rainfrze) then + dum = -(t(i,k)-rainfrze)*cpp/xlf + dum = dum/qr(i,k) + dum = max(0._r8,dum) + dum = min(1._r8,dum) + else + dum = 1._r8 + end if + + minstrf(i,k) = dum*qr(i,k) + ninstrf(i,k) = dum*nr(i,k) + + ! heating tendency + dum1 = xlf*minstrf(i,k)/deltat + tlat(i,k)=tlat(i,k)+dum1 + frzrdttot(i,k)=frzrdttot(i,k) + dum1 + + qr(i,k) = max(qr(i,k) - minstrf(i,k), 0._r8) + nr(i,k) = max(nr(i,k) - ninstrf(i,k), 0._r8) + qs(i,k) = max(qs(i,k) + minstrf(i,k), 0._r8) + ns(i,k) = max(ns(i,k) + ninstrf(i,k), 0._r8) + + end if + end if + + ! obtain in-cloud values of cloud water/ice mixing ratios and number concentrations + !------------------------------------------------------- + ! for microphysical process calculations + ! units are kg/kg for mixing ratio, 1/kg for number conc + + if (qc(i,k).ge.qsmall) then + ! limit in-cloud values to 0.005 kg/kg + qcic(i,k)=min(qc(i,k)/lcldm(i,k),5.e-3_r8) + ncic(i,k)=max(nc(i,k)/lcldm(i,k),0._r8) + + ! specify droplet concentration + if (nccons) then + ncic(i,k)=ncnst/rho(i,k) + end if + else + qcic(i,k)=0._r8 + ncic(i,k)=0._r8 + end if + + if (qi(i,k).ge.qsmall) then + ! limit in-cloud values to 0.005 kg/kg + qiic(i,k)=min(qi(i,k)/icldm(i,k),5.e-3_r8) + niic(i,k)=max(ni(i,k)/icldm(i,k),0._r8) + + ! switch for specification of cloud ice number + if (nicons) then + niic(i,k)=ninst/rho(i,k) + end if + else + qiic(i,k)=0._r8 + niic(i,k)=0._r8 + end if + + end do pre_col_loop + end do pre_vert_loop + + !======================================================================== + + ! for sub-columns cldm has already been set to 1 if cloud + ! water or ice is present, so precip_frac will be correctly set below + ! and nothing extra needs to be done here + + precip_frac = cldm + + micro_vert_loop: do k=1,nlev + + if (trim(micro_mg_precip_frac_method) == 'in_cloud') then + + if (k /= 1) then + where (qc(:,k) < qsmall .and. qi(:,k) < qsmall) + precip_frac(:,k) = precip_frac(:,k-1) + end where + endif + + else if (trim(micro_mg_precip_frac_method) == 'max_overlap') then + + ! calculate precip fraction based on maximum overlap assumption + + ! if rain or snow mix ratios are smaller than threshold, + ! then leave precip_frac as cloud fraction at current level + if (k /= 1) then + where (qr(:,k-1) >= qsmall .or. qs(:,k-1) >= qsmall) + precip_frac(:,k)=max(precip_frac(:,k-1),precip_frac(:,k)) + end where + end if + + endif + + do i = 1, mgncol + + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! get size distribution parameters based on in-cloud cloud water + ! these calculations also ensure consistency between number and mixing ratio + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + ! cloud liquid + !------------------------------------------- + + call size_dist_param_liq(mg_liq_props, qcic(i,k), ncic(i,k), rho(i,k), & + pgam(i,k), lamc(i,k)) + + end do + + !======================================================================== + ! autoconversion of cloud liquid water to rain + ! formula from Khrouditnov and Kogan (2000), modified for sub-grid distribution of qc + ! minimum qc of 1 x 10^-8 prevents floating point error + + call kk2000_liq_autoconversion(microp_uniform, qcic(:,k), & + ncic(:,k), rho(:,k), relvar(:,k), prc(:,k), nprc(:,k), nprc1(:,k)) + + ! assign qric based on prognostic qr, using assumed precip fraction + ! note: this could be moved above for consistency with qcic and qiic calculations + qric(:,k) = qr(:,k)/precip_frac(:,k) + nric(:,k) = nr(:,k)/precip_frac(:,k) + + ! limit in-precip mixing ratios to 10 g/kg + qric(:,k)=min(qric(:,k),0.01_r8) + + ! add autoconversion to precip from above to get provisional rain mixing ratio + ! and number concentration (qric and nric) + + where (qric(:,k).lt.qsmall) + qric(:,k)=0._r8 + nric(:,k)=0._r8 + end where + + ! make sure number concentration is a positive number to avoid + ! taking root of negative later + + nric(:,k)=max(nric(:,k),0._r8) + + ! Get size distribution parameters for cloud ice + + call size_dist_param_basic(mg_ice_props, qiic(:,k), niic(:,k), & + lami(:,k), n0i(:,k)) + + !....................................................................... + ! Autoconversion of cloud ice to snow + ! similar to Ferrier (1994) + + if (do_cldice) then + call ice_autoconversion(t(:,k), qiic(:,k), lami(:,k), n0i(:,k), & + dcs, prci(:,k), nprci(:,k)) + else + ! Add in the particles that we have already converted to snow, and + ! don't do any further autoconversion of ice. + prci(:,k) = tnd_qsnow(:,k) / cldm(:,k) + nprci(:,k) = tnd_nsnow(:,k) / cldm(:,k) + end if + + ! note, currently we don't have this + ! inside the do_cldice block, should be changed later + ! assign qsic based on prognostic qs, using assumed precip fraction + qsic(:,k) = qs(:,k)/precip_frac(:,k) + nsic(:,k) = ns(:,k)/precip_frac(:,k) + + ! limit in-precip mixing ratios to 10 g/kg + qsic(:,k)=min(qsic(:,k),0.01_r8) + + ! if precip mix ratio is zero so should number concentration + + where (qsic(:,k) < qsmall) + qsic(:,k)=0._r8 + nsic(:,k)=0._r8 + end where + + ! make sure number concentration is a positive number to avoid + ! taking root of negative later + + nsic(:,k)=max(nsic(:,k),0._r8) + + !....................................................................... + ! get size distribution parameters for precip + !...................................................................... + ! rain + + call size_dist_param_basic(mg_rain_props, qric(:,k), nric(:,k), & + lamr(:,k), n0r(:,k)) + + where (lamr(:,k) >= qsmall) + + ! provisional rain number and mass weighted mean fallspeed (m/s) + + unr(:,k) = min(arn(:,k)*gamma_br_plus1/lamr(:,k)**br,9.1_r8*rhof(:,k)) + umr(:,k) = min(arn(:,k)*gamma_br_plus4/(6._r8*lamr(:,k)**br),9.1_r8*rhof(:,k)) + + elsewhere + umr(:,k) = 0._r8 + unr(:,k) = 0._r8 + end where + + !...................................................................... + ! snow + + call size_dist_param_basic(mg_snow_props, qsic(:,k), nsic(:,k), & + lams(:,k), n0s(:,k)) + + where (lams(:,k) > 0._r8) + + ! provisional snow number and mass weighted mean fallspeed (m/s) + + ums(:,k) = min(asn(:,k)*gamma_bs_plus4/(6._r8*lams(:,k)**bs),1.2_r8*rhof(:,k)) + uns(:,k) = min(asn(:,k)*gamma_bs_plus1/lams(:,k)**bs,1.2_r8*rhof(:,k)) + + elsewhere + ums(:,k) = 0._r8 + uns(:,k) = 0._r8 + end where + + if (do_cldice) then + if (.not. use_hetfrz_classnuc) then + + ! heterogeneous freezing of cloud water + !---------------------------------------------- + + call immersion_freezing(microp_uniform, t(:,k), pgam(:,k), lamc(:,k), & + qcic(:,k), ncic(:,k), relvar(:,k), mnuccc(:,k), nnuccc(:,k)) + + ! make sure number of droplets frozen does not exceed available ice nuclei concentration + ! this prevents 'runaway' droplet freezing + + where (qcic(:,k).ge.qsmall .and. t(:,k).lt.269.15_r8) + where (nnuccc(:,k)*lcldm(:,k).gt.nnuccd(:,k)) + ! scale mixing ratio of droplet freezing with limit + mnuccc(:,k)=mnuccc(:,k)*(nnuccd(:,k)/(nnuccc(:,k)*lcldm(:,k))) + nnuccc(:,k)=nnuccd(:,k)/lcldm(:,k) + end where + end where + + call contact_freezing(microp_uniform, t(:,k), p(:,k), rndst(:,k,:), & + nacon(:,k,:), pgam(:,k), lamc(:,k), qcic(:,k), ncic(:,k), & + relvar(:,k), mnucct(:,k), nnucct(:,k)) + + mnudep(:,k)=0._r8 + nnudep(:,k)=0._r8 + + else + + ! Mass of droplets frozen is the average droplet mass, except + ! with two limiters: concentration must be at least 1/cm^3, and + ! mass must be at least the minimum defined above. + mi0l = qcic(:,k)/max(ncic(:,k), 1.0e6_r8/rho(:,k)) + mi0l = max(mi0l_min, mi0l) + + where (qcic(:,k) >= qsmall) + nnuccc(:,k) = frzimm(:,k)*1.0e6_r8/rho(:,k) + mnuccc(:,k) = nnuccc(:,k)*mi0l + + nnucct(:,k) = frzcnt(:,k)*1.0e6_r8/rho(:,k) + mnucct(:,k) = nnucct(:,k)*mi0l + + nnudep(:,k) = frzdep(:,k)*1.0e6_r8/rho(:,k) + mnudep(:,k) = nnudep(:,k)*mi0 + elsewhere + nnuccc(:,k) = 0._r8 + mnuccc(:,k) = 0._r8 + + nnucct(:,k) = 0._r8 + mnucct(:,k) = 0._r8 + + nnudep(:,k) = 0._r8 + mnudep(:,k) = 0._r8 + end where + + end if + + else + mnuccc(:,k)=0._r8 + nnuccc(:,k)=0._r8 + mnucct(:,k)=0._r8 + nnucct(:,k)=0._r8 + mnudep(:,k)=0._r8 + nnudep(:,k)=0._r8 + end if + + call snow_self_aggregation(t(:,k), rho(:,k), asn(:,k), rhosn, qsic(:,k), nsic(:,k), & + nsagg(:,k)) + + call accrete_cloud_water_snow(t(:,k), rho(:,k), asn(:,k), uns(:,k), mu(:,k), & + qcic(:,k), ncic(:,k), qsic(:,k), pgam(:,k), lamc(:,k), lams(:,k), n0s(:,k), & + psacws(:,k), npsacws(:,k)) + + if (do_cldice) then + call secondary_ice_production(t(:,k), psacws(:,k), msacwi(:,k), nsacwi(:,k)) + else + nsacwi(:,k) = 0.0_r8 + msacwi(:,k) = 0.0_r8 + end if + + call accrete_rain_snow(t(:,k), rho(:,k), umr(:,k), ums(:,k), unr(:,k), uns(:,k), & + qric(:,k), qsic(:,k), lamr(:,k), n0r(:,k), lams(:,k), n0s(:,k), & + pracs(:,k), npracs(:,k)) + + call heterogeneous_rain_freezing(t(:,k), qric(:,k), nric(:,k), lamr(:,k), & + mnuccr(:,k), nnuccr(:,k)) + + call accrete_cloud_water_rain(microp_uniform, qric(:,k), qcic(:,k), & + ncic(:,k), relvar(:,k), accre_enhan(:,k), pra(:,k), npra(:,k)) + + call self_collection_rain(rho(:,k), qric(:,k), nric(:,k), nragg(:,k)) + + if (do_cldice) then + call accrete_cloud_ice_snow(t(:,k), rho(:,k), asn(:,k), qiic(:,k), niic(:,k), & + qsic(:,k), lams(:,k), n0s(:,k), prai(:,k), nprai(:,k)) + else + prai(:,k) = 0._r8 + nprai(:,k) = 0._r8 + end if + + call evaporate_sublimate_precip(t(:,k), rho(:,k), & + dv(:,k), mu(:,k), sc(:,k), q(:,k), qvl(:,k), qvi(:,k), & + lcldm(:,k), precip_frac(:,k), arn(:,k), asn(:,k), qcic(:,k), qiic(:,k), & + qric(:,k), qsic(:,k), lamr(:,k), n0r(:,k), lams(:,k), n0s(:,k), & + pre(:,k), prds(:,k)) + + call bergeron_process_snow(t(:,k), rho(:,k), dv(:,k), mu(:,k), sc(:,k), & + qvl(:,k), qvi(:,k), asn(:,k), qcic(:,k), qsic(:,k), lams(:,k), n0s(:,k), & + bergs(:,k)) + + bergs(:,k)=bergs(:,k)*micro_mg_berg_eff_factor + + !+++PMC 12/3/12 - NEW VAPOR DEP/SUBLIMATION GOES HERE!!! + if (do_cldice) then + + call ice_deposition_sublimation(t(:,k), q(:,k), qi(:,k), ni(:,k), & + icldm(:,k), rho(:,k), dv(:,k), qvl(:,k), qvi(:,k), & + berg(:,k), vap_dep(:,k), ice_sublim(:,k)) + + berg(:,k)=berg(:,k)*micro_mg_berg_eff_factor + + where (vap_dep(:,k) < 0._r8 .and. qi(:,k) > qsmall .and. icldm(:,k) > mincld) + nsubi(:,k) = vap_dep(:,k) / qi(:,k) * ni(:,k) / icldm(:,k) + elsewhere + nsubi(:,k) = 0._r8 + end where + + ! bergeron process should not reduce nc unless + ! all ql is removed (which is handled elsewhere) + !in fact, nothing in this entire file makes nsubc nonzero. + nsubc(:,k) = 0._r8 + + end if !do_cldice + !---PMC 12/3/12 + + do i=1,mgncol + + ! conservation to ensure no negative values of cloud water/precipitation + ! in case microphysical process rates are large + !=================================================================== + + ! note: for check on conservation, processes are multiplied by omsm + ! to prevent problems due to round off error + + ! conservation of qc + !------------------------------------------------------------------- + + dum = ((prc(i,k)+pra(i,k)+mnuccc(i,k)+mnucct(i,k)+msacwi(i,k)+ & + psacws(i,k)+bergs(i,k))*lcldm(i,k)+berg(i,k))*deltat + + if (dum.gt.qc(i,k)) then + ratio = qc(i,k)/deltat/((prc(i,k)+pra(i,k)+mnuccc(i,k)+mnucct(i,k)+ & + msacwi(i,k)+psacws(i,k)+bergs(i,k))*lcldm(i,k)+berg(i,k))*omsm + prc(i,k) = prc(i,k)*ratio + pra(i,k) = pra(i,k)*ratio + mnuccc(i,k) = mnuccc(i,k)*ratio + mnucct(i,k) = mnucct(i,k)*ratio + msacwi(i,k) = msacwi(i,k)*ratio + psacws(i,k) = psacws(i,k)*ratio + bergs(i,k) = bergs(i,k)*ratio + berg(i,k) = berg(i,k)*ratio + qcrat(i,k) = ratio + else + qcrat(i,k) = 1._r8 + end if + + !PMC 12/3/12: ratio is also frac of step w/ liquid. + !thus we apply berg for "ratio" of timestep and vapor + !deposition for the remaining frac of the timestep. + if (qc(i,k) >= qsmall) then + vap_dep(i,k) = vap_dep(i,k)*(1._r8-qcrat(i,k)) + end if + + end do + + do i=1,mgncol + + !================================================================= + ! apply limiter to ensure that ice/snow sublimation and rain evap + ! don't push conditions into supersaturation, and ice deposition/nucleation don't + ! push conditions into sub-saturation + ! note this is done after qc conservation since we don't know how large + ! vap_dep is before then + ! estimates are only approximate since other process terms haven't been limited + ! for conservation yet + + ! first limit ice deposition/nucleation vap_dep + mnuccd + dum1 = vap_dep(i,k) + mnuccd(i,k) + if (dum1 > 1.e-20_r8) then + dum = (q(i,k)-qvi(i,k))/(1._r8 + xxls_squared*qvi(i,k)/(cpp*rv*t(i,k)**2))/deltat + dum = max(dum,0._r8) + if (dum1 > dum) then + ! Allocate the limited "dum" tendency to mnuccd and vap_dep + ! processes. Don't divide by cloud fraction; these are grid- + ! mean rates. + dum1 = mnuccd(i,k) / (vap_dep(i,k)+mnuccd(i,k)) + mnuccd(i,k) = dum*dum1 + vap_dep(i,k) = dum - mnuccd(i,k) + end if + end if + + end do + + do i=1,mgncol + + !=================================================================== + ! conservation of nc + !------------------------------------------------------------------- + dum = (nprc1(i,k)+npra(i,k)+nnuccc(i,k)+nnucct(i,k)+ & + npsacws(i,k)-nsubc(i,k))*lcldm(i,k)*deltat + + if (dum.gt.nc(i,k)) then + ratio = nc(i,k)/deltat/((nprc1(i,k)+npra(i,k)+nnuccc(i,k)+nnucct(i,k)+& + npsacws(i,k)-nsubc(i,k))*lcldm(i,k))*omsm + + nprc1(i,k) = nprc1(i,k)*ratio + npra(i,k) = npra(i,k)*ratio + nnuccc(i,k) = nnuccc(i,k)*ratio + nnucct(i,k) = nnucct(i,k)*ratio + npsacws(i,k) = npsacws(i,k)*ratio + nsubc(i,k)=nsubc(i,k)*ratio + end if + + mnuccri(i,k)=0._r8 + nnuccri(i,k)=0._r8 + + if (do_cldice) then + + ! freezing of rain to produce ice if mean rain size is smaller than Dcs + if (lamr(i,k) > qsmall .and. 1._r8/lamr(i,k) < Dcs) then + mnuccri(i,k)=mnuccr(i,k) + nnuccri(i,k)=nnuccr(i,k) + mnuccr(i,k)=0._r8 + nnuccr(i,k)=0._r8 + end if + end if + + end do + + do i=1,mgncol + + ! conservation of rain mixing ratio + !------------------------------------------------------------------- + dum = ((-pre(i,k)+pracs(i,k)+mnuccr(i,k)+mnuccri(i,k))*precip_frac(i,k)- & + (pra(i,k)+prc(i,k))*lcldm(i,k))*deltat + + ! note that qrtend is included below because of instantaneous freezing/melt + if (dum.gt.qr(i,k).and. & + (-pre(i,k)+pracs(i,k)+mnuccr(i,k)+mnuccri(i,k)).ge.qsmall) then + ratio = (qr(i,k)/deltat+(pra(i,k)+prc(i,k))*lcldm(i,k))/ & + precip_frac(i,k)/(-pre(i,k)+pracs(i,k)+mnuccr(i,k)+mnuccri(i,k))*omsm + pre(i,k)=pre(i,k)*ratio + pracs(i,k)=pracs(i,k)*ratio + mnuccr(i,k)=mnuccr(i,k)*ratio + mnuccri(i,k)=mnuccri(i,k)*ratio + end if + + end do + + do i=1,mgncol + + ! conservation of rain number + !------------------------------------------------------------------- + + ! Add evaporation of rain number. + if (pre(i,k) < 0._r8) then + dum = pre(i,k)*deltat/qr(i,k) + dum = max(-1._r8,dum) + nsubr(i,k) = dum*nr(i,k)/deltat + else + nsubr(i,k) = 0._r8 + end if + + end do + + do i=1,mgncol + + dum = ((-nsubr(i,k)+npracs(i,k)+nnuccr(i,k)+nnuccri(i,k)-nragg(i,k))*precip_frac(i,k)- & + nprc(i,k)*lcldm(i,k))*deltat + + if (dum.gt.nr(i,k)) then + ratio = (nr(i,k)/deltat+nprc(i,k)*lcldm(i,k)/precip_frac(i,k))/ & + (-nsubr(i,k)+npracs(i,k)+nnuccr(i,k)+nnuccri(i,k)-nragg(i,k))*omsm + + nragg(i,k)=nragg(i,k)*ratio + npracs(i,k)=npracs(i,k)*ratio + nnuccr(i,k)=nnuccr(i,k)*ratio + nsubr(i,k)=nsubr(i,k)*ratio + nnuccri(i,k)=nnuccri(i,k)*ratio + end if + + end do + + if (do_cldice) then + + do i=1,mgncol + + ! conservation of qi + !------------------------------------------------------------------- + + dum = ((-mnuccc(i,k)-mnucct(i,k)-mnudep(i,k)-msacwi(i,k))*lcldm(i,k)+(prci(i,k)+ & + prai(i,k))*icldm(i,k)-mnuccri(i,k)*precip_frac(i,k) & + -ice_sublim(i,k)-vap_dep(i,k)-berg(i,k)-mnuccd(i,k))*deltat + + if (dum.gt.qi(i,k)) then + ratio = (qi(i,k)/deltat+vap_dep(i,k)+berg(i,k)+mnuccd(i,k)+ & + (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k))*lcldm(i,k)+ & + mnuccri(i,k)*precip_frac(i,k))/ & + ((prci(i,k)+prai(i,k))*icldm(i,k)-ice_sublim(i,k))*omsm + prci(i,k) = prci(i,k)*ratio + prai(i,k) = prai(i,k)*ratio + ice_sublim(i,k) = ice_sublim(i,k)*ratio + end if + + end do + + end if + + if (do_cldice) then + + do i=1,mgncol + + ! conservation of ni + !------------------------------------------------------------------- + if (use_hetfrz_classnuc) then + tmpfrz = nnuccc(i,k) + else + tmpfrz = 0._r8 + end if + dum = ((-nnucct(i,k)-tmpfrz-nnudep(i,k)-nsacwi(i,k))*lcldm(i,k)+(nprci(i,k)+ & + nprai(i,k)-nsubi(i,k))*icldm(i,k)-nnuccri(i,k)*precip_frac(i,k)- & + nnuccd(i,k))*deltat + + if (dum.gt.ni(i,k)) then + ratio = (ni(i,k)/deltat+nnuccd(i,k)+ & + (nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k))*lcldm(i,k)+ & + nnuccri(i,k)*precip_frac(i,k))/ & + ((nprci(i,k)+nprai(i,k)-nsubi(i,k))*icldm(i,k))*omsm + nprci(i,k) = nprci(i,k)*ratio + nprai(i,k) = nprai(i,k)*ratio + nsubi(i,k) = nsubi(i,k)*ratio + end if + + end do + + end if + + do i=1,mgncol + + ! conservation of snow mixing ratio + !------------------------------------------------------------------- + dum = (-(prds(i,k)+pracs(i,k)+mnuccr(i,k))*precip_frac(i,k)-(prai(i,k)+prci(i,k))*icldm(i,k) & + -(bergs(i,k)+psacws(i,k))*lcldm(i,k))*deltat + + if (dum.gt.qs(i,k).and.-prds(i,k).ge.qsmall) then + ratio = (qs(i,k)/deltat+(prai(i,k)+prci(i,k))*icldm(i,k)+ & + (bergs(i,k)+psacws(i,k))*lcldm(i,k)+(pracs(i,k)+mnuccr(i,k))*precip_frac(i,k))/ & + precip_frac(i,k)/(-prds(i,k))*omsm + prds(i,k)=prds(i,k)*ratio + end if + + end do + + do i=1,mgncol + + ! conservation of snow number + !------------------------------------------------------------------- + ! calculate loss of number due to sublimation + ! for now neglect sublimation of ns + nsubs(i,k)=0._r8 + + dum = ((-nsagg(i,k)-nsubs(i,k)-nnuccr(i,k))*precip_frac(i,k)-nprci(i,k)*icldm(i,k))*deltat + + if (dum.gt.ns(i,k)) then + ratio = (ns(i,k)/deltat+nnuccr(i,k)* & + precip_frac(i,k)+nprci(i,k)*icldm(i,k))/precip_frac(i,k)/ & + (-nsubs(i,k)-nsagg(i,k))*omsm + nsubs(i,k)=nsubs(i,k)*ratio + nsagg(i,k)=nsagg(i,k)*ratio + end if + + end do + + do i=1,mgncol + + ! next limit ice and snow sublimation and rain evaporation + ! get estimate of q and t at end of time step + ! don't include other microphysical processes since they haven't + ! been limited via conservation checks yet + + if ((pre(i,k)+prds(i,k))*precip_frac(i,k)+ice_sublim(i,k) < -1.e-20_r8) then + + qtmp=q(i,k)-(ice_sublim(i,k)+vap_dep(i,k)+mnuccd(i,k)+ & + (pre(i,k)+prds(i,k))*precip_frac(i,k))*deltat + ttmp=t(i,k)+((pre(i,k)*precip_frac(i,k))*xxlv+ & + (prds(i,k)*precip_frac(i,k)+vap_dep(i,k)+ice_sublim(i,k)+mnuccd(i,k))*xxls)*deltat/cpp + + ! use rhw to allow ice supersaturation + call qsat_water(ttmp, p(i,k), esn, qvn) + + ! modify ice/precip evaporation rate if q > qsat + if (qtmp > qvn) then + + dum1=pre(i,k)*precip_frac(i,k)/((pre(i,k)+prds(i,k))*precip_frac(i,k)+ice_sublim(i,k)) + dum2=prds(i,k)*precip_frac(i,k)/((pre(i,k)+prds(i,k))*precip_frac(i,k)+ice_sublim(i,k)) + ! recalculate q and t after vap_dep and mnuccd but without evap or sublim + qtmp=q(i,k)-(vap_dep(i,k)+mnuccd(i,k))*deltat + ttmp=t(i,k)+((vap_dep(i,k)+mnuccd(i,k))*xxls)*deltat/cpp + + ! use rhw to allow ice supersaturation + call qsat_water(ttmp, p(i,k), esn, qvn) + + dum=(qtmp-qvn)/(1._r8 + xxlv_squared*qvn/(cpp*rv*ttmp**2)) + dum=min(dum,0._r8) + + ! modify rates if needed, divide by precip_frac to get local (in-precip) value + pre(i,k)=dum*dum1/deltat/precip_frac(i,k) + + ! do separately using RHI for prds and ice_sublim + call qsat_ice(ttmp, p(i,k), esn, qvn) + + dum=(qtmp-qvn)/(1._r8 + xxls_squared*qvn/(cpp*rv*ttmp**2)) + dum=min(dum,0._r8) + + ! modify rates if needed, divide by precip_frac to get local (in-precip) value + prds(i,k) = dum*dum2/deltat/precip_frac(i,k) + + ! don't divide ice_sublim by cloud fraction since it is grid-averaged + dum1 = (1._r8-dum1-dum2) + ice_sublim(i,k) = dum*dum1/deltat + end if + end if + + end do + + ! Big "administration" loop enforces conservation, updates variables + ! that accumulate over substeps, and sets output variables. + + do i=1,mgncol + + ! get tendencies due to microphysical conversion processes + !========================================================== + ! note: tendencies are multiplied by appropriate cloud/precip + ! fraction to get grid-scale values + ! note: vap_dep is already grid-average values + + ! The net tendencies need to be added to rather than overwritten, + ! because they may have a value already set for instantaneous + ! melting/freezing. + + qvlat(i,k) = qvlat(i,k)-(pre(i,k)+prds(i,k))*precip_frac(i,k)-& + vap_dep(i,k)-ice_sublim(i,k)-mnuccd(i,k)-mnudep(i,k)*lcldm(i,k) + + tlat(i,k) = tlat(i,k)+((pre(i,k)*precip_frac(i,k)) & + *xxlv+(prds(i,k)*precip_frac(i,k)+vap_dep(i,k)+ice_sublim(i,k)+mnuccd(i,k)+mnudep(i,k)*lcldm(i,k))*xxls+ & + ((bergs(i,k)+psacws(i,k)+mnuccc(i,k)+mnucct(i,k)+msacwi(i,k))*lcldm(i,k)+(mnuccr(i,k)+ & + pracs(i,k)+mnuccri(i,k))*precip_frac(i,k)+berg(i,k))*xlf) + + qctend(i,k) = qctend(i,k)+ & + (-pra(i,k)-prc(i,k)-mnuccc(i,k)-mnucct(i,k)-msacwi(i,k)- & + psacws(i,k)-bergs(i,k))*lcldm(i,k)-berg(i,k) + + if (do_cldice) then + qitend(i,k) = qitend(i,k)+ & + (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k))*lcldm(i,k)+(-prci(i,k)- & + prai(i,k))*icldm(i,k)+vap_dep(i,k)+berg(i,k)+ice_sublim(i,k)+ & + mnuccd(i,k)+mnuccri(i,k)*precip_frac(i,k) + end if + + qrtend(i,k) = qrtend(i,k)+ & + (pra(i,k)+prc(i,k))*lcldm(i,k)+(pre(i,k)-pracs(i,k)- & + mnuccr(i,k)-mnuccri(i,k))*precip_frac(i,k) + + qstend(i,k) = qstend(i,k)+ & + (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k)+(prds(i,k)+ & + pracs(i,k)+mnuccr(i,k))*precip_frac(i,k) + + + cmeout(i,k) = vap_dep(i,k) + ice_sublim(i,k) + mnuccd(i,k) + + ! add output for cmei (accumulate) + cmeitot(i,k) = vap_dep(i,k) + ice_sublim(i,k) + mnuccd(i,k) + + ! assign variables for trop_mozart, these are grid-average + !------------------------------------------------------------------- + ! evaporation/sublimation is stored here as positive term + + evapsnow(i,k) = -prds(i,k)*precip_frac(i,k) + nevapr(i,k) = -pre(i,k)*precip_frac(i,k) + prer_evap(i,k) = -pre(i,k)*precip_frac(i,k) + + ! change to make sure prain is positive: do not remove snow from + ! prain used for wet deposition + prain(i,k) = (pra(i,k)+prc(i,k))*lcldm(i,k)+(-pracs(i,k)- & + mnuccr(i,k)-mnuccri(i,k))*precip_frac(i,k) + prodsnow(i,k) = (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k)+(& + pracs(i,k)+mnuccr(i,k))*precip_frac(i,k) + + ! following are used to calculate 1st order conversion rate of cloud water + ! to rain and snow (1/s), for later use in aerosol wet removal routine + ! previously, wetdepa used (prain/qc) for this, and the qc in wetdepa may be smaller than the qc + ! used to calculate pra, prc, ... in this routine + ! qcsinksum_rate1ord = { rate of direct transfer of cloud water to rain & snow } + ! (no cloud ice or bergeron terms) + qcsinksum_rate1ord(i,k) = (pra(i,k)+prc(i,k)+psacws(i,k))*lcldm(i,k) + ! Avoid zero/near-zero division. + qcsinksum_rate1ord(i,k) = qcsinksum_rate1ord(i,k) / & + max(qc(i,k),1.0e-30_r8) + + + ! microphysics output, note this is grid-averaged + pratot(i,k) = pra(i,k)*lcldm(i,k) + prctot(i,k) = prc(i,k)*lcldm(i,k) + mnuccctot(i,k) = mnuccc(i,k)*lcldm(i,k) + mnuccttot(i,k) = mnucct(i,k)*lcldm(i,k) + msacwitot(i,k) = msacwi(i,k)*lcldm(i,k) + psacwstot(i,k) = psacws(i,k)*lcldm(i,k) + bergstot(i,k) = bergs(i,k)*lcldm(i,k) + bergtot(i,k) = berg(i,k) + prcitot(i,k) = prci(i,k)*icldm(i,k) + praitot(i,k) = prai(i,k)*icldm(i,k) + mnuccdtot(i,k) = mnuccd(i,k)*icldm(i,k) + + pracstot(i,k) = pracs(i,k)*precip_frac(i,k) + mnuccrtot(i,k) = mnuccr(i,k)*precip_frac(i,k) + + + nctend(i,k) = nctend(i,k)+& + (-nnuccc(i,k)-nnucct(i,k)-npsacws(i,k)+nsubc(i,k) & + -npra(i,k)-nprc1(i,k))*lcldm(i,k) + + if (do_cldice) then + if (use_hetfrz_classnuc) then + tmpfrz = nnuccc(i,k) + else + tmpfrz = 0._r8 + end if + nitend(i,k) = nitend(i,k)+ nnuccd(i,k)+ & + (nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k))*lcldm(i,k)+(nsubi(i,k)-nprci(i,k)- & + nprai(i,k))*icldm(i,k)+nnuccri(i,k)*precip_frac(i,k) + end if + + nstend(i,k) = nstend(i,k)+(nsubs(i,k)+ & + nsagg(i,k)+nnuccr(i,k))*precip_frac(i,k)+nprci(i,k)*icldm(i,k) + + nrtend(i,k) = nrtend(i,k)+ & + nprc(i,k)*lcldm(i,k)+(nsubr(i,k)-npracs(i,k)-nnuccr(i,k) & + -nnuccri(i,k)+nragg(i,k))*precip_frac(i,k) + + ! make sure that ni at advanced time step does not exceed + ! maximum (existing N + source terms*dt), which is possible if mtime < deltat + ! note that currently mtime = deltat + !================================================================ + + if (do_cldice .and. nitend(i,k).gt.0._r8.and.ni(i,k)+nitend(i,k)*deltat.gt.nimax(i,k)) then + nitend(i,k)=max(0._r8,(nimax(i,k)-ni(i,k))/deltat) + end if + + end do + + ! End of "administration" loop + + end do micro_vert_loop ! end k loop + + !----------------------------------------------------- + ! convert rain/snow q and N for output to history, note, + ! output is for gridbox average + + qrout = qr + nrout = nr * rho + qsout = qs + nsout = ns * rho + + ! calculate precip fluxes + ! calculate the precip flux (kg/m2/s) as mixingratio(kg/kg)*airdensity(kg/m3)*massweightedfallspeed(m/s) + ! --------------------------------------------------------------------- + + rflx(:,2:) = rflx(:,2:) + (qric*rho*umr*precip_frac) + sflx(:,2:) = sflx(:,2:) + (qsic*rho*ums*precip_frac) + + ! calculate n0r and lamr from rain mass and number + ! divide by precip fraction to get in-precip (local) values of + ! rain mass and number, divide by rhow to get rain number in kg^-1 + + call size_dist_param_basic(mg_rain_props, qric, nric, lamr, n0r) + + ! Calculate rercld + + ! calculate mean size of combined rain and cloud water + + call calc_rercld(lamr, n0r, lamc, pgam, qric, qcic, ncic, & + rercld) + + + ! Assign variables back to start-of-timestep values + ! Some state variables are changed before the main microphysics loop + ! to make "instantaneous" adjustments. Afterward, we must move those changes + ! back into the tendencies. + ! These processes: + ! - Droplet activation (npccn, impacts nc) + ! - Instantaneous snow melting (minstsm/ninstsm, impacts qr/qs/nr/ns) + ! - Instantaneous rain freezing (minstfr/ninstrf, impacts qr/qs/nr/ns) + !================================================================================ + + ! Re-apply droplet activation tendency + nc = ncn + nctend = nctend + npccn + + ! Re-apply rain freezing and snow melting. + dum_2D = qs + qs = qsn + qstend = qstend + (dum_2D-qs)/deltat + + dum_2D = ns + ns = nsn + nstend = nstend + (dum_2D-ns)/deltat + + dum_2D = qr + qr = qrn + qrtend = qrtend + (dum_2D-qr)/deltat + + dum_2D = nr + nr = nrn + nrtend = nrtend + (dum_2D-nr)/deltat + + !............................................................................. + + !================================================================================ + + ! modify to include snow. in prain & evap (diagnostic here: for wet dep) + nevapr = nevapr + evapsnow + prain = prain + prodsnow + + sed_col_loop: do i=1,mgncol + + do k=1,nlev + + ! calculate sedimentation for cloud water and ice + !================================================================================ + + ! update in-cloud cloud mixing ratio and number concentration + ! with microphysical tendencies to calculate sedimentation, assign to dummy vars + ! note: these are in-cloud values***, hence we divide by cloud fraction + + dumc(i,k) = (qc(i,k)+qctend(i,k)*deltat)/lcldm(i,k) + dumi(i,k) = (qi(i,k)+qitend(i,k)*deltat)/icldm(i,k) + dumnc(i,k) = max((nc(i,k)+nctend(i,k)*deltat)/lcldm(i,k),0._r8) + dumni(i,k) = max((ni(i,k)+nitend(i,k)*deltat)/icldm(i,k),0._r8) + + dumr(i,k) = (qr(i,k)+qrtend(i,k)*deltat)/precip_frac(i,k) + dumnr(i,k) = max((nr(i,k)+nrtend(i,k)*deltat)/precip_frac(i,k),0._r8) + dums(i,k) = (qs(i,k)+qstend(i,k)*deltat)/precip_frac(i,k) + dumns(i,k) = max((ns(i,k)+nstend(i,k)*deltat)/precip_frac(i,k),0._r8) + + + ! switch for specification of droplet and crystal number + if (nccons) then + dumnc(i,k)=ncnst/rho(i,k) + end if + + ! switch for specification of cloud ice number + if (nicons) then + dumni(i,k)=ninst/rho(i,k) + end if + + ! obtain new slope parameter to avoid possible singularity + + call size_dist_param_basic(mg_ice_props, dumi(i,k), dumni(i,k), & + lami(i,k)) + + call size_dist_param_liq(mg_liq_props, dumc(i,k), dumnc(i,k), rho(i,k), & + pgam(i,k), lamc(i,k)) + + ! calculate number and mass weighted fall velocity for droplets and cloud ice + !------------------------------------------------------------------- + + + if (dumc(i,k).ge.qsmall) then + + vtrmc(i,k)=acn(i,k)*gamma(4._r8+bc+pgam(i,k))/ & + (lamc(i,k)**bc*gamma(pgam(i,k)+4._r8)) + + fc(k) = g*rho(i,k)*vtrmc(i,k) + + fnc(k) = g*rho(i,k)* & + acn(i,k)*gamma(1._r8+bc+pgam(i,k))/ & + (lamc(i,k)**bc*gamma(pgam(i,k)+1._r8)) + else + fc(k) = 0._r8 + fnc(k)= 0._r8 + end if + + ! calculate number and mass weighted fall velocity for cloud ice + + if (dumi(i,k).ge.qsmall) then + + vtrmi(i,k)=min(ain(i,k)*gamma_bi_plus4/(6._r8*lami(i,k)**bi), & + 1.2_r8*rhof(i,k)) + + fi(k) = g*rho(i,k)*vtrmi(i,k) + fni(k) = g*rho(i,k)* & + min(ain(i,k)*gamma_bi_plus1/lami(i,k)**bi,1.2_r8*rhof(i,k)) + else + fi(k) = 0._r8 + fni(k)= 0._r8 + end if + + ! fallspeed for rain + + call size_dist_param_basic(mg_rain_props, dumr(i,k), dumnr(i,k), & + lamr(i,k)) + + if (lamr(i,k).ge.qsmall) then + + ! 'final' values of number and mass weighted mean fallspeed for rain (m/s) + + unr(i,k) = min(arn(i,k)*gamma_br_plus1/lamr(i,k)**br,9.1_r8*rhof(i,k)) + umr(i,k) = min(arn(i,k)*gamma_br_plus4/(6._r8*lamr(i,k)**br),9.1_r8*rhof(i,k)) + + fr(k) = g*rho(i,k)*umr(i,k) + fnr(k) = g*rho(i,k)*unr(i,k) + + else + fr(k)=0._r8 + fnr(k)=0._r8 + end if + + ! fallspeed for snow + + call size_dist_param_basic(mg_snow_props, dums(i,k), dumns(i,k), & + lams(i,k)) + + if (lams(i,k).ge.qsmall) then + + ! 'final' values of number and mass weighted mean fallspeed for snow (m/s) + ums(i,k) = min(asn(i,k)*gamma_bs_plus4/(6._r8*lams(i,k)**bs),1.2_r8*rhof(i,k)) + uns(i,k) = min(asn(i,k)*gamma_bs_plus1/lams(i,k)**bs,1.2_r8*rhof(i,k)) + + fs(k) = g*rho(i,k)*ums(i,k) + fns(k) = g*rho(i,k)*uns(i,k) + + else + fs(k)=0._r8 + fns(k)=0._r8 + end if + + ! redefine dummy variables - sedimentation is calculated over grid-scale + ! quantities to ensure conservation + + dumc(i,k) = (qc(i,k)+qctend(i,k)*deltat) + dumnc(i,k) = max((nc(i,k)+nctend(i,k)*deltat),0._r8) + dumi(i,k) = (qi(i,k)+qitend(i,k)*deltat) + dumni(i,k) = max((ni(i,k)+nitend(i,k)*deltat),0._r8) + dumr(i,k) = (qr(i,k)+qrtend(i,k)*deltat) + dumnr(i,k) = max((nr(i,k)+nrtend(i,k)*deltat),0._r8) + dums(i,k) = (qs(i,k)+qstend(i,k)*deltat) + dumns(i,k) = max((ns(i,k)+nstend(i,k)*deltat),0._r8) + + if (dumc(i,k).lt.qsmall) dumnc(i,k)=0._r8 + if (dumi(i,k).lt.qsmall) dumni(i,k)=0._r8 + if (dumr(i,k).lt.qsmall) dumnr(i,k)=0._r8 + if (dums(i,k).lt.qsmall) dumns(i,k)=0._r8 + + end do !!! vertical loop + + ! initialize nstep for sedimentation sub-steps + + ! calculate number of split time steps to ensure courant stability criteria + ! for sedimentation calculations + !------------------------------------------------------------------- + nstep = 1 + int(max( & + maxval( fi/pdel(i,:)), & + maxval(fni/pdel(i,:))) & + * deltat) + + + ! loop over sedimentation sub-time step to ensure stability + !============================================================== + do n = 1,nstep + + if (do_cldice) then + falouti = fi * dumi(i,:) + faloutni = fni * dumni(i,:) + else + falouti = 0._r8 + faloutni = 0._r8 + end if + + ! top of model + + k = 1 + + ! add fallout terms to microphysical tendencies + faltndi = falouti(k)/pdel(i,k) + faltndni = faloutni(k)/pdel(i,k) + qitend(i,k) = qitend(i,k)-faltndi/nstep + nitend(i,k) = nitend(i,k)-faltndni/nstep + + ! sedimentation tendency for output + qisedten(i,k)=qisedten(i,k)-faltndi/nstep + + dumi(i,k) = dumi(i,k)-faltndi*deltat/nstep + dumni(i,k) = dumni(i,k)-faltndni*deltat/nstep + + do k = 2,nlev + + ! for cloud liquid and ice, if cloud fraction increases with height + ! then add flux from above to both vapor and cloud water of current level + ! this means that flux entering clear portion of cell from above evaporates + ! instantly + + ! note: this is not an issue with precip, since we assume max overlap + dum1=icldm(i,k)/icldm(i,k-1) + dum1=min(dum1,1._r8) + + faltndqie=(falouti(k)-falouti(k-1))/pdel(i,k) + faltndi=(falouti(k)-dum1*falouti(k-1))/pdel(i,k) + faltndni=(faloutni(k)-dum1*faloutni(k-1))/pdel(i,k) + + ! add fallout terms to eulerian tendencies + + qitend(i,k) = qitend(i,k)-faltndi/nstep + nitend(i,k) = nitend(i,k)-faltndni/nstep + + ! sedimentation tendency for output + qisedten(i,k)=qisedten(i,k)-faltndi/nstep + + ! add terms to to evap/sub of cloud water + + qvlat(i,k)=qvlat(i,k)-(faltndqie-faltndi)/nstep + ! for output + qisevap(i,k)=qisevap(i,k)-(faltndqie-faltndi)/nstep + + tlat(i,k)=tlat(i,k)+(faltndqie-faltndi)*xxls/nstep + + dumi(i,k) = dumi(i,k)-faltndi*deltat/nstep + dumni(i,k) = dumni(i,k)-faltndni*deltat/nstep + + end do + + ! units below are m/s + ! sedimentation flux at surface is added to precip flux at surface + ! to get total precip (cloud + precip water) rate + + prect(i) = prect(i)+falouti(nlev)/g/real(nstep)/1000._r8 + preci(i) = preci(i)+falouti(nlev)/g/real(nstep)/1000._r8 + + end do + + ! calculate number of split time steps to ensure courant stability criteria + ! for sedimentation calculations + !------------------------------------------------------------------- + nstep = 1 + int(max( & + maxval( fc/pdel(i,:)), & + maxval(fnc/pdel(i,:))) & + * deltat) + + ! loop over sedimentation sub-time step to ensure stability + !============================================================== + do n = 1,nstep + + faloutc = fc * dumc(i,:) + faloutnc = fnc * dumnc(i,:) + + ! top of model + k = 1 + + ! add fallout terms to microphysical tendencies + faltndc = faloutc(k)/pdel(i,k) + faltndnc = faloutnc(k)/pdel(i,k) + qctend(i,k) = qctend(i,k)-faltndc/nstep + nctend(i,k) = nctend(i,k)-faltndnc/nstep + + ! sedimentation tendency for output + qcsedten(i,k)=qcsedten(i,k)-faltndc/nstep + + dumc(i,k) = dumc(i,k)-faltndc*deltat/nstep + dumnc(i,k) = dumnc(i,k)-faltndnc*deltat/nstep + + do k = 2,nlev + + dum=lcldm(i,k)/lcldm(i,k-1) + dum=min(dum,1._r8) + faltndqce=(faloutc(k)-faloutc(k-1))/pdel(i,k) + faltndc=(faloutc(k)-dum*faloutc(k-1))/pdel(i,k) + faltndnc=(faloutnc(k)-dum*faloutnc(k-1))/pdel(i,k) + + ! add fallout terms to eulerian tendencies + qctend(i,k) = qctend(i,k)-faltndc/nstep + nctend(i,k) = nctend(i,k)-faltndnc/nstep + + ! sedimentation tendency for output + qcsedten(i,k)=qcsedten(i,k)-faltndc/nstep + + ! add terms to to evap/sub of cloud water + qvlat(i,k)=qvlat(i,k)-(faltndqce-faltndc)/nstep + ! for output + qcsevap(i,k)=qcsevap(i,k)-(faltndqce-faltndc)/nstep + + tlat(i,k)=tlat(i,k)+(faltndqce-faltndc)*xxlv/nstep + + dumc(i,k) = dumc(i,k)-faltndc*deltat/nstep + dumnc(i,k) = dumnc(i,k)-faltndnc*deltat/nstep + + end do + + prect(i) = prect(i)+faloutc(nlev)/g/real(nstep)/1000._r8 + + end do + + ! calculate number of split time steps to ensure courant stability criteria + ! for sedimentation calculations + !------------------------------------------------------------------- + nstep = 1 + int(max( & + maxval( fr/pdel(i,:)), & + maxval(fnr/pdel(i,:))) & + * deltat) + + ! loop over sedimentation sub-time step to ensure stability + !============================================================== + do n = 1,nstep + + faloutr = fr * dumr(i,:) + faloutnr = fnr * dumnr(i,:) + + ! top of model + k = 1 + + ! add fallout terms to microphysical tendencies + faltndr = faloutr(k)/pdel(i,k) + faltndnr = faloutnr(k)/pdel(i,k) + qrtend(i,k) = qrtend(i,k)-faltndr/nstep + nrtend(i,k) = nrtend(i,k)-faltndnr/nstep + + ! sedimentation tendency for output + qrsedten(i,k)=qrsedten(i,k)-faltndr/nstep + + dumr(i,k) = dumr(i,k)-faltndr*deltat/real(nstep) + dumnr(i,k) = dumnr(i,k)-faltndnr*deltat/real(nstep) + + do k = 2,nlev + + faltndr=(faloutr(k)-faloutr(k-1))/pdel(i,k) + faltndnr=(faloutnr(k)-faloutnr(k-1))/pdel(i,k) + + ! add fallout terms to eulerian tendencies + qrtend(i,k) = qrtend(i,k)-faltndr/nstep + nrtend(i,k) = nrtend(i,k)-faltndnr/nstep + + ! sedimentation tendency for output + qrsedten(i,k)=qrsedten(i,k)-faltndr/nstep + + dumr(i,k) = dumr(i,k)-faltndr*deltat/real(nstep) + dumnr(i,k) = dumnr(i,k)-faltndnr*deltat/real(nstep) + + end do + + prect(i) = prect(i)+faloutr(nlev)/g/real(nstep)/1000._r8 + + end do + + ! calculate number of split time steps to ensure courant stability criteria + ! for sedimentation calculations + !------------------------------------------------------------------- + nstep = 1 + int(max( & + maxval( fs/pdel(i,:)), & + maxval(fns/pdel(i,:))) & + * deltat) + + ! loop over sedimentation sub-time step to ensure stability + !============================================================== + do n = 1,nstep + + falouts = fs * dums(i,:) + faloutns = fns * dumns(i,:) + + ! top of model + k = 1 + + ! add fallout terms to microphysical tendencies + faltnds = falouts(k)/pdel(i,k) + faltndns = faloutns(k)/pdel(i,k) + qstend(i,k) = qstend(i,k)-faltnds/nstep + nstend(i,k) = nstend(i,k)-faltndns/nstep + + ! sedimentation tendency for output + qssedten(i,k)=qssedten(i,k)-faltnds/nstep + + dums(i,k) = dums(i,k)-faltnds*deltat/real(nstep) + dumns(i,k) = dumns(i,k)-faltndns*deltat/real(nstep) + + do k = 2,nlev + + faltnds=(falouts(k)-falouts(k-1))/pdel(i,k) + faltndns=(faloutns(k)-faloutns(k-1))/pdel(i,k) + + ! add fallout terms to eulerian tendencies + qstend(i,k) = qstend(i,k)-faltnds/nstep + nstend(i,k) = nstend(i,k)-faltndns/nstep + + ! sedimentation tendency for output + qssedten(i,k)=qssedten(i,k)-faltnds/nstep + + dums(i,k) = dums(i,k)-faltnds*deltat/real(nstep) + dumns(i,k) = dumns(i,k)-faltndns*deltat/real(nstep) + + end do !! k loop + + prect(i) = prect(i)+falouts(nlev)/g/real(nstep)/1000._r8 + preci(i) = preci(i)+falouts(nlev)/g/real(nstep)/1000._r8 + + end do !! nstep loop + + ! end sedimentation + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + ! get new update for variables that includes sedimentation tendency + ! note : here dum variables are grid-average, NOT in-cloud + + do k=1,nlev + + dumc(i,k) = max(qc(i,k)+qctend(i,k)*deltat,0._r8) + dumi(i,k) = max(qi(i,k)+qitend(i,k)*deltat,0._r8) + dumnc(i,k) = max(nc(i,k)+nctend(i,k)*deltat,0._r8) + dumni(i,k) = max(ni(i,k)+nitend(i,k)*deltat,0._r8) + + dumr(i,k) = max(qr(i,k)+qrtend(i,k)*deltat,0._r8) + dumnr(i,k) = max(nr(i,k)+nrtend(i,k)*deltat,0._r8) + dums(i,k) = max(qs(i,k)+qstend(i,k)*deltat,0._r8) + dumns(i,k) = max(ns(i,k)+nstend(i,k)*deltat,0._r8) + + ! switch for specification of droplet and crystal number + if (nccons) then + dumnc(i,k)=ncnst/rho(i,k)*lcldm(i,k) + end if + + ! switch for specification of cloud ice number + if (nicons) then + dumni(i,k)=ninst/rho(i,k)*icldm(i,k) + end if + + if (dumc(i,k).lt.qsmall) dumnc(i,k)=0._r8 + if (dumi(i,k).lt.qsmall) dumni(i,k)=0._r8 + if (dumr(i,k).lt.qsmall) dumnr(i,k)=0._r8 + if (dums(i,k).lt.qsmall) dumns(i,k)=0._r8 + + ! calculate instantaneous processes (melting, homogeneous freezing) + !==================================================================== + + ! melting of snow at +2 C + + if (t(i,k)+tlat(i,k)/cpp*deltat > snowmelt) then + if (dums(i,k) > 0._r8) then + + ! make sure melting snow doesn't reduce temperature below threshold + dum = -xlf/cpp*dums(i,k) + if (t(i,k)+tlat(i,k)/cpp*deltat+dum.lt. snowmelt) then + dum = (t(i,k)+tlat(i,k)/cpp*deltat-snowmelt)*cpp/xlf + dum = dum/dums(i,k) + dum = max(0._r8,dum) + dum = min(1._r8,dum) + else + dum = 1._r8 + end if + + qstend(i,k)=qstend(i,k)-dum*dums(i,k)/deltat + nstend(i,k)=nstend(i,k)-dum*dumns(i,k)/deltat + qrtend(i,k)=qrtend(i,k)+dum*dums(i,k)/deltat + nrtend(i,k)=nrtend(i,k)+dum*dumns(i,k)/deltat + + dum1=-xlf*dum*dums(i,k)/deltat + tlat(i,k)=tlat(i,k)+dum1 + meltsdttot(i,k)=meltsdttot(i,k) + dum1 + end if + end if + + ! freezing of rain at -5 C + + if (t(i,k)+tlat(i,k)/cpp*deltat < rainfrze) then + + if (dumr(i,k) > 0._r8) then + + ! make sure freezing rain doesn't increase temperature above threshold + dum = xlf/cpp*dumr(i,k) + if (t(i,k)+tlat(i,k)/cpp*deltat+dum.gt.rainfrze) then + dum = -(t(i,k)+tlat(i,k)/cpp*deltat-rainfrze)*cpp/xlf + dum = dum/dumr(i,k) + dum = max(0._r8,dum) + dum = min(1._r8,dum) + else + dum = 1._r8 + end if + + qrtend(i,k)=qrtend(i,k)-dum*dumr(i,k)/deltat + nrtend(i,k)=nrtend(i,k)-dum*dumnr(i,k)/deltat + + ! get mean size of rain = 1/lamr, add frozen rain to either snow or cloud ice + ! depending on mean rain size + + call size_dist_param_basic(mg_rain_props, dumr(i,k), dumnr(i,k), & + lamr(i,k)) + + if (lamr(i,k) < 1._r8/Dcs) then + qstend(i,k)=qstend(i,k)+dum*dumr(i,k)/deltat + nstend(i,k)=nstend(i,k)+dum*dumnr(i,k)/deltat + else + qitend(i,k)=qitend(i,k)+dum*dumr(i,k)/deltat + nitend(i,k)=nitend(i,k)+dum*dumnr(i,k)/deltat + end if + + ! heating tendency + dum1 = xlf*dum*dumr(i,k)/deltat + frzrdttot(i,k)=frzrdttot(i,k) + dum1 + tlat(i,k)=tlat(i,k)+dum1 + + end if + end if + + + if (do_cldice) then + if (t(i,k)+tlat(i,k)/cpp*deltat > tmelt) then + if (dumi(i,k) > 0._r8) then + + ! limit so that melting does not push temperature below freezing + !----------------------------------------------------------------- + dum = -dumi(i,k)*xlf/cpp + if (t(i,k)+tlat(i,k)/cpp*deltat+dum.lt.tmelt) then + dum = (t(i,k)+tlat(i,k)/cpp*deltat-tmelt)*cpp/xlf + dum = dum/dumi(i,k) + dum = max(0._r8,dum) + dum = min(1._r8,dum) + else + dum = 1._r8 + end if + + qctend(i,k)=qctend(i,k)+dum*dumi(i,k)/deltat + + ! for output + melttot(i,k)=dum*dumi(i,k)/deltat + + ! assume melting ice produces droplet + ! mean volume radius of 8 micron + + nctend(i,k)=nctend(i,k)+3._r8*dum*dumi(i,k)/deltat/ & + (4._r8*pi*5.12e-16_r8*rhow) + + qitend(i,k)=((1._r8-dum)*dumi(i,k)-qi(i,k))/deltat + nitend(i,k)=((1._r8-dum)*dumni(i,k)-ni(i,k))/deltat + tlat(i,k)=tlat(i,k)-xlf*dum*dumi(i,k)/deltat + end if + end if + + ! homogeneously freeze droplets at -40 C + !----------------------------------------------------------------- + + if (t(i,k)+tlat(i,k)/cpp*deltat < 233.15_r8) then + if (dumc(i,k) > 0._r8) then + + ! limit so that freezing does not push temperature above threshold + dum = dumc(i,k)*xlf/cpp + if (t(i,k)+tlat(i,k)/cpp*deltat+dum.gt.233.15_r8) then + dum = -(t(i,k)+tlat(i,k)/cpp*deltat-233.15_r8)*cpp/xlf + dum = dum/dumc(i,k) + dum = max(0._r8,dum) + dum = min(1._r8,dum) + else + dum = 1._r8 + end if + + qitend(i,k)=qitend(i,k)+dum*dumc(i,k)/deltat + ! for output + homotot(i,k)=dum*dumc(i,k)/deltat + + ! assume 25 micron mean volume radius of homogeneously frozen droplets + ! consistent with size of detrained ice in stratiform.F90 + nitend(i,k)=nitend(i,k)+dum*3._r8*dumc(i,k)/(4._r8*3.14_r8*1.563e-14_r8* & + 500._r8)/deltat + qctend(i,k)=((1._r8-dum)*dumc(i,k)-qc(i,k))/deltat + nctend(i,k)=((1._r8-dum)*dumnc(i,k)-nc(i,k))/deltat + tlat(i,k)=tlat(i,k)+xlf*dum*dumc(i,k)/deltat + end if + end if + + ! remove any excess over-saturation, which is possible due to non-linearity when adding + ! together all microphysical processes + !----------------------------------------------------------------- + ! follow code similar to old CAM scheme + + qtmp=q(i,k)+qvlat(i,k)*deltat + ttmp=t(i,k)+tlat(i,k)/cpp*deltat + + ! use rhw to allow ice supersaturation + call qsat_water(ttmp, p(i,k), esn, qvn) + + if (qtmp > qvn .and. qvn > 0 .and. allow_sed_supersat) then + ! expression below is approximate since there may be ice deposition + dum = (qtmp-qvn)/(1._r8+xxlv_squared*qvn/(cpp*rv*ttmp**2))/deltat + ! add to output cme + cmeout(i,k) = cmeout(i,k)+dum + ! now add to tendencies, partition between liquid and ice based on temperature + if (ttmp > 268.15_r8) then + dum1=0.0_r8 + ! now add to tendencies, partition between liquid and ice based on te + !------------------------------------------------------- + else if (ttmp < 238.15_r8) then + dum1=1.0_r8 + else + dum1=(268.15_r8-ttmp)/30._r8 + end if + + dum = (qtmp-qvn)/(1._r8+(xxls*dum1+xxlv*(1._r8-dum1))**2 & + *qvn/(cpp*rv*ttmp**2))/deltat + qctend(i,k)=qctend(i,k)+dum*(1._r8-dum1) + ! for output + qcrestot(i,k)=dum*(1._r8-dum1) + qitend(i,k)=qitend(i,k)+dum*dum1 + qirestot(i,k)=dum*dum1 + qvlat(i,k)=qvlat(i,k)-dum + ! for output + qvres(i,k)=-dum + tlat(i,k)=tlat(i,k)+dum*(1._r8-dum1)*xxlv+dum*dum1*xxls + end if + end if + + ! calculate effective radius for pass to radiation code + !========================================================= + ! if no cloud water, default value is 10 micron for droplets, + ! 25 micron for cloud ice + + ! update cloud variables after instantaneous processes to get effective radius + ! variables are in-cloud to calculate size dist parameters + + dumc(i,k) = max(qc(i,k)+qctend(i,k)*deltat,0._r8)/lcldm(i,k) + dumi(i,k) = max(qi(i,k)+qitend(i,k)*deltat,0._r8)/icldm(i,k) + dumnc(i,k) = max(nc(i,k)+nctend(i,k)*deltat,0._r8)/lcldm(i,k) + dumni(i,k) = max(ni(i,k)+nitend(i,k)*deltat,0._r8)/icldm(i,k) + + dumr(i,k) = max(qr(i,k)+qrtend(i,k)*deltat,0._r8)/precip_frac(i,k) + dumnr(i,k) = max(nr(i,k)+nrtend(i,k)*deltat,0._r8)/precip_frac(i,k) + dums(i,k) = max(qs(i,k)+qstend(i,k)*deltat,0._r8)/precip_frac(i,k) + dumns(i,k) = max(ns(i,k)+nstend(i,k)*deltat,0._r8)/precip_frac(i,k) + + ! switch for specification of droplet and crystal number + if (nccons) then + dumnc(i,k)=ncnst/rho(i,k) + end if + + ! switch for specification of cloud ice number + if (nicons) then + dumni(i,k)=ninst/rho(i,k) + end if + + ! limit in-cloud mixing ratio to reasonable value of 5 g kg-1 + dumc(i,k)=min(dumc(i,k),5.e-3_r8) + dumi(i,k)=min(dumi(i,k),5.e-3_r8) + ! limit in-precip mixing ratios + dumr(i,k)=min(dumr(i,k),10.e-3_r8) + dums(i,k)=min(dums(i,k),10.e-3_r8) + + ! cloud ice effective radius + !----------------------------------------------------------------- + + if (do_cldice) then + if (dumi(i,k).ge.qsmall) then + + dum_2D(i,k) = dumni(i,k) + call size_dist_param_basic(mg_ice_props, dumi(i,k), dumni(i,k), & + lami(i,k)) + + if (dumni(i,k) /=dum_2D(i,k)) then + ! adjust number conc if needed to keep mean size in reasonable range + nitend(i,k)=(dumni(i,k)*icldm(i,k)-ni(i,k))/deltat + end if + + effi(i,k) = 1.5_r8/lami(i,k)*1.e6_r8 + + else + effi(i,k) = 25._r8 + end if + + ! ice effective diameter for david mitchell's optics + deffi(i,k)=effi(i,k)*rhoi/rhows*2._r8 + else + ! NOTE: If CARMA is doing the ice microphysics, then the ice effective + ! radius has already been determined from the size distribution. + effi(i,k) = re_ice(i,k) * 1.e6_r8 ! m -> um + deffi(i,k)=effi(i,k) * 2._r8 + end if + + ! cloud droplet effective radius + !----------------------------------------------------------------- + if (dumc(i,k).ge.qsmall) then + + + ! switch for specification of droplet and crystal number + if (nccons) then + ! make sure nc is consistence with the constant N by adjusting tendency, need + ! to multiply by cloud fraction + ! note that nctend may be further adjusted below if mean droplet size is + ! out of bounds + + nctend(i,k)=(ncnst/rho(i,k)*lcldm(i,k)-nc(i,k))/deltat + + end if + + dum = dumnc(i,k) + + call size_dist_param_liq(mg_liq_props, dumc(i,k), dumnc(i,k), rho(i,k), & + pgam(i,k), lamc(i,k)) + + if (dum /= dumnc(i,k)) then + ! adjust number conc if needed to keep mean size in reasonable range + nctend(i,k)=(dumnc(i,k)*lcldm(i,k)-nc(i,k))/deltat + end if + + effc(i,k) = (pgam(i,k)+3._r8)/lamc(i,k)/2._r8*1.e6_r8 + !assign output fields for shape here + lamcrad(i,k)=lamc(i,k) + pgamrad(i,k)=pgam(i,k) + + + ! recalculate effective radius for constant number, in order to separate + ! first and second indirect effects + !====================================== + ! assume constant number of 10^8 kg-1 + + dumnc(i,k)=1.e8_r8 + + ! Pass in "false" adjust flag to prevent number from being changed within + ! size distribution subroutine. + call size_dist_param_liq(mg_liq_props, dumc(i,k), dumnc(i,k), rho(i,k), & + pgam(i,k), lamc(i,k)) + + effc_fn(i,k) = (pgam(i,k)+3._r8)/lamc(i,k)/2._r8*1.e6_r8 + + else + effc(i,k) = 10._r8 + lamcrad(i,k)=0._r8 + pgamrad(i,k)=0._r8 + effc_fn(i,k) = 10._r8 + end if + + ! recalculate 'final' rain size distribution parameters + ! to ensure that rain size is in bounds, adjust rain number if needed + + if (dumr(i,k).ge.qsmall) then + + dum = dumnr(i,k) + + call size_dist_param_basic(mg_rain_props, dumr(i,k), dumnr(i,k), & + lamr(i,k)) + + if (dum /= dumnr(i,k)) then + ! adjust number conc if needed to keep mean size in reasonable range + nrtend(i,k)=(dumnr(i,k)*precip_frac(i,k)-nr(i,k))/deltat + end if + + end if + + ! recalculate 'final' snow size distribution parameters + ! to ensure that snow size is in bounds, adjust snow number if needed + + if (dums(i,k).ge.qsmall) then + + dum = dumns(i,k) + + call size_dist_param_basic(mg_snow_props, dums(i,k), dumns(i,k), & + lams(i,k)) + + if (dum /= dumns(i,k)) then + ! adjust number conc if needed to keep mean size in reasonable range + nstend(i,k)=(dumns(i,k)*precip_frac(i,k)-ns(i,k))/deltat + end if + + end if + + + end do ! vertical k loop + + do k=1,nlev + ! if updated q (after microphysics) is zero, then ensure updated n is also zero + !================================================================================= + if (qc(i,k)+qctend(i,k)*deltat.lt.qsmall) nctend(i,k)=-nc(i,k)/deltat + if (do_cldice .and. qi(i,k)+qitend(i,k)*deltat.lt.qsmall) nitend(i,k)=-ni(i,k)/deltat + if (qr(i,k)+qrtend(i,k)*deltat.lt.qsmall) nrtend(i,k)=-nr(i,k)/deltat + if (qs(i,k)+qstend(i,k)*deltat.lt.qsmall) nstend(i,k)=-ns(i,k)/deltat + + end do + + end do sed_col_loop! i loop + + ! DO STUFF FOR OUTPUT: + !================================================== + + ! qc and qi are only used for output calculations past here, + ! so add qctend and qitend back in one more time + qc = qc + qctend*deltat + qi = qi + qitend*deltat + + ! averaging for snow and rain number and diameter + !-------------------------------------------------- + + ! drout2/dsout2: + ! diameter of rain and snow + ! dsout: + ! scaled diameter of snow (passed to radiation in CAM) + ! reff_rain/reff_snow: + ! calculate effective radius of rain and snow in microns for COSP using Eq. 9 of COSP v1.3 manual + + where (qrout .gt. 1.e-7_r8 & + .and. nrout.gt.0._r8) + qrout2 = qrout * precip_frac + nrout2 = nrout * precip_frac + ! The avg_diameter call does the actual calculation; other diameter + ! outputs are just drout2 times constants. + drout2 = avg_diameter(qrout, nrout, rho, rhow) + freqr = precip_frac + + reff_rain=1.5_r8*drout2*1.e6_r8 + elsewhere + qrout2 = 0._r8 + nrout2 = 0._r8 + drout2 = 0._r8 + freqr = 0._r8 + reff_rain = 0._r8 + end where + + where (qsout .gt. 1.e-7_r8 & + .and. nsout.gt.0._r8) + qsout2 = qsout * precip_frac + nsout2 = nsout * precip_frac + ! The avg_diameter call does the actual calculation; other diameter + ! outputs are just dsout2 times constants. + dsout2 = avg_diameter(qsout, nsout, rho, rhosn) + freqs = precip_frac + + dsout=3._r8*rhosn/rhows*dsout2 + + reff_snow=1.5_r8*dsout2*1.e6_r8 + elsewhere + dsout = 0._r8 + qsout2 = 0._r8 + nsout2 = 0._r8 + dsout2 = 0._r8 + freqs = 0._r8 + reff_snow=0._r8 + end where + + ! analytic radar reflectivity + !-------------------------------------------------- + ! formulas from Matthew Shupe, NOAA/CERES + ! *****note: radar reflectivity is local (in-precip average) + ! units of mm^6/m^3 + + do i = 1,mgncol + do k=1,nlev + if (qc(i,k).ge.qsmall) then + dum=(qc(i,k)/lcldm(i,k)*rho(i,k)*1000._r8)**2 & + /(0.109_r8*(nc(i,k)+nctend(i,k)*deltat)/lcldm(i,k)*rho(i,k)/1.e6_r8)*lcldm(i,k)/precip_frac(i,k) + else + dum=0._r8 + end if + if (qi(i,k).ge.qsmall) then + dum1=(qi(i,k)*rho(i,k)/icldm(i,k)*1000._r8/0.1_r8)**(1._r8/0.63_r8)*icldm(i,k)/precip_frac(i,k) + else + dum1=0._r8 + end if + + if (qsout(i,k).ge.qsmall) then + dum1=dum1+(qsout(i,k)*rho(i,k)*1000._r8/0.1_r8)**(1._r8/0.63_r8) + end if + + refl(i,k)=dum+dum1 + + ! add rain rate, but for 37 GHz formulation instead of 94 GHz + ! formula approximated from data of Matrasov (2007) + ! rainrt is the rain rate in mm/hr + ! reflectivity (dum) is in DBz + + if (rainrt(i,k).ge.0.001_r8) then + dum=log10(rainrt(i,k)**6._r8)+16._r8 + + ! convert from DBz to mm^6/m^3 + + dum = 10._r8**(dum/10._r8) + else + ! don't include rain rate in R calculation for values less than 0.001 mm/hr + dum=0._r8 + end if + + ! add to refl + + refl(i,k)=refl(i,k)+dum + + !output reflectivity in Z. + areflz(i,k)=refl(i,k) * precip_frac(i,k) + + ! convert back to DBz + + if (refl(i,k).gt.minrefl) then + refl(i,k)=10._r8*log10(refl(i,k)) + else + refl(i,k)=-9999._r8 + end if + + !set averaging flag + if (refl(i,k).gt.mindbz) then + arefl(i,k)=refl(i,k) * precip_frac(i,k) + frefl(i,k)=precip_frac(i,k) + else + arefl(i,k)=0._r8 + areflz(i,k)=0._r8 + frefl(i,k)=0._r8 + end if + + ! bound cloudsat reflectivity + + csrfl(i,k)=min(csmax,refl(i,k)) + + !set averaging flag + if (csrfl(i,k).gt.csmin) then + acsrfl(i,k)=refl(i,k) * precip_frac(i,k) + fcsrfl(i,k)=precip_frac(i,k) + else + acsrfl(i,k)=0._r8 + fcsrfl(i,k)=0._r8 + end if + + end do + end do + + !redefine fice here.... + dum_2D = qsout + qrout + qc + qi + dumi = qsout + qi + where (dumi .gt. qsmall .and. dum_2D .gt. qsmall) + nfice=min(dumi/dum_2D,1._r8) + elsewhere + nfice=0._r8 + end where + +end subroutine micro_mg_tend + +!======================================================================== +!OUTPUT CALCULATIONS +!======================================================================== + +elemental subroutine calc_rercld(lamr, n0r, lamc, pgam, qric, qcic, ncic, & + rercld) + real(r8), intent(in) :: lamr ! rain size parameter (slope) + real(r8), intent(in) :: n0r ! rain size parameter (intercept) + real(r8), intent(in) :: lamc ! size distribution parameter (slope) + real(r8), intent(in) :: pgam ! droplet size parameter + real(r8), intent(in) :: qric ! in-cloud rain mass mixing ratio + real(r8), intent(in) :: qcic ! in-cloud cloud liquid + real(r8), intent(in) :: ncic ! in-cloud droplet number concentration + + real(r8), intent(inout) :: rercld ! effective radius calculation for rain + cloud + + ! combined size of precip & cloud drops + real(r8) :: Atmp + + ! Rain drops + if (lamr > 0._r8) then + Atmp = n0r * pi / (2._r8 * lamr**3._r8) + else + Atmp = 0._r8 + end if + + ! Add cloud drops + if (lamc > 0._r8) then + Atmp = Atmp + & + ncic * pi * rising_factorial(pgam+1._r8, 2)/(4._r8 * lamc**2._r8) + end if + + if (Atmp > 0._r8) then + rercld = rercld + 3._r8 *(qric + qcic) / (4._r8 * rhow * Atmp) + end if + +end subroutine calc_rercld + +!======================================================================== +!UTILITIES +!======================================================================== + +pure subroutine micro_mg_get_cols(ncol, nlev, top_lev, qcn, qin, & + qrn, qsn, mgncol, mgcols) + + ! Determines which columns microphysics should operate over by + ! checking for non-zero cloud water/ice. + + integer, intent(in) :: ncol ! Number of columns with meaningful data + integer, intent(in) :: nlev ! Number of levels to use + integer, intent(in) :: top_lev ! Top level for microphysics + + real(r8), intent(in) :: qcn(:,:) ! cloud water mixing ratio (kg/kg) + real(r8), intent(in) :: qin(:,:) ! cloud ice mixing ratio (kg/kg) + real(r8), intent(in) :: qrn(:,:) ! rain mixing ratio (kg/kg) + real(r8), intent(in) :: qsn(:,:) ! snow mixing ratio (kg/kg) + + integer, intent(out) :: mgncol ! Number of columns MG will use + integer, allocatable, intent(out) :: mgcols(:) ! column indices + + integer :: lev_offset ! top_lev - 1 (defined here for consistency) + logical :: ltrue(ncol) ! store tests for each column + + integer :: i, ii ! column indices + + if (allocated(mgcols)) deallocate(mgcols) + + lev_offset = top_lev - 1 + + ! Using "any" along dimension 2 collapses across levels, but + ! not columns, so we know if water is present at any level + ! in each column. + + ltrue = any(qcn(:ncol,top_lev:(nlev+lev_offset)) >= qsmall, 2) + ltrue = ltrue .or. any(qin(:ncol,top_lev:(nlev+lev_offset)) >= qsmall, 2) + ltrue = ltrue .or. any(qrn(:ncol,top_lev:(nlev+lev_offset)) >= qsmall, 2) + ltrue = ltrue .or. any(qsn(:ncol,top_lev:(nlev+lev_offset)) >= qsmall, 2) + + ! Scan for true values to get a usable list of indices. + + mgncol = count(ltrue) + allocate(mgcols(mgncol)) + i = 0 + do ii = 1,ncol + if (ltrue(ii)) then + i = i + 1 + mgcols(i) = ii + end if + end do + +end subroutine micro_mg_get_cols + +end module micro_mg2_0 diff --git a/models/atm/cam/src/physics/cam/micro_mg_cam.F90 b/models/atm/cam/src/physics/cam/micro_mg_cam.F90 index 9e70712f3355..2cfef4c255da 100644 --- a/models/atm/cam/src/physics/cam/micro_mg_cam.F90 +++ b/models/atm/cam/src/physics/cam/micro_mg_cam.F90 @@ -5,31 +5,92 @@ module micro_mg_cam ! CAM Interfaces for MG microphysics ! !--------------------------------------------------------------------------------- +! +! How to add new packed MG inputs to micro_mg_cam_tend: +! +! If you have an input with first dimension [psetcols, pver], the procedure +! for adding inputs is as follows: +! +! 1) In addition to any variables you need to declare for the "unpacked" +! (CAM format) version, you must declare an allocatable or pointer array +! for the "packed" (MG format) version. +! +! 2) After micro_mg_get_cols is called, allocate the "packed" array with +! size [mgncol, nlev]. +! +! 3) Add a call similar to the following line (look before the +! micro_mg_tend calls to see similar lines): +! +! packed_array = packer%pack(original_array) +! +! The packed array can then be passed into any of the MG schemes. +! +! This same procedure will also work for 1D arrays of size psetcols, 3-D +! arrays with psetcols and pver as the first dimensions, and for arrays of +! dimension [psetcols, pverp]. You only have to modify the allocation of +! the packed array before the "pack" call. +! +!--------------------------------------------------------------------------------- +! +! How to add new packed MG outputs to micro_mg_cam_tend: +! +! 1) As with inputs, in addition to the unpacked outputs you must declare +! an allocatable or pointer array for packed data. The unpacked and +! packed arrays must *also* be targets or pointers (but cannot be both). +! +! 2) Again as for inputs, allocate the packed array using mgncol and nlev, +! which are set in micro_mg_get_cols. +! +! 3) Add the field to post-processing as in the following line (again, +! there are many examples before the micro_mg_tend calls): +! +! call post_proc%add_field(p(final_array),p(packed_array)) +! +! This registers the field for post-MG averaging, and to scatter to the +! final, unpacked version of the array. +! +! By default, any columns/levels that are not operated on by MG will be +! set to 0 on output; this value can be adjusted using the "fillvalue" +! optional argument to post_proc%add_field. +! +! Also by default, outputs from multiple substeps will be averaged after +! MG's substepping is complete. Passing the optional argument +! "accum_method=accum_null" will change this behavior so that the last +! substep is always output. +! +! This procedure works on 1-D and 2-D outputs. Note that the final, +! unpacked arrays are not set until the call to +! "post_proc%process_and_unpack", which sets every single field that was +! added with post_proc%add_field. +! +!--------------------------------------------------------------------------------- use shr_kind_mod, only: r8=>shr_kind_r8 use spmd_utils, only: masterproc -use ppgrid, only: pver, pverp, psubcols +use ppgrid, only: pcols, pver, pverp, psubcols use physconst, only: gravit, rair, tmelt, cpair, rh2o, rhoh2o, & - latvap, latice, mwdry -use phys_control, only: phys_getopts + latvap, latice, mwh2o +use phys_control, only: phys_getopts, use_hetfrz_classnuc -use physics_types, only: physics_state, physics_ptend, physics_ptend_init, & - physics_state_copy, physics_ptend_copy, & - physics_update, physics_state_dealloc, & - physics_ptend_sum +use physics_types, only: physics_state, physics_ptend, & + physics_ptend_init, physics_state_copy, & + physics_update, physics_state_dealloc, & + physics_ptend_sum, physics_ptend_scale + use physics_buffer, only: physics_buffer_desc, pbuf_add_field, dyn_time_lvls, & - pbuf_old_tim_idx, pbuf_get_index, dtype_r8, dtype_i4, & - pbuf_get_field, pbuf_set_field, col_type_subcol, pbuf_register_subcol + pbuf_old_tim_idx, pbuf_get_index, dtype_r8, dtype_i4, & + pbuf_get_field, pbuf_set_field, col_type_subcol, & + pbuf_register_subcol use constituents, only: cnst_add, cnst_get_ind, & - cnst_name, cnst_longname, sflxnam, apcnst, bpcnst, pcnst + cnst_name, cnst_longname, sflxnam, apcnst, bpcnst, pcnst -use cldwat2m_macro, only: rhmini +use cldfrc2m, only: rhmini=>rhmini_const use cam_history, only: addfld, add_default, phys_decomp, outfld use cam_logfile, only: iulog -use cam_abortutils, only: endrun +use cam_abortutils, only: endrun use error_messages, only: handle_errmsg use ref_pres, only: top_lev=>trop_cloud_top_lev @@ -40,55 +101,76 @@ module micro_mg_cam save public :: & - micro_mg_cam_readnl, & - micro_mg_cam_register, & - micro_mg_cam_init_cnst, & - micro_mg_cam_implements_cnst, & - micro_mg_cam_init, & - micro_mg_cam_tend + micro_mg_cam_readnl, & + micro_mg_cam_register, & + micro_mg_cam_init_cnst, & + micro_mg_cam_implements_cnst, & + micro_mg_cam_init, & + micro_mg_cam_tend, & + micro_mg_version integer :: micro_mg_version = 1 ! Version number for MG. integer :: micro_mg_sub_version = 0 ! Second part of version number. +real(r8) :: micro_mg_dcs = -1._r8 + logical :: microp_uniform +character(len=16) :: micro_mg_precip_frac_method = 'max_overlap' ! type of precipitation fraction method + +real(r8) :: micro_mg_berg_eff_factor = 1.0_r8 ! berg efficiency factor + logical, public :: do_cldliq ! Prognose cldliq flag logical, public :: do_cldice ! Prognose cldice flag -real(r8) :: dcs !autoconversion size threshold for cloud ice to snow (m) -integer, parameter :: ncnst = 4 ! Number of constituents +integer :: num_steps ! Number of MG substeps + +integer :: ncnst = 4 ! Number of constituents + character(len=8), parameter :: & ! Constituent names - cnst_names(ncnst) = (/'CLDLIQ', 'CLDICE','NUMLIQ','NUMICE'/) + cnst_names(8) = (/'CLDLIQ', 'CLDICE','NUMLIQ','NUMICE', & + 'RAINQM', 'SNOWQM','NUMRAI','NUMSNO'/) integer :: & - ixcldliq, &! cloud liquid amount index - ixcldice, &! cloud ice amount index - ixnumliq, &! cloud liquid number index - ixnumice ! cloud ice water index + ixcldliq = -1, &! cloud liquid amount index + ixcldice = -1, &! cloud ice amount index + ixnumliq = -1, &! cloud liquid number index + ixnumice = -1, &! cloud ice water index + ixrain = -1, &! rain index + ixsnow = -1, &! snow index + ixnumrain = -1, &! rain number index + ixnumsnow = -1 ! snow number index ! Physics buffer indices for fields registered by this module integer :: & - cldo_idx, & - qme_idx, & - prain_idx, & - nevapr_idx, & - wsedl_idx, & - rei_idx, & - rel_idx, & - dei_idx, & - mu_idx, & - lambdac_idx, & - iciwpst_idx, & - iclwpst_idx, & - des_idx, & - icswp_idx, & - cldfsnow_idx, & - rate1_cw2pr_st_idx = -1, & - ls_flxprc_idx, & - ls_flxsnw_idx, & - relvar_idx, & - cmeliq_idx, & - accre_enhan_idx + cldo_idx, & + qme_idx, & + prain_idx, & + nevapr_idx, & + wsedl_idx, & + rei_idx, & + rel_idx, & + dei_idx, & + mu_idx, & + prer_evap_idx, & + lambdac_idx, & + iciwpst_idx, & + iclwpst_idx, & + des_idx, & + icswp_idx, & + cldfsnow_idx, & + rate1_cw2pr_st_idx = -1, & + ls_flxprc_idx, & + ls_flxsnw_idx, & + relvar_idx, & + cmeliq_idx, & + accre_enhan_idx + +! Fields for UNICON +integer :: & + am_evp_st_idx, &! Evaporation area of stratiform precipitation + evprain_st_idx, &! Evaporation rate of stratiform rain [kg/kg/s]. >= 0. + evpsnow_st_idx ! Evaporation rate of stratiform snow [kg/kg/s]. >= 0. ! Fields needed as inputs to COSP integer :: & @@ -105,36 +187,53 @@ module micro_mg_cam ! Used to replace aspects of MG microphysics ! (e.g. by CARMA) -integer :: tnd_qsnow_idx, tnd_nsnow_idx, re_ice_idx +integer :: & + tnd_qsnow_idx = -1, & + tnd_nsnow_idx = -1, & + re_ice_idx = -1 ! Index fields for precipitation efficiency. -integer :: acpr_idx, acgcme_idx, acnum_idx +integer :: & + acpr_idx = -1, & + acgcme_idx = -1, & + acnum_idx = -1 ! Physics buffer indices for fields registered by other modules integer :: & - ast_idx = -1, & - aist_idx = -1, & - alst_idx = -1, & - cld_idx = -1, & - concld_idx = -1 + ast_idx = -1, & + cld_idx = -1, & + concld_idx = -1 ! Pbuf fields needed for subcol_SILHS integer :: & - qrain_idx=-1, qsnow_idx=-1, & - nrain_idx=-1, nsnow_idx=-1 + qrain_idx=-1, qsnow_idx=-1, & + nrain_idx=-1, nsnow_idx=-1 integer :: & - naai_idx = -1, & - naai_hom_idx = -1, & - npccn_idx = -1, & - rndst_idx = -1, & - nacon_idx = -1, & - prec_str_idx = -1, & - snow_str_idx = -1, & - prec_pcw_idx = -1, & - snow_pcw_idx = -1, & - prec_sed_idx = -1, & - snow_sed_idx = -1 + naai_idx = -1, & + naai_hom_idx = -1, & + npccn_idx = -1, & + rndst_idx = -1, & + nacon_idx = -1, & + prec_str_idx = -1, & + snow_str_idx = -1, & + prec_pcw_idx = -1, & + snow_pcw_idx = -1, & + prec_sed_idx = -1, & + snow_sed_idx = -1 + +! pbuf fields for heterogeneous freezing +integer :: & + frzimm_idx = -1, & + frzcnt_idx = -1, & + frzdep_idx = -1 + + logical :: allow_sed_supersat ! allow supersaturated conditions after sedimentation loop + +interface p + module procedure p1 + module procedure p2 +end interface p !=============================================================================== @@ -150,17 +249,18 @@ subroutine micro_mg_cam_readnl(nlfile) character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input ! Namelist variables - logical :: micro_mg_do_cldice = .true. ! do_cldice = .true., MG microphysics is prognosing cldice - logical :: micro_mg_do_cldliq = .true. ! do_cldliq = .true., MG microphysics is prognosing cldliq - real(r8) :: micro_mg_dcs !autoconversion size threshold for cloud ice to snow (m) + logical :: micro_mg_do_cldice = .true. ! do_cldice = .true., MG microphysics is prognosing cldice + logical :: micro_mg_do_cldliq = .true. ! do_cldliq = .true., MG microphysics is prognosing cldliq + integer :: micro_mg_num_steps = 1 ! Number of substepping iterations done by MG (1.5 only for now). + ! Local variables integer :: unitn, ierr character(len=*), parameter :: subname = 'micro_mg_cam_readnl' namelist /micro_mg_nl/ micro_mg_version, micro_mg_sub_version, & - micro_mg_do_cldice, micro_mg_do_cldliq, microp_uniform, & - micro_mg_dcs + micro_mg_do_cldice, micro_mg_do_cldliq, micro_mg_num_steps, & + microp_uniform, micro_mg_dcs, micro_mg_precip_frac_method, micro_mg_berg_eff_factor !----------------------------------------------------------------------------- @@ -178,9 +278,9 @@ subroutine micro_mg_cam_readnl(nlfile) call freeunit(unitn) ! set local variables - do_cldice = micro_mg_do_cldice - do_cldliq = micro_mg_do_cldliq - dcs = micro_mg_dcs + do_cldice = micro_mg_do_cldice + do_cldliq = micro_mg_do_cldliq + num_steps = micro_mg_num_steps ! Verify that version numbers are valid. select case (micro_mg_version) @@ -193,20 +293,33 @@ subroutine micro_mg_cam_readnl(nlfile) case default call bad_version_endrun() end select + case (2) + select case (micro_mg_sub_version) + case(0) + ! MG version 2.0 + case default + call bad_version_endrun() + end select case default call bad_version_endrun() end select + if (micro_mg_dcs < 0._r8) call endrun( "micro_mg_cam_readnl: & + µ_mg_dcs has not been set to a valid value.") end if #ifdef SPMD ! Broadcast namelist variables - call mpibcast(micro_mg_version, 1, mpiint, 0, mpicom) - call mpibcast(micro_mg_sub_version, 1, mpiint, 0, mpicom) - call mpibcast(do_cldice, 1, mpilog, 0, mpicom) - call mpibcast(do_cldliq, 1, mpilog, 0, mpicom) - call mpibcast(microp_uniform, 1, mpilog, 0, mpicom) - call mpibcast(dcs, 1, mpir8, 0, mpicom) + call mpibcast(micro_mg_version, 1, mpiint, 0, mpicom) + call mpibcast(micro_mg_sub_version, 1, mpiint, 0, mpicom) + call mpibcast(do_cldice, 1, mpilog, 0, mpicom) + call mpibcast(do_cldliq, 1, mpilog, 0, mpicom) + call mpibcast(num_steps, 1, mpiint, 0, mpicom) + call mpibcast(microp_uniform, 1, mpilog, 0, mpicom) + call mpibcast(micro_mg_dcs, 1, mpir8, 0, mpicom) + call mpibcast(micro_mg_berg_eff_factor, 1, mpir8, 0, mpicom) + call mpibcast(micro_mg_precip_frac_method, 16, mpichar,0, mpicom) + #endif contains @@ -225,174 +338,198 @@ end subroutine micro_mg_cam_readnl subroutine micro_mg_cam_register - ! Register microphysics constituents and fields in the physics buffer. - !----------------------------------------------------------------------- - - use ppgrid, only: pcols - - logical :: prog_modal_aero - logical :: use_subcol_microp ! If true, then are using subcolumns in microphysics - logical :: save_subcol_microp ! If true, then need to store sub-columnized fields in pbuf - - call phys_getopts(use_subcol_microp_out = use_subcol_microp, & - prog_modal_aero_out = prog_modal_aero ) - - ! Register microphysics constituents and save indices. - - call cnst_add(cnst_names(1), mwdry, cpair, 0._r8, ixcldliq, & - longname='Grid box averaged cloud liquid amount', is_convtran1=.true.) - call cnst_add(cnst_names(2), mwdry, cpair, 0._r8, ixcldice, & - longname='Grid box averaged cloud ice amount', is_convtran1=.true.) - ! The next statements should have "is_convtran1=.true.", but this would change - ! answers. - call cnst_add(cnst_names(3), mwdry, cpair, 0._r8, ixnumliq, & - longname='Grid box averaged cloud liquid number', is_convtran1=.false.) - call cnst_add(cnst_names(4), mwdry, cpair, 0._r8, ixnumice, & - longname='Grid box averaged cloud ice number', is_convtran1=.false.) - - ! Request physics buffer space for fields that persist across timesteps. - - call pbuf_add_field('CLDO','global',dtype_r8,(/pcols,pver,dyn_time_lvls/), cldo_idx) - - ! Physics buffer variables for convective cloud properties. - - call pbuf_add_field('QME', 'physpkg',dtype_r8,(/pcols,pver/), qme_idx) - call pbuf_add_field('PRAIN', 'physpkg',dtype_r8,(/pcols,pver/), prain_idx) - call pbuf_add_field('NEVAPR', 'physpkg',dtype_r8,(/pcols,pver/), nevapr_idx) - - call pbuf_add_field('WSEDL', 'physpkg',dtype_r8,(/pcols,pver/), wsedl_idx) - - call pbuf_add_field('REI', 'physpkg',dtype_r8,(/pcols,pver/), rei_idx) - call pbuf_add_field('REL', 'physpkg',dtype_r8,(/pcols,pver/), rel_idx) - - ! Mitchell ice effective diameter for radiation - call pbuf_add_field('DEI', 'physpkg',dtype_r8,(/pcols,pver/), dei_idx) - ! Size distribution shape parameter for radiation - call pbuf_add_field('MU', 'physpkg',dtype_r8,(/pcols,pver/), mu_idx) - ! Size distribution shape parameter for radiation - call pbuf_add_field('LAMBDAC', 'physpkg',dtype_r8,(/pcols,pver/), lambdac_idx) - - ! Stratiform only in cloud ice water path for radiation - call pbuf_add_field('ICIWPST', 'physpkg',dtype_r8,(/pcols,pver/), iciwpst_idx) - ! Stratiform in cloud liquid water path for radiation - call pbuf_add_field('ICLWPST', 'physpkg',dtype_r8,(/pcols,pver/), iclwpst_idx) - - ! Snow effective diameter for radiation - call pbuf_add_field('DES', 'physpkg',dtype_r8,(/pcols,pver/), des_idx) - ! In cloud snow water path for radiation - call pbuf_add_field('ICSWP', 'physpkg',dtype_r8,(/pcols,pver/), icswp_idx) - ! Cloud fraction for liquid drops + snow - call pbuf_add_field('CLDFSNOW ', 'physpkg',dtype_r8,(/pcols,pver,dyn_time_lvls/), cldfsnow_idx) - - if (prog_modal_aero) then - call pbuf_add_field('RATE1_CW2PR_ST','physpkg',dtype_r8,(/pcols,pver/), rate1_cw2pr_st_idx) - endif - - call pbuf_add_field('LS_FLXPRC', 'physpkg',dtype_r8,(/pcols,pverp/), ls_flxprc_idx) - call pbuf_add_field('LS_FLXSNW', 'physpkg',dtype_r8,(/pcols,pverp/), ls_flxsnw_idx) - - - ! Fields needed as inputs to COSP - call pbuf_add_field('LS_MRPRC', 'physpkg',dtype_r8,(/pcols,pver/), ls_mrprc_idx) - call pbuf_add_field('LS_MRSNW', 'physpkg',dtype_r8,(/pcols,pver/), ls_mrsnw_idx) - call pbuf_add_field('LS_REFFRAIN','physpkg',dtype_r8,(/pcols,pver/), ls_reffrain_idx) - call pbuf_add_field('LS_REFFSNOW','physpkg',dtype_r8,(/pcols,pver/), ls_reffsnow_idx) - call pbuf_add_field('CV_REFFLIQ', 'physpkg',dtype_r8,(/pcols,pver/), cv_reffliq_idx) - call pbuf_add_field('CV_REFFICE', 'physpkg',dtype_r8,(/pcols,pver/), cv_reffice_idx) - - ! CC_* Fields needed by Park macrophysics - call pbuf_add_field('CC_T', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_t_idx) - call pbuf_add_field('CC_qv', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_qv_idx) - call pbuf_add_field('CC_ql', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_ql_idx) - call pbuf_add_field('CC_qi', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_qi_idx) - call pbuf_add_field('CC_nl', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_nl_idx) - call pbuf_add_field('CC_ni', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_ni_idx) - call pbuf_add_field('CC_qlst', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_qlst_idx) - - ! Register subcolumn pbuf fields - if (use_subcol_microp) then - ! Global pbuf fields - call pbuf_register_subcol('CLDO', 'micro_mg_cam_register', cldo_idx) - - ! CC_* Fields needed by Park macrophysics - call pbuf_register_subcol('CC_T', 'micro_mg_cam_register', cc_t_idx) - call pbuf_register_subcol('CC_qv', 'micro_mg_cam_register', cc_qv_idx) - call pbuf_register_subcol('CC_ql', 'micro_mg_cam_register', cc_ql_idx) - call pbuf_register_subcol('CC_qi', 'micro_mg_cam_register', cc_qi_idx) - call pbuf_register_subcol('CC_nl', 'micro_mg_cam_register', cc_nl_idx) - call pbuf_register_subcol('CC_ni', 'micro_mg_cam_register', cc_ni_idx) - call pbuf_register_subcol('CC_qlst', 'micro_mg_cam_register', cc_qlst_idx) - - ! Physpkg pbuf fields - ! Physics buffer variables for convective cloud properties. - - call pbuf_register_subcol('QME', 'micro_mg_cam_register', qme_idx) - call pbuf_register_subcol('PRAIN', 'micro_mg_cam_register', prain_idx) - call pbuf_register_subcol('NEVAPR', 'micro_mg_cam_register', nevapr_idx) - - call pbuf_register_subcol('WSEDL', 'micro_mg_cam_register', wsedl_idx) - - call pbuf_register_subcol('REI', 'micro_mg_cam_register', rei_idx) - call pbuf_register_subcol('REL', 'micro_mg_cam_register', rel_idx) - - ! Mitchell ice effective diameter for radiation - call pbuf_register_subcol('DEI', 'micro_mg_cam_register', dei_idx) - ! Size distribution shape parameter for radiation - call pbuf_register_subcol('MU', 'micro_mg_cam_register', mu_idx) - ! Size distribution shape parameter for radiation - call pbuf_register_subcol('LAMBDAC', 'micro_mg_cam_register', lambdac_idx) - - ! Stratiform only in cloud ice water path for radiation - call pbuf_register_subcol('ICIWPST', 'micro_mg_cam_register', iciwpst_idx) - ! Stratiform in cloud liquid water path for radiation - call pbuf_register_subcol('ICLWPST', 'micro_mg_cam_register', iclwpst_idx) - - ! Snow effective diameter for radiation - call pbuf_register_subcol('DES', 'micro_mg_cam_register', des_idx) - ! In cloud snow water path for radiation - call pbuf_register_subcol('ICSWP', 'micro_mg_cam_register', icswp_idx) - ! Cloud fraction for liquid drops + snow - call pbuf_register_subcol('CLDFSNOW ', 'micro_mg_cam_register', cldfsnow_idx) - - if (prog_modal_aero) then - call pbuf_register_subcol('RATE1_CW2PR_ST', 'micro_mg_cam_register', rate1_cw2pr_st_idx) - end if - - call pbuf_register_subcol('LS_FLXPRC', 'micro_mg_cam_register', ls_flxprc_idx) - call pbuf_register_subcol('LS_FLXSNW', 'micro_mg_cam_register', ls_flxsnw_idx) - - ! Fields needed as inputs to COSP - call pbuf_register_subcol('LS_MRPRC', 'micro_mg_cam_register', ls_mrprc_idx) - call pbuf_register_subcol('LS_MRSNW', 'micro_mg_cam_register', ls_mrsnw_idx) - call pbuf_register_subcol('LS_REFFRAIN', 'micro_mg_cam_register', ls_reffrain_idx) - call pbuf_register_subcol('LS_REFFSNOW', 'micro_mg_cam_register', ls_reffsnow_idx) - call pbuf_register_subcol('CV_REFFLIQ', 'micro_mg_cam_register', cv_reffliq_idx) - call pbuf_register_subcol('CV_REFFICE', 'micro_mg_cam_register', cv_reffice_idx) - end if - - ! Additional pbuf for CARMA interface - call pbuf_add_field('TND_QSNOW', 'physpkg',dtype_r8,(/pcols,pver/), tnd_qsnow_idx) - call pbuf_add_field('TND_NSNOW', 'physpkg',dtype_r8,(/pcols,pver/), tnd_nsnow_idx) - call pbuf_add_field('RE_ICE', 'physpkg',dtype_r8,(/pcols,pver/), re_ice_idx) - - ! Precipitation efficiency fields across timesteps. - call pbuf_add_field('ACPRECL', 'global',dtype_r8,(/pcols/), acpr_idx) ! accumulated precip - call pbuf_add_field('ACGCME', 'global',dtype_r8,(/pcols/), acgcme_idx) ! accumulated condensation - call pbuf_add_field('ACNUM', 'global',dtype_i4,(/pcols/), acnum_idx) ! counter for accumulated # timesteps - - ! SGS variability -- These could be reset by CLUBB so they need to be grid only - call pbuf_add_field('RELVAR', 'global',dtype_r8,(/pcols,pver/), relvar_idx) - call pbuf_add_field('ACCRE_ENHAN','global',dtype_r8,(/pcols,pver/), accre_enhan_idx) - - ! Diagnostic fields needed for subcol_SILHS, need to be grid-only - if (subcol_get_scheme() == 'SILHS') then - call pbuf_add_field('QRAIN', 'global',dtype_r8,(/pcols,pver/), qrain_idx) - call pbuf_add_field('QSNOW', 'global',dtype_r8,(/pcols,pver/), qsnow_idx) - call pbuf_add_field('NRAIN', 'global',dtype_r8,(/pcols,pver/), nrain_idx) - call pbuf_add_field('NSNOW', 'global',dtype_r8,(/pcols,pver/), nsnow_idx) - end if - - + ! Register microphysics constituents and fields in the physics buffer. + !----------------------------------------------------------------------- + + logical :: prog_modal_aero + logical :: use_subcol_microp ! If true, then are using subcolumns in microphysics + + call phys_getopts(use_subcol_microp_out = use_subcol_microp, & + prog_modal_aero_out = prog_modal_aero) + + ! Register microphysics constituents and save indices. + + call cnst_add(cnst_names(1), mwh2o, cpair, 0._r8, ixcldliq, & + longname='Grid box averaged cloud liquid amount', is_convtran1=.true.) + call cnst_add(cnst_names(2), mwh2o, cpair, 0._r8, ixcldice, & + longname='Grid box averaged cloud ice amount', is_convtran1=.true.) + + ! The next statements should have "is_convtran1=.true.", but this would change + ! answers for MG 1.0. Thus make an exception for that version only. + if (micro_mg_version == 1 .and. micro_mg_sub_version == 0) then + call cnst_add(cnst_names(3), mwh2o, cpair, 0._r8, ixnumliq, & + longname='Grid box averaged cloud liquid number', is_convtran1=.false.) + call cnst_add(cnst_names(4), mwh2o, cpair, 0._r8, ixnumice, & + longname='Grid box averaged cloud ice number', is_convtran1=.false.) + else + call cnst_add(cnst_names(3), mwh2o, cpair, 0._r8, ixnumliq, & + longname='Grid box averaged cloud liquid number', is_convtran1=.true.) + call cnst_add(cnst_names(4), mwh2o, cpair, 0._r8, ixnumice, & + longname='Grid box averaged cloud ice number', is_convtran1=.true.) + end if + + ! Note is_convtran1 is set to .true. + if (micro_mg_version > 1) then + call cnst_add(cnst_names(5), mwh2o, cpair, 0._r8, ixrain, & + longname='Grid box averaged rain amount', is_convtran1=.true.) + call cnst_add(cnst_names(6), mwh2o, cpair, 0._r8, ixsnow, & + longname='Grid box averaged snow amount', is_convtran1=.true.) + call cnst_add(cnst_names(7), mwh2o, cpair, 0._r8, ixnumrain, & + longname='Grid box averaged rain number', is_convtran1=.true.) + call cnst_add(cnst_names(8), mwh2o, cpair, 0._r8, ixnumsnow, & + longname='Grid box averaged snow number', is_convtran1=.true.) + end if + + ! Request physics buffer space for fields that persist across timesteps. + + call pbuf_add_field('CLDO','global',dtype_r8,(/pcols,pver,dyn_time_lvls/), cldo_idx) + + ! Physics buffer variables for convective cloud properties. + + call pbuf_add_field('QME', 'physpkg',dtype_r8,(/pcols,pver/), qme_idx) + call pbuf_add_field('PRAIN', 'physpkg',dtype_r8,(/pcols,pver/), prain_idx) + call pbuf_add_field('NEVAPR', 'physpkg',dtype_r8,(/pcols,pver/), nevapr_idx) + call pbuf_add_field('PRER_EVAP', 'global', dtype_r8,(/pcols,pver/), prer_evap_idx) + + call pbuf_add_field('WSEDL', 'physpkg',dtype_r8,(/pcols,pver/), wsedl_idx) + + call pbuf_add_field('REI', 'physpkg',dtype_r8,(/pcols,pver/), rei_idx) + call pbuf_add_field('REL', 'physpkg',dtype_r8,(/pcols,pver/), rel_idx) + + ! Mitchell ice effective diameter for radiation + call pbuf_add_field('DEI', 'physpkg',dtype_r8,(/pcols,pver/), dei_idx) + ! Size distribution shape parameter for radiation + call pbuf_add_field('MU', 'physpkg',dtype_r8,(/pcols,pver/), mu_idx) + ! Size distribution shape parameter for radiation + call pbuf_add_field('LAMBDAC', 'physpkg',dtype_r8,(/pcols,pver/), lambdac_idx) + + ! Stratiform only in cloud ice water path for radiation + call pbuf_add_field('ICIWPST', 'physpkg',dtype_r8,(/pcols,pver/), iciwpst_idx) + ! Stratiform in cloud liquid water path for radiation + call pbuf_add_field('ICLWPST', 'physpkg',dtype_r8,(/pcols,pver/), iclwpst_idx) + + ! Snow effective diameter for radiation + call pbuf_add_field('DES', 'physpkg',dtype_r8,(/pcols,pver/), des_idx) + ! In cloud snow water path for radiation + call pbuf_add_field('ICSWP', 'physpkg',dtype_r8,(/pcols,pver/), icswp_idx) + ! Cloud fraction for liquid drops + snow + call pbuf_add_field('CLDFSNOW ', 'physpkg',dtype_r8,(/pcols,pver,dyn_time_lvls/), cldfsnow_idx) + + if (prog_modal_aero) then + call pbuf_add_field('RATE1_CW2PR_ST','physpkg',dtype_r8,(/pcols,pver/), rate1_cw2pr_st_idx) + endif + + call pbuf_add_field('LS_FLXPRC', 'physpkg',dtype_r8,(/pcols,pverp/), ls_flxprc_idx) + call pbuf_add_field('LS_FLXSNW', 'physpkg',dtype_r8,(/pcols,pverp/), ls_flxsnw_idx) + + + ! Fields needed as inputs to COSP + call pbuf_add_field('LS_MRPRC', 'physpkg',dtype_r8,(/pcols,pver/), ls_mrprc_idx) + call pbuf_add_field('LS_MRSNW', 'physpkg',dtype_r8,(/pcols,pver/), ls_mrsnw_idx) + call pbuf_add_field('LS_REFFRAIN','physpkg',dtype_r8,(/pcols,pver/), ls_reffrain_idx) + call pbuf_add_field('LS_REFFSNOW','physpkg',dtype_r8,(/pcols,pver/), ls_reffsnow_idx) + call pbuf_add_field('CV_REFFLIQ', 'physpkg',dtype_r8,(/pcols,pver/), cv_reffliq_idx) + call pbuf_add_field('CV_REFFICE', 'physpkg',dtype_r8,(/pcols,pver/), cv_reffice_idx) + + ! CC_* Fields needed by Park macrophysics + call pbuf_add_field('CC_T', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_t_idx) + call pbuf_add_field('CC_qv', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_qv_idx) + call pbuf_add_field('CC_ql', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_ql_idx) + call pbuf_add_field('CC_qi', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_qi_idx) + call pbuf_add_field('CC_nl', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_nl_idx) + call pbuf_add_field('CC_ni', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_ni_idx) + call pbuf_add_field('CC_qlst', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_qlst_idx) + + ! Fields for UNICON + call pbuf_add_field('am_evp_st', 'global', dtype_r8, (/pcols,pver/), am_evp_st_idx) + call pbuf_add_field('evprain_st', 'global', dtype_r8, (/pcols,pver/), evprain_st_idx) + call pbuf_add_field('evpsnow_st', 'global', dtype_r8, (/pcols,pver/), evpsnow_st_idx) + + ! Register subcolumn pbuf fields + if (use_subcol_microp) then + ! Global pbuf fields + call pbuf_register_subcol('CLDO', 'micro_mg_cam_register', cldo_idx) + + ! CC_* Fields needed by Park macrophysics + call pbuf_register_subcol('CC_T', 'micro_mg_cam_register', cc_t_idx) + call pbuf_register_subcol('CC_qv', 'micro_mg_cam_register', cc_qv_idx) + call pbuf_register_subcol('CC_ql', 'micro_mg_cam_register', cc_ql_idx) + call pbuf_register_subcol('CC_qi', 'micro_mg_cam_register', cc_qi_idx) + call pbuf_register_subcol('CC_nl', 'micro_mg_cam_register', cc_nl_idx) + call pbuf_register_subcol('CC_ni', 'micro_mg_cam_register', cc_ni_idx) + call pbuf_register_subcol('CC_qlst', 'micro_mg_cam_register', cc_qlst_idx) + + ! Physpkg pbuf fields + ! Physics buffer variables for convective cloud properties. + + call pbuf_register_subcol('QME', 'micro_mg_cam_register', qme_idx) + call pbuf_register_subcol('PRAIN', 'micro_mg_cam_register', prain_idx) + call pbuf_register_subcol('NEVAPR', 'micro_mg_cam_register', nevapr_idx) + call pbuf_register_subcol('PRER_EVAP', 'micro_mg_cam_register', prer_evap_idx) + + call pbuf_register_subcol('WSEDL', 'micro_mg_cam_register', wsedl_idx) + + call pbuf_register_subcol('REI', 'micro_mg_cam_register', rei_idx) + call pbuf_register_subcol('REL', 'micro_mg_cam_register', rel_idx) + + ! Mitchell ice effective diameter for radiation + call pbuf_register_subcol('DEI', 'micro_mg_cam_register', dei_idx) + ! Size distribution shape parameter for radiation + call pbuf_register_subcol('MU', 'micro_mg_cam_register', mu_idx) + ! Size distribution shape parameter for radiation + call pbuf_register_subcol('LAMBDAC', 'micro_mg_cam_register', lambdac_idx) + + ! Stratiform only in cloud ice water path for radiation + call pbuf_register_subcol('ICIWPST', 'micro_mg_cam_register', iciwpst_idx) + ! Stratiform in cloud liquid water path for radiation + call pbuf_register_subcol('ICLWPST', 'micro_mg_cam_register', iclwpst_idx) + + ! Snow effective diameter for radiation + call pbuf_register_subcol('DES', 'micro_mg_cam_register', des_idx) + ! In cloud snow water path for radiation + call pbuf_register_subcol('ICSWP', 'micro_mg_cam_register', icswp_idx) + ! Cloud fraction for liquid drops + snow + call pbuf_register_subcol('CLDFSNOW ', 'micro_mg_cam_register', cldfsnow_idx) + + if (prog_modal_aero) then + call pbuf_register_subcol('RATE1_CW2PR_ST', 'micro_mg_cam_register', rate1_cw2pr_st_idx) + end if + + call pbuf_register_subcol('LS_FLXPRC', 'micro_mg_cam_register', ls_flxprc_idx) + call pbuf_register_subcol('LS_FLXSNW', 'micro_mg_cam_register', ls_flxsnw_idx) + + ! Fields needed as inputs to COSP + call pbuf_register_subcol('LS_MRPRC', 'micro_mg_cam_register', ls_mrprc_idx) + call pbuf_register_subcol('LS_MRSNW', 'micro_mg_cam_register', ls_mrsnw_idx) + call pbuf_register_subcol('LS_REFFRAIN', 'micro_mg_cam_register', ls_reffrain_idx) + call pbuf_register_subcol('LS_REFFSNOW', 'micro_mg_cam_register', ls_reffsnow_idx) + call pbuf_register_subcol('CV_REFFLIQ', 'micro_mg_cam_register', cv_reffliq_idx) + call pbuf_register_subcol('CV_REFFICE', 'micro_mg_cam_register', cv_reffice_idx) + end if + + ! Additional pbuf for CARMA interface + if (.not. do_cldice) then + call pbuf_add_field('TND_QSNOW', 'physpkg',dtype_r8,(/pcols,pver/), tnd_qsnow_idx) + call pbuf_add_field('TND_NSNOW', 'physpkg',dtype_r8,(/pcols,pver/), tnd_nsnow_idx) + call pbuf_add_field('RE_ICE', 'physpkg',dtype_r8,(/pcols,pver/), re_ice_idx) + end if + + ! Precipitation efficiency fields across timesteps. + call pbuf_add_field('ACPRECL', 'global',dtype_r8,(/pcols/), acpr_idx) ! accumulated precip + call pbuf_add_field('ACGCME', 'global',dtype_r8,(/pcols/), acgcme_idx) ! accumulated condensation + call pbuf_add_field('ACNUM', 'global',dtype_i4,(/pcols/), acnum_idx) ! counter for accumulated # timesteps + + ! SGS variability -- These could be reset by CLUBB so they need to be grid only + call pbuf_add_field('RELVAR', 'global',dtype_r8,(/pcols,pver/), relvar_idx) + call pbuf_add_field('ACCRE_ENHAN','global',dtype_r8,(/pcols,pver/), accre_enhan_idx) + + ! Diagnostic fields needed for subcol_SILHS, need to be grid-only + if (subcol_get_scheme() == 'SILHS') then + call pbuf_add_field('QRAIN', 'global',dtype_r8,(/pcols,pver/), qrain_idx) + call pbuf_add_field('QSNOW', 'global',dtype_r8,(/pcols,pver/), qsnow_idx) + call pbuf_add_field('NRAIN', 'global',dtype_r8,(/pcols,pver/), nrain_idx) + call pbuf_add_field('NSNOW', 'global',dtype_r8,(/pcols,pver/), nsnow_idx) + end if end subroutine micro_mg_cam_register @@ -400,17 +537,15 @@ end subroutine micro_mg_cam_register function micro_mg_cam_implements_cnst(name) - ! Return true if specified constituent is implemented by the - ! microphysics package + ! Return true if specified constituent is implemented by the + ! microphysics package - character(len=*), intent(in) :: name ! constituent name - logical :: micro_mg_cam_implements_cnst ! return value + character(len=*), intent(in) :: name ! constituent name + logical :: micro_mg_cam_implements_cnst ! return value - ! Local workspace - integer :: m - !----------------------------------------------------------------------- + !----------------------------------------------------------------------- - micro_mg_cam_implements_cnst = any(name == cnst_names) + micro_mg_cam_implements_cnst = any(name == cnst_names) end function micro_mg_cam_implements_cnst @@ -418,1694 +553,2428 @@ end function micro_mg_cam_implements_cnst subroutine micro_mg_cam_init_cnst(name, q, gcid) - ! Initialize the microphysics constituents, if they are - ! not read from the initial file. + ! Initialize the microphysics constituents, if they are + ! not read from the initial file. - character(len=*), intent(in) :: name ! constituent name - real(r8), intent(out) :: q(:,:) ! mass mixing ratio (gcol, plev) - integer, intent(in) :: gcid(:) ! global column id - !----------------------------------------------------------------------- + character(len=*), intent(in) :: name ! constituent name + real(r8), intent(out) :: q(:,:) ! mass mixing ratio (gcol, plev) + integer, intent(in) :: gcid(:) ! global column id + !----------------------------------------------------------------------- - if (micro_mg_cam_implements_cnst(name)) q = 0.0_r8 + if (micro_mg_cam_implements_cnst(name)) q = 0.0_r8 end subroutine micro_mg_cam_init_cnst !=============================================================================== subroutine micro_mg_cam_init(pbuf2d) - use time_manager, only: is_first_step - use micro_mg_utils, only: micro_mg_utils_init - use micro_mg1_0, only: micro_mg_init1_0 => micro_mg_init - use micro_mg1_5, only: micro_mg_init1_5 => micro_mg_init - - !----------------------------------------------------------------------- - ! - ! Initialization for MG microphysics - ! - !----------------------------------------------------------------------- - - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - - integer :: m, mm - logical :: history_amwg ! output the variables used by the AMWG diag package - logical :: history_budget ! Output tendencies and state variables for CAM4 - ! temperature, water vapor, cloud ice and cloud - ! liquid budgets. - logical :: use_subcol_microp - integer :: budget_histfile ! output history file number for budget fields - integer :: ierr - - character(128) :: errstring ! return status (non-blank for error return) - - !----------------------------------------------------------------------- - - call phys_getopts(use_subcol_microp_out = use_subcol_microp) - - if (masterproc) then - write(iulog,"(A,I2,A,I2)") "Initializing MG version ",micro_mg_version,".",micro_mg_sub_version - if (.not. do_cldliq) & - write(iulog,*) "MG prognostic cloud liquid has been turned off via namelist." - if (.not. do_cldice) & - write(iulog,*) "MG prognostic cloud ice has been turned off via namelist." - end if - - select case (micro_mg_version) - case (1) - ! MG 1 does not initialize micro_mg_utils, so have to do it here. - call micro_mg_utils_init(r8, rh2o, cpair, tmelt, latvap, latice, & - errstring, dcs) - call handle_errmsg(errstring, subname="micro_mg_utils_init") - - select case (micro_mg_sub_version) - case (0) - call micro_mg_init1_0( & - r8, gravit, rair, rh2o, cpair, & - rhoh2o, tmelt, latvap, latice, & - rhmini, errstring, dcs) - case (5) - call micro_mg_init1_5( & - r8, gravit, rair, rh2o, cpair, & - tmelt, latvap, latice, rhmini, & - microp_uniform, do_cldice, errstring, dcs) - end select - end select - - call handle_errmsg(errstring, subname="micro_mg_init") - - ! Register history variables - do m = 1, ncnst - call cnst_get_ind(cnst_names(m), mm) - if ( any(mm == (/ ixcldliq, ixcldice /)) ) then - ! mass mixing ratios - call addfld(cnst_name(mm), 'kg/kg ', pver, 'A', cnst_longname(mm) , phys_decomp) - call addfld(sflxnam(mm), 'kg/m2/s ', 1, 'A', trim(cnst_name(mm))//' surface flux', phys_decomp) - else if ( any(mm == (/ ixnumliq, ixnumice /)) ) then - ! number concentrations - call addfld(cnst_name(mm), '1/kg ', pver, 'A', cnst_longname(mm) , phys_decomp) - call addfld(sflxnam(mm), '1/m2/s ', 1, 'A', trim(cnst_name(mm))//' surface flux', phys_decomp) - else - call endrun( "micro_mg_cam_init: & - &Could not call addfld for constituent with unknown units.") - endif - end do - - call addfld(apcnst(ixcldliq), 'kg/kg ', pver, 'A', trim(cnst_name(ixcldliq))//' after physics' , phys_decomp) - call addfld(apcnst(ixcldice), 'kg/kg ', pver, 'A', trim(cnst_name(ixcldice))//' after physics' , phys_decomp) - call addfld(bpcnst(ixcldliq), 'kg/kg ', pver, 'A', trim(cnst_name(ixcldliq))//' before physics' , phys_decomp) - call addfld(bpcnst(ixcldice), 'kg/kg ', pver, 'A', trim(cnst_name(ixcldice))//' before physics' , phys_decomp) - - call addfld ('CME ', 'kg/kg/s ', pver, 'A', 'Rate of cond-evap within the cloud' ,phys_decomp) - call addfld ('PRODPREC ', 'kg/kg/s ', pver, 'A', 'Rate of conversion of condensate to precip' ,phys_decomp) - call addfld ('EVAPPREC ', 'kg/kg/s ', pver, 'A', 'Rate of evaporation of falling precip' ,phys_decomp) - call addfld ('EVAPSNOW ', 'kg/kg/s ', pver, 'A', 'Rate of evaporation of falling snow' ,phys_decomp) - call addfld ('HPROGCLD ', 'W/kg' , pver, 'A', 'Heating from prognostic clouds' ,phys_decomp) - call addfld ('FICE ', 'fraction', pver, 'A', 'Fractional ice content within cloud' ,phys_decomp) - call addfld ('ICWMRST ', 'kg/kg ', pver, 'A', 'Prognostic in-stratus water mixing ratio' ,phys_decomp) - call addfld ('ICIMRST ', 'kg/kg ', pver, 'A', 'Prognostic in-stratus ice mixing ratio' ,phys_decomp) - - ! MG microphysics diagnostics - call addfld ('QCSEVAP ', 'kg/kg/s ', pver, 'A', 'Rate of evaporation of falling cloud water' ,phys_decomp) - call addfld ('QISEVAP ', 'kg/kg/s ', pver, 'A', 'Rate of sublimation of falling cloud ice' ,phys_decomp) - call addfld ('QVRES ', 'kg/kg/s ', pver, 'A', 'Rate of residual condensation term' ,phys_decomp) - call addfld ('CMEIOUT ', 'kg/kg/s ', pver, 'A', 'Rate of deposition/sublimation of cloud ice' ,phys_decomp) - call addfld ('VTRMC ', 'm/s ', pver, 'A', 'Mass-weighted cloud water fallspeed' ,phys_decomp) - call addfld ('VTRMI ', 'm/s ', pver, 'A', 'Mass-weighted cloud ice fallspeed' ,phys_decomp) - call addfld ('QCSEDTEN ', 'kg/kg/s ', pver, 'A', 'Cloud water mixing ratio tendency from sedimentation' ,phys_decomp) - call addfld ('QISEDTEN ', 'kg/kg/s ', pver, 'A', 'Cloud ice mixing ratio tendency from sedimentation' ,phys_decomp) - call addfld ('PRAO ', 'kg/kg/s ', pver, 'A', 'Accretion of cloud water by rain' ,phys_decomp) - call addfld ('PRCO ', 'kg/kg/s ', pver, 'A', 'Autoconversion of cloud water' ,phys_decomp) - call addfld ('MNUCCCO ', 'kg/kg/s ', pver, 'A', 'Immersion freezing of cloud water' ,phys_decomp) - call addfld ('MNUCCTO ', 'kg/kg/s ', pver, 'A', 'Contact freezing of cloud water' ,phys_decomp) - call addfld ('MNUCCDO ', 'kg/kg/s ', pver, 'A', 'Homogeneous and heterogeneous nucleation from vapor' ,phys_decomp) - call addfld ('MNUCCDOhet','kg/kg/s ', pver, 'A', 'Heterogeneous nucleation from vapor' ,phys_decomp) - call addfld ('MSACWIO ', 'kg/kg/s ', pver, 'A', 'Conversion of cloud water from rime-splintering' ,phys_decomp) - call addfld ('PSACWSO ', 'kg/kg/s ', pver, 'A', 'Accretion of cloud water by snow' ,phys_decomp) - call addfld ('BERGSO ', 'kg/kg/s ', pver, 'A', 'Conversion of cloud water to snow from bergeron' ,phys_decomp) - call addfld ('BERGO ', 'kg/kg/s ', pver, 'A', 'Conversion of cloud water to cloud ice from bergeron' ,phys_decomp) - call addfld ('MELTO ', 'kg/kg/s ', pver, 'A', 'Melting of cloud ice' ,phys_decomp) - call addfld ('HOMOO ', 'kg/kg/s ', pver, 'A', 'Homogeneous freezing of cloud water' ,phys_decomp) - call addfld ('QCRESO ', 'kg/kg/s ', pver, 'A', 'Residual condensation term for cloud water' ,phys_decomp) - call addfld ('PRCIO ', 'kg/kg/s ', pver, 'A', 'Autoconversion of cloud ice' ,phys_decomp) - call addfld ('PRAIO ', 'kg/kg/s ', pver, 'A', 'Accretion of cloud ice by rain' ,phys_decomp) - call addfld ('QIRESO ', 'kg/kg/s ', pver, 'A', 'Residual deposition term for cloud ice' ,phys_decomp) - call addfld ('MNUCCRO ', 'kg/kg/s ', pver, 'A', 'Heterogeneous freezing of rain to snow' ,phys_decomp) - call addfld ('PRACSO ', 'kg/kg/s ', pver, 'A', 'Accretion of rain by snow' ,phys_decomp) - call addfld ('MELTSDT ', 'W/kg ', pver, 'A', 'Latent heating rate due to melting of snow' ,phys_decomp) - call addfld ('FRZRDT ', 'W/kg ', pver, 'A', 'Latent heating rate due to homogeneous freezing of rain' ,phys_decomp) - - ! History variables for CAM5 microphysics - call addfld ('MPDT ', 'W/kg ', pver, 'A', 'Heating tendency - Morrison microphysics' ,phys_decomp) - call addfld ('MPDQ ', 'kg/kg/s ', pver, 'A', 'Q tendency - Morrison microphysics' ,phys_decomp) - call addfld ('MPDLIQ ', 'kg/kg/s ', pver, 'A', 'CLDLIQ tendency - Morrison microphysics' ,phys_decomp) - call addfld ('MPDICE ', 'kg/kg/s ', pver, 'A', 'CLDICE tendency - Morrison microphysics' ,phys_decomp) - call addfld ('MPDW2V ', 'kg/kg/s ', pver, 'A', 'Water <--> Vapor tendency - Morrison microphysics' ,phys_decomp) - call addfld ('MPDW2I ', 'kg/kg/s ', pver, 'A', 'Water <--> Ice tendency - Morrison microphysics' ,phys_decomp) - call addfld ('MPDW2P ', 'kg/kg/s ', pver, 'A', 'Water <--> Precip tendency - Morrison microphysics' ,phys_decomp) - call addfld ('MPDI2V ', 'kg/kg/s ', pver, 'A', 'Ice <--> Vapor tendency - Morrison microphysics' ,phys_decomp) - call addfld ('MPDI2W ', 'kg/kg/s ', pver, 'A', 'Ice <--> Water tendency - Morrison microphysics' ,phys_decomp) - call addfld ('MPDI2P ', 'kg/kg/s ', pver, 'A', 'Ice <--> Precip tendency - Morrison microphysics' ,phys_decomp) - call addfld ('ICWNC ', 'm-3 ', pver, 'A', 'Prognostic in-cloud water number conc' ,phys_decomp) - call addfld ('ICINC ', 'm-3 ', pver, 'A', 'Prognostic in-cloud ice number conc' ,phys_decomp) - call addfld ('EFFLIQ_IND','Micron ', pver, 'A', 'Prognostic droplet effective radius (indirect effect)' ,phys_decomp) - call addfld ('CDNUMC ', '1/m2 ', 1, 'A', 'Vertically-integrated droplet concentration' ,phys_decomp) - call addfld ('MPICLWPI ', 'kg/m2 ', 1, 'A', 'Vertically-integrated & - &in-cloud Initial Liquid WP (Before Micro)' ,phys_decomp) - call addfld ('MPICIWPI ', 'kg/m2 ', 1, 'A', 'Vertically-integrated & - &in-cloud Initial Ice WP (Before Micro)' ,phys_decomp) - - ! This is provided as an example on how to write out subcolumn output - ! NOTE -- only 'I' should be used for sub-column fields as subc-columns could shift from time-step to time-step - if (use_subcol_microp) then - call addfld('FICE_SCOL', 'fraction', psubcols*pver, 'I', & - 'Sub-column fractional ice content within cloud', phys_decomp, & - mdimnames=(/'psubcols','lev '/), flag_xyfill=.true., fill_value=1.e30_r8) - end if - - ! Averaging for cloud particle number and size - call addfld ('AWNC ', 'm-3 ', pver, 'A', 'Average cloud water number conc' ,phys_decomp) - call addfld ('AWNI ', 'm-3 ', pver, 'A', 'Average cloud ice number conc' ,phys_decomp) - call addfld ('AREL ', 'Micron ', pver, 'A', 'Average droplet effective radius' ,phys_decomp) - call addfld ('AREI ', 'Micron ', pver, 'A', 'Average ice effective radius' ,phys_decomp) - ! Frequency arrays for above - call addfld ('FREQL ', 'fraction', pver, 'A', 'Fractional occurrence of liquid' ,phys_decomp) - call addfld ('FREQI ', 'fraction', pver, 'A', 'Fractional occurrence of ice' ,phys_decomp) - - ! Average cloud top particle size and number (liq, ice) and frequency - call addfld ('ACTREL ', 'Micron ', 1, 'A', 'Average Cloud Top droplet effective radius' ,phys_decomp) - call addfld ('ACTREI ', 'Micron ', 1, 'A', 'Average Cloud Top ice effective radius' ,phys_decomp) - call addfld ('ACTNL ', 'Micron ', 1, 'A', 'Average Cloud Top droplet number' ,phys_decomp) - call addfld ('ACTNI ', 'Micron ', 1, 'A', 'Average Cloud Top ice number' ,phys_decomp) - - call addfld ('FCTL ', 'fraction', 1, 'A', 'Fractional occurrence of cloud top liquid' ,phys_decomp) - call addfld ('FCTI ', 'fraction', 1, 'A', 'Fractional occurrence of cloud top ice' ,phys_decomp) - - call addfld ('LS_FLXPRC', 'kg/m2/s', pverp, 'A', 'ls stratiform gbm interface rain+snow flux', phys_decomp) - call addfld ('LS_FLXSNW', 'kg/m2/s', pverp, 'A', 'ls stratiform gbm interface snow flux', phys_decomp) - - call addfld ('REL', 'micron', pver, 'A', 'MG REL stratiform cloud effective radius liquid', phys_decomp) - call addfld ('REI', 'micron', pver, 'A', 'MG REI stratiform cloud effective radius ice', phys_decomp) - call addfld ('LS_REFFRAIN', 'micron', pver, 'A', 'ls stratiform rain effective radius', phys_decomp) - call addfld ('LS_REFFSNOW', 'micron', pver, 'A', 'ls stratiform snow effective radius', phys_decomp) - call addfld ('CV_REFFLIQ', 'micron', pver, 'A', 'convective cloud liq effective radius', phys_decomp) - call addfld ('CV_REFFICE', 'micron', pver, 'A', 'convective cloud ice effective radius', phys_decomp) - - ! diagnostic precip - call addfld ('QRAIN ','kg/kg ',pver, 'A','Diagnostic grid-mean rain mixing ratio' ,phys_decomp) - call addfld ('QSNOW ','kg/kg ',pver, 'A','Diagnostic grid-mean snow mixing ratio' ,phys_decomp) - call addfld ('NRAIN ','m-3 ',pver, 'A','Diagnostic grid-mean rain number conc' ,phys_decomp) - call addfld ('NSNOW ','m-3 ',pver, 'A','Diagnostic grid-mean snow number conc' ,phys_decomp) - - ! size of precip - call addfld ('RERCLD ','m ',pver, 'A','Diagnostic effective radius of Liquid Cloud and Rain' ,phys_decomp) - call addfld ('DSNOW ','m ',pver, 'A','Diagnostic grid-mean snow diameter' ,phys_decomp) - - ! diagnostic radar reflectivity, cloud-averaged - call addfld ('REFL ','DBz ',pver, 'A','94 GHz radar reflectivity' ,phys_decomp) - call addfld ('AREFL ','DBz ',pver, 'A','Average 94 GHz radar reflectivity' ,phys_decomp) - call addfld ('FREFL ','fraction ',pver, 'A','Fractional occurrence of radar reflectivity' ,phys_decomp) - - call addfld ('CSRFL ','DBz ',pver, 'A','94 GHz radar reflectivity (CloudSat thresholds)' ,phys_decomp) - call addfld ('ACSRFL ','DBz ',pver, 'A','Average 94 GHz radar reflectivity (CloudSat thresholds)' ,phys_decomp) - call addfld ('FCSRFL ','fraction ',pver, 'A','Fractional occurrence of radar reflectivity (CloudSat thresholds)' & - ,phys_decomp) - - call addfld ('AREFLZ ','mm^6/m^3 ',pver, 'A','Average 94 GHz radar reflectivity' ,phys_decomp) - - ! Aerosol information - call addfld ('NCAL ','1/m3 ',pver, 'A','Number Concentation Activated for Liquid',phys_decomp) - call addfld ('NCAI ','1/m3 ',pver, 'A','Number Concentation Activated for Ice',phys_decomp) - - ! Average rain and snow mixing ratio (Q), number (N) and diameter (D), with frequency - call addfld ('AQRAIN ','kg/kg ',pver, 'A','Average rain mixing ratio' ,phys_decomp) - call addfld ('AQSNOW ','kg/kg ',pver, 'A','Average snow mixing ratio' ,phys_decomp) - call addfld ('ANRAIN ','m-3 ',pver, 'A','Average rain number conc' ,phys_decomp) - call addfld ('ANSNOW ','m-3 ',pver, 'A','Average snow number conc' ,phys_decomp) - call addfld ('ADRAIN ','Micron ',pver, 'A','Average rain effective Diameter' ,phys_decomp) - call addfld ('ADSNOW ','Micron ',pver, 'A','Average snow effective Diameter' ,phys_decomp) - call addfld ('FREQR ','fraction ',pver, 'A','Fractional occurrence of rain' ,phys_decomp) - call addfld ('FREQS ','fraction ',pver, 'A','Fractional occurrence of snow' ,phys_decomp) - - ! precipitation efficiency & other diagnostic fields - call addfld('PE' , '1', 1, 'A', 'Stratiform Precipitation Efficiency (precip/cmeliq)', phys_decomp ) - call addfld('APRL' , 'm/s', 1, 'A', 'Average Stratiform Precip Rate over efficiency calculation', phys_decomp ) - call addfld('PEFRAC', '1', 1, 'A', 'Fraction of timesteps precip efficiency reported', phys_decomp ) - call addfld('VPRCO' , 'kg/kg/s', 1, 'A', 'Vertical average of autoconversion rate', phys_decomp ) - call addfld('VPRAO' , 'kg/kg/s', 1, 'A', 'Vertical average of accretion rate', phys_decomp ) - call addfld('RACAU' , 'kg/kg/s', 1, 'A', 'Accretion/autoconversion ratio from vertical average', phys_decomp ) - - ! determine the add_default fields - call phys_getopts(history_amwg_out = history_amwg , & - history_budget_out = history_budget , & - history_budget_histfile_num_out = budget_histfile) - - if (history_amwg) then - call add_default ('FICE ', 1, ' ') - call add_default ('AQRAIN ', 1, ' ') - call add_default ('AQSNOW ', 1, ' ') - call add_default ('ANRAIN ', 1, ' ') - call add_default ('ANSNOW ', 1, ' ') - call add_default ('AREI ', 1, ' ') - call add_default ('AREL ', 1, ' ') - call add_default ('AWNC ', 1, ' ') - call add_default ('AWNI ', 1, ' ') - call add_default ('CDNUMC ', 1, ' ') - call add_default ('FREQR ', 1, ' ') - call add_default ('FREQS ', 1, ' ') - call add_default ('FREQL ', 1, ' ') - call add_default ('FREQI ', 1, ' ') - do m = 1, ncnst - call cnst_get_ind(cnst_names(m), mm) - call add_default(cnst_name(mm), 1, ' ') - ! call add_default(sflxnam(mm), 1, ' ') - end do - end if - - if ( history_budget ) then - call add_default ('EVAPSNOW ', budget_histfile, ' ') - call add_default ('EVAPPREC ', budget_histfile, ' ') - call add_default ('QVRES ', budget_histfile, ' ') - call add_default ('QISEVAP ', budget_histfile, ' ') - call add_default ('QCSEVAP ', budget_histfile, ' ') - call add_default ('QISEDTEN ', budget_histfile, ' ') - call add_default ('QCSEDTEN ', budget_histfile, ' ') - call add_default ('QIRESO ', budget_histfile, ' ') - call add_default ('QCRESO ', budget_histfile, ' ') - call add_default ('PSACWSO ', budget_histfile, ' ') - call add_default ('PRCO ', budget_histfile, ' ') - call add_default ('PRCIO ', budget_histfile, ' ') - call add_default ('PRAO ', budget_histfile, ' ') - call add_default ('PRAIO ', budget_histfile, ' ') - call add_default ('PRACSO ', budget_histfile, ' ') - call add_default ('MSACWIO ', budget_histfile, ' ') - call add_default ('MPDW2V ', budget_histfile, ' ') - call add_default ('MPDW2P ', budget_histfile, ' ') - call add_default ('MPDW2I ', budget_histfile, ' ') - call add_default ('MPDT ', budget_histfile, ' ') - call add_default ('MPDQ ', budget_histfile, ' ') - call add_default ('MPDLIQ ', budget_histfile, ' ') - call add_default ('MPDICE ', budget_histfile, ' ') - call add_default ('MPDI2W ', budget_histfile, ' ') - call add_default ('MPDI2V ', budget_histfile, ' ') - call add_default ('MPDI2P ', budget_histfile, ' ') - call add_default ('MNUCCTO ', budget_histfile, ' ') - call add_default ('MNUCCRO ', budget_histfile, ' ') - call add_default ('MNUCCCO ', budget_histfile, ' ') - call add_default ('MELTSDT ', budget_histfile, ' ') - call add_default ('MELTO ', budget_histfile, ' ') - call add_default ('HOMOO ', budget_histfile, ' ') - call add_default ('FRZRDT ', budget_histfile, ' ') - call add_default ('CMEIOUT ', budget_histfile, ' ') - call add_default ('BERGSO ', budget_histfile, ' ') - call add_default ('BERGO ', budget_histfile, ' ') - - call add_default(cnst_name(ixcldliq), budget_histfile, ' ') - call add_default(cnst_name(ixcldice), budget_histfile, ' ') - call add_default(apcnst (ixcldliq), budget_histfile, ' ') - call add_default(apcnst (ixcldice), budget_histfile, ' ') - call add_default(bpcnst (ixcldliq), budget_histfile, ' ') - call add_default(bpcnst (ixcldice), budget_histfile, ' ') - - end if - - ! physics buffer indices - ast_idx = pbuf_get_index('AST') - aist_idx = pbuf_get_index('AIST') - alst_idx = pbuf_get_index('ALST') - cld_idx = pbuf_get_index('CLD') - concld_idx = pbuf_get_index('CONCLD') - - naai_idx = pbuf_get_index('NAAI') - naai_hom_idx = pbuf_get_index('NAAI_HOM') - npccn_idx = pbuf_get_index('NPCCN') - rndst_idx = pbuf_get_index('RNDST') - nacon_idx = pbuf_get_index('NACON') - - prec_str_idx = pbuf_get_index('PREC_STR') - snow_str_idx = pbuf_get_index('SNOW_STR') - prec_sed_idx = pbuf_get_index('PREC_SED') - snow_sed_idx = pbuf_get_index('SNOW_SED') - prec_pcw_idx = pbuf_get_index('PREC_PCW') - snow_pcw_idx = pbuf_get_index('SNOW_PCW') - - cmeliq_idx = pbuf_get_index('CMELIQ') - - ! These fields may have been added, so don't abort if they have not been - qrain_idx = pbuf_get_index('QRAIN', ierr) - qsnow_idx = pbuf_get_index('QSNOW', ierr) - nrain_idx = pbuf_get_index('NRAIN', ierr) - nsnow_idx = pbuf_get_index('NSNOW', ierr) + use time_manager, only: is_first_step + use micro_mg_utils, only: micro_mg_utils_init + use micro_mg1_0, only: micro_mg_init1_0 => micro_mg_init + use micro_mg1_5, only: micro_mg_init1_5 => micro_mg_init + use micro_mg2_0, only: micro_mg_init2_0 => micro_mg_init + + !----------------------------------------------------------------------- + ! + ! Initialization for MG microphysics + ! + !----------------------------------------------------------------------- + + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + + integer :: m, mm + logical :: history_amwg ! output the variables used by the AMWG diag package + logical :: history_budget ! Output tendencies and state variables for CAM4 + ! temperature, water vapor, cloud ice and cloud + ! liquid budgets. + logical :: use_subcol_microp + logical :: do_clubb_sgs + integer :: budget_histfile ! output history file number for budget fields + integer :: ierr + character(128) :: errstring ! return status (non-blank for error return) + + !----------------------------------------------------------------------- + + call phys_getopts(use_subcol_microp_out=use_subcol_microp, & + do_clubb_sgs_out =do_clubb_sgs) + + if (do_clubb_sgs) then + allow_sed_supersat = .false. + else + allow_sed_supersat = .true. + endif + + if (masterproc) then + write(iulog,"(A,I2,A,I2)") "Initializing MG version ",micro_mg_version,".",micro_mg_sub_version + if (.not. do_cldliq) & + write(iulog,*) "MG prognostic cloud liquid has been turned off via namelist." + if (.not. do_cldice) & + write(iulog,*) "MG prognostic cloud ice has been turned off via namelist." + write(iulog,*) "Number of microphysics substeps is: ",num_steps + end if + + select case (micro_mg_version) + case (1) + ! Set constituent number for later loops. + ncnst = 4 + + select case (micro_mg_sub_version) + case (0) + ! MG 1 does not initialize micro_mg_utils, so have to do it here. + call micro_mg_utils_init(r8, rh2o, cpair, tmelt, latvap, latice, & + micro_mg_dcs, errstring) + call handle_errmsg(errstring, subname="micro_mg_utils_init") + + call micro_mg_init1_0( & + r8, gravit, rair, rh2o, cpair, & + rhoh2o, tmelt, latvap, latice, & + rhmini, micro_mg_dcs, use_hetfrz_classnuc, & + micro_mg_precip_frac_method, micro_mg_berg_eff_factor, errstring) + case (5) + ! MG 1 does not initialize micro_mg_utils, so have to do it here. + call micro_mg_utils_init(r8, rh2o, cpair, tmelt, latvap, latice, & + micro_mg_dcs, errstring) + call handle_errmsg(errstring, subname="micro_mg_utils_init") + + call micro_mg_init1_5( & + r8, gravit, rair, rh2o, cpair, & + tmelt, latvap, latice, rhmini, & + micro_mg_dcs, & + microp_uniform, do_cldice, use_hetfrz_classnuc, & + micro_mg_precip_frac_method, micro_mg_berg_eff_factor, errstring) + end select + case (2) + ! Set constituent number for later loops. + ncnst = 8 + + select case (micro_mg_sub_version) + case (0) + call micro_mg_init2_0( & + r8, gravit, rair, rh2o, cpair, & + tmelt, latvap, latice, rhmini, & + micro_mg_dcs, & + microp_uniform, do_cldice, use_hetfrz_classnuc, & + micro_mg_precip_frac_method, micro_mg_berg_eff_factor, & + allow_sed_supersat, errstring) + end select + end select + + call handle_errmsg(errstring, subname="micro_mg_init") + + ! Register history variables + do m = 1, ncnst + call cnst_get_ind(cnst_names(m), mm) + if ( any(mm == (/ ixcldliq, ixcldice, ixrain, ixsnow /)) ) then + ! mass mixing ratios + call addfld(cnst_name(mm), 'kg/kg ', pver, 'A', cnst_longname(mm) , phys_decomp) + call addfld(sflxnam(mm), 'kg/m2/s ', 1, 'A', trim(cnst_name(mm))//' surface flux', phys_decomp) + else if ( any(mm == (/ ixnumliq, ixnumice, ixnumrain, ixnumsnow /)) ) then + ! number concentrations + call addfld(cnst_name(mm), '1/kg ', pver, 'A', cnst_longname(mm) , phys_decomp) + call addfld(sflxnam(mm), '1/m2/s ', 1, 'A', trim(cnst_name(mm))//' surface flux', phys_decomp) + else + call endrun( "micro_mg_cam_init: & + &Could not call addfld for constituent with unknown units.") + endif + end do + + call addfld(apcnst(ixcldliq), 'kg/kg ', pver, 'A', trim(cnst_name(ixcldliq))//' after physics' , phys_decomp) + call addfld(apcnst(ixcldice), 'kg/kg ', pver, 'A', trim(cnst_name(ixcldice))//' after physics' , phys_decomp) + call addfld(bpcnst(ixcldliq), 'kg/kg ', pver, 'A', trim(cnst_name(ixcldliq))//' before physics' , phys_decomp) + call addfld(bpcnst(ixcldice), 'kg/kg ', pver, 'A', trim(cnst_name(ixcldice))//' before physics' , phys_decomp) + + if (micro_mg_version > 1) then + call addfld(apcnst(ixrain), 'kg/kg ', pver, 'A', trim(cnst_name(ixrain))//' after physics' , phys_decomp) + call addfld(apcnst(ixsnow), 'kg/kg ', pver, 'A', trim(cnst_name(ixsnow))//' after physics' , phys_decomp) + call addfld(bpcnst(ixrain), 'kg/kg ', pver, 'A', trim(cnst_name(ixrain))//' before physics' , phys_decomp) + call addfld(bpcnst(ixsnow), 'kg/kg ', pver, 'A', trim(cnst_name(ixsnow))//' before physics' , phys_decomp) + end if + + call addfld ('CME ', 'kg/kg/s ', pver, 'A', 'Rate of cond-evap within the cloud' ,phys_decomp) + call addfld ('PRODPREC ', 'kg/kg/s ', pver, 'A', 'Rate of conversion of condensate to precip' ,phys_decomp) + call addfld ('EVAPPREC ', 'kg/kg/s ', pver, 'A', 'Rate of evaporation of falling precip' ,phys_decomp) + call addfld ('EVAPSNOW ', 'kg/kg/s ', pver, 'A', 'Rate of evaporation of falling snow' ,phys_decomp) + call addfld ('HPROGCLD ', 'W/kg' , pver, 'A', 'Heating from prognostic clouds' ,phys_decomp) + call addfld ('FICE ', 'fraction', pver, 'A', 'Fractional ice content within cloud' ,phys_decomp) + call addfld ('ICWMRST ', 'kg/kg ', pver, 'A', 'Prognostic in-stratus water mixing ratio' ,phys_decomp) + call addfld ('ICIMRST ', 'kg/kg ', pver, 'A', 'Prognostic in-stratus ice mixing ratio' ,phys_decomp) + + ! MG microphysics diagnostics + call addfld ('QCSEVAP ', 'kg/kg/s ', pver, 'A', 'Rate of evaporation of falling cloud water' ,phys_decomp) + call addfld ('QISEVAP ', 'kg/kg/s ', pver, 'A', 'Rate of sublimation of falling cloud ice' ,phys_decomp) + call addfld ('QVRES ', 'kg/kg/s ', pver, 'A', 'Rate of residual condensation term' ,phys_decomp) + call addfld ('CMEIOUT ', 'kg/kg/s ', pver, 'A', 'Rate of deposition/sublimation of cloud ice' ,phys_decomp) + call addfld ('VTRMC ', 'm/s ', pver, 'A', 'Mass-weighted cloud water fallspeed' ,phys_decomp) + call addfld ('VTRMI ', 'm/s ', pver, 'A', 'Mass-weighted cloud ice fallspeed' ,phys_decomp) + call addfld ('QCSEDTEN ', 'kg/kg/s ', pver, 'A', 'Cloud water mixing ratio tendency from sedimentation' ,phys_decomp) + call addfld ('QISEDTEN ', 'kg/kg/s ', pver, 'A', 'Cloud ice mixing ratio tendency from sedimentation' ,phys_decomp) + call addfld ('PRAO ', 'kg/kg/s ', pver, 'A', 'Accretion of cloud water by rain' ,phys_decomp) + call addfld ('PRCO ', 'kg/kg/s ', pver, 'A', 'Autoconversion of cloud water' ,phys_decomp) + call addfld ('MNUCCCO ', 'kg/kg/s ', pver, 'A', 'Immersion freezing of cloud water' ,phys_decomp) + call addfld ('MNUCCTO ', 'kg/kg/s ', pver, 'A', 'Contact freezing of cloud water' ,phys_decomp) + call addfld ('MNUCCDO ', 'kg/kg/s ', pver, 'A', 'Homogeneous and heterogeneous nucleation from vapor' ,phys_decomp) + call addfld ('MNUCCDOhet','kg/kg/s ', pver, 'A', 'Heterogeneous nucleation from vapor' ,phys_decomp) + call addfld ('MSACWIO ', 'kg/kg/s ', pver, 'A', 'Conversion of cloud water from rime-splintering' ,phys_decomp) + call addfld ('PSACWSO ', 'kg/kg/s ', pver, 'A', 'Accretion of cloud water by snow' ,phys_decomp) + call addfld ('BERGSO ', 'kg/kg/s ', pver, 'A', 'Conversion of cloud water to snow from bergeron' ,phys_decomp) + call addfld ('BERGO ', 'kg/kg/s ', pver, 'A', 'Conversion of cloud water to cloud ice from bergeron' ,phys_decomp) + call addfld ('MELTO ', 'kg/kg/s ', pver, 'A', 'Melting of cloud ice' ,phys_decomp) + call addfld ('HOMOO ', 'kg/kg/s ', pver, 'A', 'Homogeneous freezing of cloud water' ,phys_decomp) + call addfld ('QCRESO ', 'kg/kg/s ', pver, 'A', 'Residual condensation term for cloud water' ,phys_decomp) + call addfld ('PRCIO ', 'kg/kg/s ', pver, 'A', 'Autoconversion of cloud ice' ,phys_decomp) + call addfld ('PRAIO ', 'kg/kg/s ', pver, 'A', 'Accretion of cloud ice by rain' ,phys_decomp) + call addfld ('QIRESO ', 'kg/kg/s ', pver, 'A', 'Residual deposition term for cloud ice' ,phys_decomp) + call addfld ('MNUCCRO ', 'kg/kg/s ', pver, 'A', 'Heterogeneous freezing of rain to snow' ,phys_decomp) + call addfld ('PRACSO ', 'kg/kg/s ', pver, 'A', 'Accretion of rain by snow' ,phys_decomp) + call addfld ('MELTSDT ', 'W/kg ', pver, 'A', 'Latent heating rate due to melting of snow' ,phys_decomp) + call addfld ('FRZRDT ', 'W/kg ', pver, 'A', 'Latent heating rate due to homogeneous freezing of rain' ,phys_decomp) + if (micro_mg_version > 1) then + call addfld ('QRSEDTEN ', 'kg/kg/s ', pver, 'A', 'Rain mixing ratio tendency from sedimentation' ,phys_decomp) + call addfld ('QSSEDTEN ', 'kg/kg/s ', pver, 'A', 'Snow mixing ratio tendency from sedimentation' ,phys_decomp) + end if + + ! History variables for CAM5 microphysics + call addfld ('MPDT ', 'W/kg ', pver, 'A', 'Heating tendency - Morrison microphysics' ,phys_decomp) + call addfld ('MPDQ ', 'kg/kg/s ', pver, 'A', 'Q tendency - Morrison microphysics' ,phys_decomp) + call addfld ('MPDLIQ ', 'kg/kg/s ', pver, 'A', 'CLDLIQ tendency - Morrison microphysics' ,phys_decomp) + call addfld ('MPDICE ', 'kg/kg/s ', pver, 'A', 'CLDICE tendency - Morrison microphysics' ,phys_decomp) + call addfld ('MPDW2V ', 'kg/kg/s ', pver, 'A', 'Water <--> Vapor tendency - Morrison microphysics' ,phys_decomp) + call addfld ('MPDW2I ', 'kg/kg/s ', pver, 'A', 'Water <--> Ice tendency - Morrison microphysics' ,phys_decomp) + call addfld ('MPDW2P ', 'kg/kg/s ', pver, 'A', 'Water <--> Precip tendency - Morrison microphysics' ,phys_decomp) + call addfld ('MPDI2V ', 'kg/kg/s ', pver, 'A', 'Ice <--> Vapor tendency - Morrison microphysics' ,phys_decomp) + call addfld ('MPDI2W ', 'kg/kg/s ', pver, 'A', 'Ice <--> Water tendency - Morrison microphysics' ,phys_decomp) + call addfld ('MPDI2P ', 'kg/kg/s ', pver, 'A', 'Ice <--> Precip tendency - Morrison microphysics' ,phys_decomp) + call addfld ('ICWNC ', 'm-3 ', pver, 'A', 'Prognostic in-cloud water number conc' ,phys_decomp) + call addfld ('ICINC ', 'm-3 ', pver, 'A', 'Prognostic in-cloud ice number conc' ,phys_decomp) + call addfld ('EFFLIQ_IND','Micron ', pver, 'A', 'Prognostic droplet effective radius (indirect effect)' ,phys_decomp) + call addfld ('CDNUMC ', '1/m2 ', 1, 'A', 'Vertically-integrated droplet concentration' ,phys_decomp) + call addfld ('MPICLWPI ', 'kg/m2 ', 1, 'A', 'Vertically-integrated & + &in-cloud Initial Liquid WP (Before Micro)' ,phys_decomp) + call addfld ('MPICIWPI ', 'kg/m2 ', 1, 'A', 'Vertically-integrated & + &in-cloud Initial Ice WP (Before Micro)' ,phys_decomp) + + ! This is provided as an example on how to write out subcolumn output + ! NOTE -- only 'I' should be used for sub-column fields as subc-columns could shift from time-step to time-step + if (use_subcol_microp) then + call addfld('FICE_SCOL', 'fraction', psubcols*pver, 'I', & + 'Sub-column fractional ice content within cloud', phys_decomp, & + mdimnames=(/'psubcols','lev '/), flag_xyfill=.true., fill_value=1.e30_r8) + end if + + ! Averaging for cloud particle number and size + call addfld ('AWNC ', 'm-3 ', pver, 'A', 'Average cloud water number conc' ,phys_decomp) + call addfld ('AWNI ', 'm-3 ', pver, 'A', 'Average cloud ice number conc' ,phys_decomp) + call addfld ('AREL ', 'Micron ', pver, 'A', 'Average droplet effective radius' ,phys_decomp) + call addfld ('AREI ', 'Micron ', pver, 'A', 'Average ice effective radius' ,phys_decomp) + ! Frequency arrays for above + call addfld ('FREQL ', 'fraction', pver, 'A', 'Fractional occurrence of liquid' ,phys_decomp) + call addfld ('FREQI ', 'fraction', pver, 'A', 'Fractional occurrence of ice' ,phys_decomp) + + ! Average cloud top particle size and number (liq, ice) and frequency + call addfld ('ACTREL ', 'Micron ', 1, 'A', 'Average Cloud Top droplet effective radius' ,phys_decomp) + call addfld ('ACTREI ', 'Micron ', 1, 'A', 'Average Cloud Top ice effective radius' ,phys_decomp) + call addfld ('ACTNL ', 'Micron ', 1, 'A', 'Average Cloud Top droplet number' ,phys_decomp) + call addfld ('ACTNI ', 'Micron ', 1, 'A', 'Average Cloud Top ice number' ,phys_decomp) + + call addfld ('FCTL ', 'fraction', 1, 'A', 'Fractional occurrence of cloud top liquid' ,phys_decomp) + call addfld ('FCTI ', 'fraction', 1, 'A', 'Fractional occurrence of cloud top ice' ,phys_decomp) + + call addfld ('LS_FLXPRC', 'kg/m2/s', pverp, 'A', 'ls stratiform gbm interface rain+snow flux', phys_decomp) + call addfld ('LS_FLXSNW', 'kg/m2/s', pverp, 'A', 'ls stratiform gbm interface snow flux', phys_decomp) + + call addfld ('REL', 'micron', pver, 'A', 'MG REL stratiform cloud effective radius liquid', phys_decomp) + call addfld ('REI', 'micron', pver, 'A', 'MG REI stratiform cloud effective radius ice', phys_decomp) + call addfld ('LS_REFFRAIN', 'micron', pver, 'A', 'ls stratiform rain effective radius', phys_decomp) + call addfld ('LS_REFFSNOW', 'micron', pver, 'A', 'ls stratiform snow effective radius', phys_decomp) + call addfld ('CV_REFFLIQ', 'micron', pver, 'A', 'convective cloud liq effective radius', phys_decomp) + call addfld ('CV_REFFICE', 'micron', pver, 'A', 'convective cloud ice effective radius', phys_decomp) + + ! diagnostic precip + call addfld ('QRAIN ','kg/kg ',pver, 'A','Diagnostic grid-mean rain mixing ratio' ,phys_decomp) + call addfld ('QSNOW ','kg/kg ',pver, 'A','Diagnostic grid-mean snow mixing ratio' ,phys_decomp) + call addfld ('NRAIN ','m-3 ',pver, 'A','Diagnostic grid-mean rain number conc' ,phys_decomp) + call addfld ('NSNOW ','m-3 ',pver, 'A','Diagnostic grid-mean snow number conc' ,phys_decomp) + + ! size of precip + call addfld ('RERCLD ','m ',pver, 'A','Diagnostic effective radius of Liquid Cloud and Rain' ,phys_decomp) + call addfld ('DSNOW ','m ',pver, 'A','Diagnostic grid-mean snow diameter' ,phys_decomp) + + ! diagnostic radar reflectivity, cloud-averaged + call addfld ('REFL ','DBz ',pver, 'A','94 GHz radar reflectivity' ,phys_decomp) + call addfld ('AREFL ','DBz ',pver, 'A','Average 94 GHz radar reflectivity' ,phys_decomp) + call addfld ('FREFL ','fraction ',pver, 'A','Fractional occurrence of radar reflectivity' ,phys_decomp) + + call addfld ('CSRFL ','DBz ',pver, 'A','94 GHz radar reflectivity (CloudSat thresholds)' ,phys_decomp) + call addfld ('ACSRFL ','DBz ',pver, 'A','Average 94 GHz radar reflectivity (CloudSat thresholds)' ,phys_decomp) + call addfld ('FCSRFL ','fraction ',pver, 'A','Fractional occurrence of radar reflectivity (CloudSat thresholds)' & + ,phys_decomp) + + call addfld ('AREFLZ ','mm^6/m^3 ',pver, 'A','Average 94 GHz radar reflectivity' ,phys_decomp) + + ! Aerosol information + call addfld ('NCAL ','1/m3 ',pver, 'A','Number Concentation Activated for Liquid',phys_decomp) + call addfld ('NCAI ','1/m3 ',pver, 'A','Number Concentation Activated for Ice',phys_decomp) + + ! Average rain and snow mixing ratio (Q), number (N) and diameter (D), with frequency + call addfld ('AQRAIN ','kg/kg ',pver, 'A','Average rain mixing ratio' ,phys_decomp) + call addfld ('AQSNOW ','kg/kg ',pver, 'A','Average snow mixing ratio' ,phys_decomp) + call addfld ('ANRAIN ','m-3 ',pver, 'A','Average rain number conc' ,phys_decomp) + call addfld ('ANSNOW ','m-3 ',pver, 'A','Average snow number conc' ,phys_decomp) + call addfld ('ADRAIN ','Micron ',pver, 'A','Average rain effective Diameter' ,phys_decomp) + call addfld ('ADSNOW ','Micron ',pver, 'A','Average snow effective Diameter' ,phys_decomp) + call addfld ('FREQR ','fraction ',pver, 'A','Fractional occurrence of rain' ,phys_decomp) + call addfld ('FREQS ','fraction ',pver, 'A','Fractional occurrence of snow' ,phys_decomp) + + ! precipitation efficiency & other diagnostic fields + call addfld('PE' , '1', 1, 'A', 'Stratiform Precipitation Efficiency (precip/cmeliq)', phys_decomp ) + call addfld('APRL' , 'm/s', 1, 'A', 'Average Stratiform Precip Rate over efficiency calculation', phys_decomp ) + call addfld('PEFRAC', '1', 1, 'A', 'Fraction of timesteps precip efficiency reported', phys_decomp ) + call addfld('VPRCO' , 'kg/kg/s', 1, 'A', 'Vertical average of autoconversion rate', phys_decomp ) + call addfld('VPRAO' , 'kg/kg/s', 1, 'A', 'Vertical average of accretion rate', phys_decomp ) + call addfld('RACAU' , 'kg/kg/s', 1, 'A', 'Accretion/autoconversion ratio from vertical average', phys_decomp ) + + if (micro_mg_version > 1) then + call addfld('UMR', 'm/s ', pver, 'A', 'Mass-weighted rain fallspeed' , phys_decomp) + call addfld('UMS', 'm/s ', pver, 'A', 'Mass-weighted snow fallspeed' , phys_decomp) + end if + + ! qc limiter (only output in versions 1.5 and later) + if (.not. (micro_mg_version == 1 .and. micro_mg_sub_version == 0)) then + call addfld('QCRAT', 'fraction', pver, 'A', 'Qc Limiter: Fraction of qc tendency applied', phys_decomp) + end if + + ! determine the add_default fields + call phys_getopts(history_amwg_out = history_amwg , & + history_budget_out = history_budget , & + history_budget_histfile_num_out = budget_histfile) + + if (history_amwg) then + call add_default ('FICE ', 1, ' ') + call add_default ('AQRAIN ', 1, ' ') + call add_default ('AQSNOW ', 1, ' ') + call add_default ('ANRAIN ', 1, ' ') + call add_default ('ANSNOW ', 1, ' ') + call add_default ('ADRAIN ', 1, ' ') + call add_default ('ADSNOW ', 1, ' ') + call add_default ('AREI ', 1, ' ') + call add_default ('AREL ', 1, ' ') + call add_default ('AWNC ', 1, ' ') + call add_default ('AWNI ', 1, ' ') + call add_default ('CDNUMC ', 1, ' ') + call add_default ('FREQR ', 1, ' ') + call add_default ('FREQS ', 1, ' ') + call add_default ('FREQL ', 1, ' ') + call add_default ('FREQI ', 1, ' ') + do m = 1, ncnst + call cnst_get_ind(cnst_names(m), mm) + call add_default(cnst_name(mm), 1, ' ') + ! call add_default(sflxnam(mm), 1, ' ') + end do + end if + + if ( history_budget ) then + call add_default ('EVAPSNOW ', budget_histfile, ' ') + call add_default ('EVAPPREC ', budget_histfile, ' ') + call add_default ('QVRES ', budget_histfile, ' ') + call add_default ('QISEVAP ', budget_histfile, ' ') + call add_default ('QCSEVAP ', budget_histfile, ' ') + call add_default ('QISEDTEN ', budget_histfile, ' ') + call add_default ('QCSEDTEN ', budget_histfile, ' ') + call add_default ('QIRESO ', budget_histfile, ' ') + call add_default ('QCRESO ', budget_histfile, ' ') + if (micro_mg_version > 1) then + call add_default ('QRSEDTEN ', budget_histfile, ' ') + call add_default ('QSSEDTEN ', budget_histfile, ' ') + end if + call add_default ('PSACWSO ', budget_histfile, ' ') + call add_default ('PRCO ', budget_histfile, ' ') + call add_default ('PRCIO ', budget_histfile, ' ') + call add_default ('PRAO ', budget_histfile, ' ') + call add_default ('PRAIO ', budget_histfile, ' ') + call add_default ('PRACSO ', budget_histfile, ' ') + call add_default ('MSACWIO ', budget_histfile, ' ') + call add_default ('MPDW2V ', budget_histfile, ' ') + call add_default ('MPDW2P ', budget_histfile, ' ') + call add_default ('MPDW2I ', budget_histfile, ' ') + call add_default ('MPDT ', budget_histfile, ' ') + call add_default ('MPDQ ', budget_histfile, ' ') + call add_default ('MPDLIQ ', budget_histfile, ' ') + call add_default ('MPDICE ', budget_histfile, ' ') + call add_default ('MPDI2W ', budget_histfile, ' ') + call add_default ('MPDI2V ', budget_histfile, ' ') + call add_default ('MPDI2P ', budget_histfile, ' ') + call add_default ('MNUCCTO ', budget_histfile, ' ') + call add_default ('MNUCCRO ', budget_histfile, ' ') + call add_default ('MNUCCCO ', budget_histfile, ' ') + call add_default ('MELTSDT ', budget_histfile, ' ') + call add_default ('MELTO ', budget_histfile, ' ') + call add_default ('HOMOO ', budget_histfile, ' ') + call add_default ('FRZRDT ', budget_histfile, ' ') + call add_default ('CMEIOUT ', budget_histfile, ' ') + call add_default ('BERGSO ', budget_histfile, ' ') + call add_default ('BERGO ', budget_histfile, ' ') + + call add_default(cnst_name(ixcldliq), budget_histfile, ' ') + call add_default(cnst_name(ixcldice), budget_histfile, ' ') + call add_default(apcnst (ixcldliq), budget_histfile, ' ') + call add_default(apcnst (ixcldice), budget_histfile, ' ') + call add_default(bpcnst (ixcldliq), budget_histfile, ' ') + call add_default(bpcnst (ixcldice), budget_histfile, ' ') + if (micro_mg_version > 1) then + call add_default(cnst_name(ixrain), budget_histfile, ' ') + call add_default(cnst_name(ixsnow), budget_histfile, ' ') + call add_default(apcnst (ixrain), budget_histfile, ' ') + call add_default(apcnst (ixsnow), budget_histfile, ' ') + call add_default(bpcnst (ixrain), budget_histfile, ' ') + call add_default(bpcnst (ixsnow), budget_histfile, ' ') + end if + + end if + + ! physics buffer indices + ast_idx = pbuf_get_index('AST') + cld_idx = pbuf_get_index('CLD') + concld_idx = pbuf_get_index('CONCLD') + + naai_idx = pbuf_get_index('NAAI') + naai_hom_idx = pbuf_get_index('NAAI_HOM') + npccn_idx = pbuf_get_index('NPCCN') + rndst_idx = pbuf_get_index('RNDST') + nacon_idx = pbuf_get_index('NACON') + + prec_str_idx = pbuf_get_index('PREC_STR') + snow_str_idx = pbuf_get_index('SNOW_STR') + prec_sed_idx = pbuf_get_index('PREC_SED') + snow_sed_idx = pbuf_get_index('SNOW_SED') + prec_pcw_idx = pbuf_get_index('PREC_PCW') + snow_pcw_idx = pbuf_get_index('SNOW_PCW') + + cmeliq_idx = pbuf_get_index('CMELIQ') + + ! These fields may have been added, so don't abort if they have not been + qrain_idx = pbuf_get_index('QRAIN', ierr) + qsnow_idx = pbuf_get_index('QSNOW', ierr) + nrain_idx = pbuf_get_index('NRAIN', ierr) + nsnow_idx = pbuf_get_index('NSNOW', ierr) + + ! fields for heterogeneous freezing + frzimm_idx = pbuf_get_index('FRZIMM', ierr) + frzcnt_idx = pbuf_get_index('FRZCNT', ierr) + frzdep_idx = pbuf_get_index('FRZDEP', ierr) ! Initialize physics buffer grid fields for accumulating precip and condensation - if (is_first_step()) then - call pbuf_set_field(pbuf2d, cldo_idx, 0._r8) - call pbuf_set_field(pbuf2d, cc_t_idx, 0._r8) - call pbuf_set_field(pbuf2d, cc_qv_idx, 0._r8) - call pbuf_set_field(pbuf2d, cc_ql_idx, 0._r8) - call pbuf_set_field(pbuf2d, cc_qi_idx, 0._r8) - call pbuf_set_field(pbuf2d, cc_nl_idx, 0._r8) - call pbuf_set_field(pbuf2d, cc_ni_idx, 0._r8) - call pbuf_set_field(pbuf2d, cc_qlst_idx,0._r8) - call pbuf_set_field(pbuf2d, acpr_idx, 0._r8) - call pbuf_set_field(pbuf2d, acgcme_idx, 0._r8) - call pbuf_set_field(pbuf2d, acnum_idx, 0) - call pbuf_set_field(pbuf2d, relvar_idx, 2._r8) - call pbuf_set_field(pbuf2d, accre_enhan_idx, 1._r8) - - if (qrain_idx > 0) call pbuf_set_field(pbuf2d, qrain_idx, 0._r8) - if (qsnow_idx > 0) call pbuf_set_field(pbuf2d, qsnow_idx, 0._r8) - if (nrain_idx > 0) call pbuf_set_field(pbuf2d, nrain_idx, 0._r8) - if (nsnow_idx > 0) call pbuf_set_field(pbuf2d, nsnow_idx, 0._r8) - - ! If sub-columns turned on, need to set the sub-column fields as well - if (use_subcol_microp) then - call pbuf_set_field(pbuf2d, cldo_idx, 0._r8, col_type=col_type_subcol) - call pbuf_set_field(pbuf2d, cc_t_idx, 0._r8, col_type=col_type_subcol) - call pbuf_set_field(pbuf2d, cc_qv_idx, 0._r8, col_type=col_type_subcol) - call pbuf_set_field(pbuf2d, cc_ql_idx, 0._r8, col_type=col_type_subcol) - call pbuf_set_field(pbuf2d, cc_qi_idx, 0._r8, col_type=col_type_subcol) - call pbuf_set_field(pbuf2d, cc_nl_idx, 0._r8, col_type=col_type_subcol) - call pbuf_set_field(pbuf2d, cc_ni_idx, 0._r8, col_type=col_type_subcol) - call pbuf_set_field(pbuf2d, cc_qlst_idx,0._r8, col_type=col_type_subcol) - end if - - end if + if (is_first_step()) then + call pbuf_set_field(pbuf2d, cldo_idx, 0._r8) + call pbuf_set_field(pbuf2d, cc_t_idx, 0._r8) + call pbuf_set_field(pbuf2d, cc_qv_idx, 0._r8) + call pbuf_set_field(pbuf2d, cc_ql_idx, 0._r8) + call pbuf_set_field(pbuf2d, cc_qi_idx, 0._r8) + call pbuf_set_field(pbuf2d, cc_nl_idx, 0._r8) + call pbuf_set_field(pbuf2d, cc_ni_idx, 0._r8) + call pbuf_set_field(pbuf2d, cc_qlst_idx,0._r8) + call pbuf_set_field(pbuf2d, acpr_idx, 0._r8) + call pbuf_set_field(pbuf2d, acgcme_idx, 0._r8) + call pbuf_set_field(pbuf2d, acnum_idx, 0) + call pbuf_set_field(pbuf2d, relvar_idx, 2._r8) + call pbuf_set_field(pbuf2d, accre_enhan_idx, 1._r8) + call pbuf_set_field(pbuf2d, am_evp_st_idx, 0._r8) + call pbuf_set_field(pbuf2d, evprain_st_idx, 0._r8) + call pbuf_set_field(pbuf2d, evpsnow_st_idx, 0._r8) + call pbuf_set_field(pbuf2d, prer_evap_idx, 0._r8) + + if (qrain_idx > 0) call pbuf_set_field(pbuf2d, qrain_idx, 0._r8) + if (qsnow_idx > 0) call pbuf_set_field(pbuf2d, qsnow_idx, 0._r8) + if (nrain_idx > 0) call pbuf_set_field(pbuf2d, nrain_idx, 0._r8) + if (nsnow_idx > 0) call pbuf_set_field(pbuf2d, nsnow_idx, 0._r8) + + ! If sub-columns turned on, need to set the sub-column fields as well + if (use_subcol_microp) then + call pbuf_set_field(pbuf2d, cldo_idx, 0._r8, col_type=col_type_subcol) + call pbuf_set_field(pbuf2d, cc_t_idx, 0._r8, col_type=col_type_subcol) + call pbuf_set_field(pbuf2d, cc_qv_idx, 0._r8, col_type=col_type_subcol) + call pbuf_set_field(pbuf2d, cc_ql_idx, 0._r8, col_type=col_type_subcol) + call pbuf_set_field(pbuf2d, cc_qi_idx, 0._r8, col_type=col_type_subcol) + call pbuf_set_field(pbuf2d, cc_nl_idx, 0._r8, col_type=col_type_subcol) + call pbuf_set_field(pbuf2d, cc_ni_idx, 0._r8, col_type=col_type_subcol) + call pbuf_set_field(pbuf2d, cc_qlst_idx,0._r8, col_type=col_type_subcol) + end if + + end if end subroutine micro_mg_cam_init - !=============================================================================== subroutine micro_mg_cam_tend(state, ptend, dtime, pbuf) - use micro_mg_utils, only: size_dist_param_basic, size_dist_param_liq, & - mg_liq_props, mg_ice_props, avg_diameter, rhoi, rhosn, rhow, rhows, & - qsmall, mincld - use micro_mg1_0, only: micro_mg_tend1_0 => micro_mg_tend - use micro_mg1_5, only: micro_mg_tend1_5 => micro_mg_tend, & - micro_mg_get_cols1_5 => micro_mg_get_cols - - use ppgrid, only: pcols - use physics_buffer, only: pbuf_col_type_index - use subcol, only: subcol_field_avg - - type(physics_state), intent(in) :: state - type(physics_ptend), intent(out) :: ptend - real(r8), intent(in) :: dtime - type(physics_buffer_desc), pointer :: pbuf(:) - - ! Local variables - logical :: microp_uniform = .false. ! True = configure microphysics for sub-columns - ! False = use in regular mode w/o sub-columns - integer :: lchnk, ncol, psetcols, ngrdcol - - integer :: i, k, itim_old, it - - real(r8), pointer :: naai(:,:) ! ice nucleation number - real(r8), pointer :: naai_hom(:,:) ! ice nucleation number (homogeneous) - real(r8), pointer :: npccn(:,:) ! liquid activation number tendency - real(r8), pointer :: rndst(:,:,:) - real(r8), pointer :: nacon(:,:,:) - - real(r8), pointer :: prec_str(:) ! [Total] Sfc flux of precip from stratiform [ m/s ] - real(r8), pointer :: snow_str(:) ! [Total] Sfc flux of snow from stratiform [ m/s ] - real(r8), pointer :: prec_sed(:) ! Surface flux of total cloud water from sedimentation - real(r8), pointer :: snow_sed(:) ! Surface flux of cloud ice from sedimentation - real(r8), pointer :: prec_pcw(:) ! Sfc flux of precip from microphysics [ m/s ] - real(r8), pointer :: snow_pcw(:) ! Sfc flux of snow from microphysics [ m/s ] - - real(r8), pointer :: ast(:,:) ! Relative humidity cloud fraction - real(r8), pointer :: alst_mic(:,:) - real(r8), pointer :: aist_mic(:,:) - real(r8), pointer :: cldo(:,:) ! Old cloud fraction - real(r8), pointer :: nevapr(:,:) ! Evaporation of total precipitation (rain + snow) - real(r8), pointer :: relvar(:,:) ! relative variance of cloud water - real(r8), pointer :: accre_enhan(:,:) ! optional accretion enhancement for experimentation - real(r8), pointer :: prain(:,:) ! Total precipitation (rain + snow) - real(r8), pointer :: dei(:,:) ! Ice effective diameter (meters) (AG: microns?) - real(r8), pointer :: mu(:,:) ! Size distribution shape parameter for radiation - real(r8), pointer :: lambdac(:,:) ! Size distribution slope parameter for radiation - real(r8), pointer :: des(:,:) ! Snow effective diameter (m) - - real(r8) :: rho(state%psetcols,pver) - real(r8) :: ncic(state%psetcols,pver) - real(r8) :: niic(state%psetcols,pver) - - real(r8) :: rate1cld(state%psetcols,pver) ! array to hold rate1ord_cw2pr_st from microphysics - - real(r8) :: tlat(state%psetcols,pver) - real(r8) :: qvlat(state%psetcols,pver) - real(r8) :: qcten(state%psetcols,pver) - real(r8) :: qiten(state%psetcols,pver) - real(r8) :: ncten(state%psetcols,pver) - real(r8) :: niten(state%psetcols,pver) - real(r8) :: prect(state%psetcols) - real(r8) :: preci(state%psetcols) - - - real(r8) :: evapsnow(state%psetcols,pver) ! Local evaporation of snow - real(r8) :: prodsnow(state%psetcols,pver) ! Local production of snow - real(r8) :: cmeice(state%psetcols,pver) ! Rate of cond-evap of ice within the cloud - real(r8) :: qsout(state%psetcols,pver) ! Snow mixing ratio - real(r8) :: rflx(state%psetcols,pver+1) ! grid-box average rain flux (kg m^-2 s^-1) - real(r8) :: sflx(state%psetcols,pver+1) ! grid-box average snow flux (kg m^-2 s^-1) - real(r8) :: qrout(state%psetcols,pver) ! Rain mixing ratio - real(r8) :: reff_rain(state%psetcols,pver) ! rain effective radius (um) - real(r8) :: reff_snow(state%psetcols,pver) ! snow effective radius (um) - real(r8) :: qcsevap(state%psetcols,pver) ! Evaporation of falling cloud water - real(r8) :: qisevap(state%psetcols,pver) ! Sublimation of falling cloud ice - real(r8) :: qvres(state%psetcols,pver) ! Residual condensation term to remove excess saturation - real(r8) :: cmeiout(state%psetcols,pver) ! Deposition/sublimation rate of cloud ice - real(r8) :: vtrmc(state%psetcols,pver) ! Mass-weighted cloud water fallspeed - real(r8) :: vtrmi(state%psetcols,pver) ! Mass-weighted cloud ice fallspeed - real(r8) :: qcsedten(state%psetcols,pver) ! Cloud water mixing ratio tendency from sedimentation - real(r8) :: qisedten(state%psetcols,pver) ! Cloud ice mixing ratio tendency from sedimentation - real(r8) :: prao(state%psetcols,pver) - real(r8) :: prco(state%psetcols,pver) - real(r8) :: mnuccco(state%psetcols,pver) - real(r8) :: mnuccto(state%psetcols,pver) - real(r8) :: msacwio(state%psetcols,pver) - real(r8) :: psacwso(state%psetcols,pver) - real(r8) :: bergso(state%psetcols,pver) - real(r8) :: bergo(state%psetcols,pver) - real(r8) :: melto(state%psetcols,pver) - real(r8) :: homoo(state%psetcols,pver) - real(r8) :: qcreso(state%psetcols,pver) - real(r8) :: prcio(state%psetcols,pver) - real(r8) :: praio(state%psetcols,pver) - real(r8) :: qireso(state%psetcols,pver) - real(r8) :: mnuccro(state%psetcols,pver) - real(r8) :: pracso (state%psetcols,pver) - real(r8) :: meltsdt(state%psetcols,pver) - real(r8) :: frzrdt (state%psetcols,pver) - real(r8) :: mnuccdo(state%psetcols,pver) - real(r8) :: nrout(state%psetcols,pver) - real(r8) :: nsout(state%psetcols,pver) - real(r8) :: refl(state%psetcols,pver) ! analytic radar reflectivity - real(r8) :: arefl(state%psetcols,pver) !average reflectivity will zero points outside valid range - real(r8) :: areflz(state%psetcols,pver) !average reflectivity in z. - real(r8) :: frefl(state%psetcols,pver) - real(r8) :: csrfl(state%psetcols,pver) !cloudsat reflectivity - real(r8) :: acsrfl(state%psetcols,pver) !cloudsat average - real(r8) :: fcsrfl(state%psetcols,pver) - real(r8) :: rercld(state%psetcols,pver) ! effective radius calculation for rain + cloud - real(r8) :: ncai(state%psetcols,pver) ! output number conc of ice nuclei available (1/m3) - real(r8) :: ncal(state%psetcols,pver) ! output number conc of CCN (1/m3) - real(r8) :: qrout2(state%psetcols,pver) - real(r8) :: qsout2(state%psetcols,pver) - real(r8) :: nrout2(state%psetcols,pver) - real(r8) :: nsout2(state%psetcols,pver) - real(r8) :: drout2(state%psetcols,pver) ! mean rain particle diameter (m) - real(r8) :: dsout2(state%psetcols,pver) ! mean snow particle diameter (m) - real(r8) :: freqs(state%psetcols,pver) - real(r8) :: freqr(state%psetcols,pver) - real(r8) :: nfice(state%psetcols,pver) - - real(r8) :: mnuccdohet(state%psetcols,pver) - - ! physics buffer fields for COSP simulator - real(r8), pointer :: mgflxprc(:,:) ! MG grid-box mean flux_large_scale_cloud_rain+snow at interfaces (kg/m2/s) - real(r8), pointer :: mgflxsnw(:,:) ! MG grid-box mean flux_large_scale_cloud_snow at interfaces (kg/m2/s) - real(r8), pointer :: mgmrprc(:,:) ! MG grid-box mean mixingratio_large_scale_cloud_rain+snow at interfaces (kg/kg) - real(r8), pointer :: mgmrsnw(:,:) ! MG grid-box mean mixingratio_large_scale_cloud_snow at interfaces (kg/kg) - real(r8), pointer :: mgreffrain_grid(:,:) ! MG diagnostic rain effective radius (um) - real(r8), pointer :: mgreffsnow_grid(:,:) ! MG diagnostic snow effective radius (um) - real(r8), pointer :: cvreffliq(:,:) ! convective cloud liquid effective radius (um) - real(r8), pointer :: cvreffice(:,:) ! convective cloud ice effective radius (um) - - ! physics buffer fields used with CARMA - real(r8), pointer, dimension(:,:) :: tnd_qsnow ! external tendency on snow mass (kg/kg/s) - real(r8), pointer, dimension(:,:) :: tnd_nsnow ! external tendency on snow number(#/kg/s) - real(r8), pointer, dimension(:,:) :: re_ice ! ice effective radius (m) - - real(r8), pointer :: rate1ord_cw2pr_st(:,:) ! 1st order rate for direct conversion of - ! strat. cloud water to precip (1/s) ! rce 2010/05/01 - real(r8), pointer :: wsedl(:,:) ! Sedimentation velocity of liquid stratus cloud droplet [ m/s ] - - - real(r8), pointer :: CC_T(:,:) ! Grid-mean microphysical tendency - real(r8), pointer :: CC_qv(:,:) ! Grid-mean microphysical tendency - real(r8), pointer :: CC_ql(:,:) ! Grid-mean microphysical tendency - real(r8), pointer :: CC_qi(:,:) ! Grid-mean microphysical tendency - real(r8), pointer :: CC_nl(:,:) ! Grid-mean microphysical tendency - real(r8), pointer :: CC_ni(:,:) ! Grid-mean microphysical tendency - real(r8), pointer :: CC_qlst(:,:) ! In-liquid stratus microphysical tendency - - real(r8), pointer :: qme(:,:) - - ! A local copy of state is used for diagnostic calculations - type(physics_state) :: state_loc - type(physics_ptend) :: ptend_loc - - real(r8) :: icecldf(state%psetcols,pver) ! Ice cloud fraction - real(r8) :: liqcldf(state%psetcols,pver) ! Liquid cloud fraction (combined into cloud) - - real(r8), pointer :: rel(:,:) ! Liquid effective drop radius (microns) - real(r8), pointer :: rei(:,:) ! Ice effective drop size (microns) - real(r8) :: rel_fn(state%psetcols,pver) ! Ice effective drop size at fixed number (indirect effect) (microns) - - ! in-cloud water quantities adjusted for convective water - real(r8) :: allcld_ice(state%psetcols,pver) ! All-cloud cloud ice - real(r8) :: allcld_liq(state%psetcols,pver) ! All-cloud liquid - - real(r8), pointer :: cmeliq(:,:) - - real(r8), pointer :: cld(:,:) ! Total cloud fraction - real(r8), pointer :: concld(:,:) ! Convective cloud fraction - real(r8), pointer :: iciwpst(:,:) ! Stratiform in-cloud ice water path for radiation - real(r8), pointer :: iclwpst(:,:) ! Stratiform in-cloud liquid water path for radiation - real(r8), pointer :: cldfsnow(:,:) ! Cloud fraction for liquid+snow - real(r8), pointer :: icswp(:,:) ! In-cloud snow water path - - real(r8) :: icimrst(state%psetcols,pver) ! In stratus ice mixing ratio - real(r8) :: icwmrst(state%psetcols,pver) ! In stratus water mixing ratio - real(r8) :: icinc(state%psetcols,pver) ! In cloud ice number conc - real(r8) :: icwnc(state%psetcols,pver) ! In cloud water number conc - - real(r8) :: iclwpi(state%psetcols) ! Vertically-integrated in-cloud Liquid WP before microphysics - real(r8) :: iciwpi(state%psetcols) ! Vertically-integrated in-cloud Ice WP before microphysics - - ! Averaging arrays for effective radius and number.... - real(r8) :: efiout_grid(pcols,pver) - real(r8) :: efcout_grid(pcols,pver) - real(r8) :: ncout_grid(pcols,pver) - real(r8) :: niout_grid(pcols,pver) - real(r8) :: freqi_grid(pcols,pver) - real(r8) :: freql_grid(pcols,pver) - - real(r8) :: cdnumc_grid(pcols) ! Vertically-integrated droplet concentration - real(r8) :: icecldf_grid_out(pcols,pver) ! Ice cloud fraction - real(r8) :: liqcldf_grid_out(pcols,pver) ! Liquid cloud fraction (combined into cloud) - real(r8) :: icimrst_grid_out(pcols,pver) ! In stratus ice mixing ratio - real(r8) :: icwmrst_grid_out(pcols,pver) ! In stratus water mixing ratio - - ! Average cloud top radius & number - real(r8) :: ctrel_grid(pcols) - real(r8) :: ctrei_grid(pcols) - real(r8) :: ctnl_grid(pcols) - real(r8) :: ctni_grid(pcols) - real(r8) :: fcti_grid(pcols) - real(r8) :: fctl_grid(pcols) - - real(r8) :: ftem_grid(pcols,pver) - - ! Variables for precip efficiency calculation - real(r8) :: minlwp ! LWP threshold - - real(r8), pointer, dimension(:) :: acprecl_grid ! accumulated precip across timesteps - real(r8), pointer, dimension(:) :: acgcme_grid ! accumulated condensation across timesteps - integer, pointer, dimension(:) :: acnum_grid ! counter for # timesteps accumulated - - ! Variables for liquid water path and column condensation - real(r8) :: tgliqwp_grid(pcols) ! column liquid - real(r8) :: tgcmeliq_grid(pcols) ! column condensation rate (units) - - real(r8) :: pe_grid(pcols) ! precip efficiency for output - real(r8) :: pefrac_grid(pcols) ! fraction of time precip efficiency is written out - real(r8) :: tpr_grid(pcols) ! average accumulated precipitation rate in pe calculation - - ! variables for autoconversion and accretion vertical averages - real(r8) :: vprco_grid(pcols) ! vertical average autoconversion - real(r8) :: vprao_grid(pcols) ! vertical average accretion - real(r8) :: racau_grid(pcols) ! ratio of vertical averages - integer :: cnt_grid(pcols) ! counters - logical :: lq(pcnst) - - real(r8) :: qc(state%psetcols,pver) ! cloud water mixing ratio (kg/kg) - real(r8) :: qi(state%psetcols,pver) ! cloud ice mixing ratio (kg/kg) - real(r8) :: nc(state%psetcols,pver) ! cloud water number conc (1/kg) - real(r8) :: ni(state%psetcols,pver) ! cloud ice number conc (1/kg) - - real(r8) :: icimrst_grid(pcols,pver) ! stratus ice mixing ratio - on grid - real(r8) :: icwmrst_grid(pcols,pver) ! stratus water mixing ratio - on grid - - real(r8),pointer :: lambdac_grid(:,:) - real(r8),pointer :: mu_grid(:,:) - real(r8),pointer :: rel_grid(:,:) - real(r8),pointer :: rei_grid(:,:) - real(r8),pointer :: dei_grid(:,:) - real(r8),pointer :: des_grid(:,:) - real(r8),pointer :: iclwpst_grid(:,:) - - real(r8) :: rho_grid(pcols,pver) - real(r8) :: liqcldf_grid(pcols,pver) - real(r8) :: qsout_grid(pcols,pver) - real(r8) :: ncic_grid(pcols,pver) - real(r8) :: niic_grid(pcols,pver) - real(r8) :: rel_fn_grid(pcols,pver) ! Ice effective drop size at fixed number (indirect effect) (microns) - on grid - real(r8) :: qrout_grid(pcols,pver) - real(r8) :: drout2_grid(pcols,pver) - real(r8) :: dsout2_grid(pcols,pver) - real(r8) :: nsout_grid(pcols,pver) - real(r8) :: nrout_grid(pcols,pver) - real(r8) :: reff_rain_grid(pcols,pver) - real(r8) :: reff_snow_grid(pcols,pver) - real(r8) :: cld_grid(pcols,pver) - real(r8) :: pdel_grid(pcols,pver) - real(r8) :: prco_grid(pcols,pver) - real(r8) :: prao_grid(pcols,pver) - real(r8) :: q_ixnumliq_grid(pcols,pver) - real(r8) :: icecldf_grid(pcols,pver) - real(r8) :: icwnc_grid(pcols,pver) - real(r8) :: icinc_grid(pcols,pver) - real(r8) :: qcreso_grid(pcols,pver) - real(r8) :: melto_grid(pcols,pver) - real(r8) :: mnuccco_grid(pcols,pver) - real(r8) :: mnuccto_grid(pcols,pver) - real(r8) :: bergo_grid(pcols,pver) - real(r8) :: homoo_grid(pcols,pver) - real(r8) :: msacwio_grid(pcols,pver) - real(r8) :: psacwso_grid(pcols,pver) - real(r8) :: bergso_grid(pcols,pver) - real(r8) :: cmeiout_grid(pcols,pver) - real(r8) :: qireso_grid(pcols,pver) - real(r8) :: prcio_grid(pcols,pver) - real(r8) :: praio_grid(pcols,pver) - - real(r8),pointer :: cmeliq_grid(:,:) - - real(r8),pointer :: prec_str_grid(:) - real(r8),pointer :: snow_str_grid(:) - real(r8),pointer :: prec_pcw_grid(:) - real(r8),pointer :: snow_pcw_grid(:) - real(r8),pointer :: prec_sed_grid(:) - real(r8),pointer :: snow_sed_grid(:) - real(r8),pointer :: cldo_grid(:,:) - real(r8),pointer :: nevapr_grid(:,:) - real(r8),pointer :: prain_grid(:,:) - real(r8),pointer :: mgflxprc_grid(:,:) - real(r8),pointer :: mgflxsnw_grid(:,:) - real(r8),pointer :: mgmrprc_grid(:,:) - real(r8),pointer :: mgmrsnw_grid(:,:) - real(r8),pointer :: cvreffliq_grid(:,:) - real(r8),pointer :: cvreffice_grid(:,:) - real(r8),pointer :: rate1ord_cw2pr_st_grid(:,:) - real(r8),pointer :: wsedl_grid(:,:) - real(r8),pointer :: CC_t_grid(:,:) - real(r8),pointer :: CC_qv_grid(:,:) - real(r8),pointer :: CC_ql_grid(:,:) - real(r8),pointer :: CC_qi_grid(:,:) - real(r8),pointer :: CC_nl_grid(:,:) - real(r8),pointer :: CC_ni_grid(:,:) - real(r8),pointer :: CC_qlst_grid(:,:) - real(r8),pointer :: qme_grid(:,:) - real(r8),pointer :: iciwpst_grid(:,:) - real(r8),pointer :: icswp_grid(:,:) - real(r8),pointer :: ast_grid(:,:) - real(r8),pointer :: cldfsnow_grid(:,:) - - real(r8),pointer :: qrout_grid_ptr(:,:) - real(r8),pointer :: qsout_grid_ptr(:,:) - real(r8),pointer :: nrout_grid_ptr(:,:) - real(r8),pointer :: nsout_grid_ptr(:,:) - - - integer :: nlev ! number of levels where cloud physics is done - integer :: mgncol ! size of mgcols - integer :: col_type ! Flag to store whether accessing grid or sub-columns in pbuf_get_field - integer, allocatable :: mgcols(:) ! Columns with microphysics performed - - logical :: use_subcol_microp - - character(128) :: errstring ! return status (non-blank for error return) - - ! For rrtmg optics specified distribution. - real(r8), parameter :: dcon = 25.e-6_r8 ! Convective size distribution effective radius (meters) - real(r8), parameter :: mucon = 5.3_r8 ! Convective size distribution shape parameter - real(r8), parameter :: deicon = 50._r8 ! Convective ice effective diameter (meters) - - !------------------------------------------------------------------------------- - - ! Find the number of levels used in the microphysics. - nlev = pver - top_lev + 1 - - lchnk = state%lchnk - ncol = state%ncol - psetcols = state%psetcols - ngrdcol = state%ngrdcol - - itim_old = pbuf_old_tim_idx() - - call phys_getopts(use_subcol_microp_out = use_subcol_microp) - - ! Set the col_type flag to grid or subcolumn dependent on the value of use_subcol_microp - call pbuf_col_type_index(use_subcol_microp, col_type=col_type) - - !----------------------- - ! These physics buffer fields are read only and not set in this parameterization - ! If these fields do not have subcolumn data, copy the grid to the subcolumn if subcolumns is turned on - ! If subcolumns is not turned on, then these fields will be grid data - - call pbuf_get_field(pbuf, naai_idx, naai, col_type=col_type, copy_if_needed=use_subcol_microp) - call pbuf_get_field(pbuf, naai_hom_idx, naai_hom, col_type=col_type, copy_if_needed=use_subcol_microp) - call pbuf_get_field(pbuf, npccn_idx, npccn, col_type=col_type, copy_if_needed=use_subcol_microp) - call pbuf_get_field(pbuf, rndst_idx, rndst, col_type=col_type, copy_if_needed=use_subcol_microp) - call pbuf_get_field(pbuf, nacon_idx, nacon, col_type=col_type, copy_if_needed=use_subcol_microp) - call pbuf_get_field(pbuf, tnd_qsnow_idx, tnd_qsnow, col_type=col_type, copy_if_needed=use_subcol_microp) - call pbuf_get_field(pbuf, tnd_nsnow_idx, tnd_nsnow, col_type=col_type, copy_if_needed=use_subcol_microp) - call pbuf_get_field(pbuf, re_ice_idx, re_ice, col_type=col_type, copy_if_needed=use_subcol_microp) - call pbuf_get_field(pbuf, relvar_idx, relvar, col_type=col_type, copy_if_needed=use_subcol_microp) - call pbuf_get_field(pbuf, accre_enhan_idx, accre_enhan, col_type=col_type, copy_if_needed=use_subcol_microp) - call pbuf_get_field(pbuf, cmeliq_idx, cmeliq, col_type=col_type, copy_if_needed=use_subcol_microp) - - call pbuf_get_field(pbuf, cld_idx, cld, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), & - col_type=col_type, copy_if_needed=use_subcol_microp) - call pbuf_get_field(pbuf, concld_idx, concld, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), & - col_type=col_type, copy_if_needed=use_subcol_microp) - call pbuf_get_field(pbuf, ast_idx, ast, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), & - col_type=col_type, copy_if_needed=use_subcol_microp) - - !----------------------- - ! These physics buffer fields are calculated and set in this parameterization - ! If subcolumns is turned on, then these fields will be calculated on a subcolumn grid, otherwise they will be a normal grid - - call pbuf_get_field(pbuf, prec_str_idx, prec_str, col_type=col_type) - call pbuf_get_field(pbuf, snow_str_idx, snow_str, col_type=col_type) - call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw, col_type=col_type) - call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw, col_type=col_type) - call pbuf_get_field(pbuf, prec_sed_idx, prec_sed, col_type=col_type) - call pbuf_get_field(pbuf, snow_sed_idx, snow_sed, col_type=col_type) - call pbuf_get_field(pbuf, nevapr_idx, nevapr, col_type=col_type) - call pbuf_get_field(pbuf, prain_idx, prain, col_type=col_type) - call pbuf_get_field(pbuf, dei_idx, dei, col_type=col_type) - call pbuf_get_field(pbuf, mu_idx, mu, col_type=col_type) - call pbuf_get_field(pbuf, lambdac_idx, lambdac, col_type=col_type) - call pbuf_get_field(pbuf, des_idx, des, col_type=col_type) - call pbuf_get_field(pbuf, ls_flxprc_idx, mgflxprc, col_type=col_type) - call pbuf_get_field(pbuf, ls_flxsnw_idx, mgflxsnw, col_type=col_type) - call pbuf_get_field(pbuf, ls_mrprc_idx, mgmrprc, col_type=col_type) - call pbuf_get_field(pbuf, ls_mrsnw_idx, mgmrsnw, col_type=col_type) - call pbuf_get_field(pbuf, cv_reffliq_idx, cvreffliq, col_type=col_type) - call pbuf_get_field(pbuf, cv_reffice_idx, cvreffice, col_type=col_type) - call pbuf_get_field(pbuf, iciwpst_idx, iciwpst, col_type=col_type) - call pbuf_get_field(pbuf, iclwpst_idx, iclwpst, col_type=col_type) - call pbuf_get_field(pbuf, icswp_idx, icswp, col_type=col_type) - call pbuf_get_field(pbuf, rel_idx, rel, col_type=col_type) - call pbuf_get_field(pbuf, rei_idx, rei, col_type=col_type) - call pbuf_get_field(pbuf, wsedl_idx, wsedl, col_type=col_type) - call pbuf_get_field(pbuf, qme_idx, qme, col_type=col_type) - - call pbuf_get_field(pbuf, cldo_idx, cldo, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) - call pbuf_get_field(pbuf, cldfsnow_idx, cldfsnow, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) - call pbuf_get_field(pbuf, cc_t_idx, CC_t, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type ) - call pbuf_get_field(pbuf, cc_qv_idx, CC_qv, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type ) - call pbuf_get_field(pbuf, cc_ql_idx, CC_ql, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type ) - call pbuf_get_field(pbuf, cc_qi_idx, CC_qi, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type ) - call pbuf_get_field(pbuf, cc_nl_idx, CC_nl, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type ) - call pbuf_get_field(pbuf, cc_ni_idx, CC_ni, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type ) - call pbuf_get_field(pbuf, cc_qlst_idx, CC_qlst, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type ) - - if (rate1_cw2pr_st_idx > 0) then - call pbuf_get_field(pbuf, rate1_cw2pr_st_idx, rate1ord_cw2pr_st, col_type=col_type) - end if - - if (qrain_idx > 0) call pbuf_get_field(pbuf, qrain_idx, qrout_grid_ptr) - if (qsnow_idx > 0) call pbuf_get_field(pbuf, qsnow_idx, qsout_grid_ptr) - if (nrain_idx > 0) call pbuf_get_field(pbuf, nrain_idx, nrout_grid_ptr) - if (nsnow_idx > 0) call pbuf_get_field(pbuf, nsnow_idx, nsout_grid_ptr) - - !----------------------- - ! If subcolumns is turned on, all calculated fields which are on subcolumns - ! need to be retrieved on the grid as well for storing averaged values - - if (use_subcol_microp) then - call pbuf_get_field(pbuf, prec_str_idx, prec_str_grid) - call pbuf_get_field(pbuf, snow_str_idx, snow_str_grid) - call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw_grid) - call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw_grid) - call pbuf_get_field(pbuf, prec_sed_idx, prec_sed_grid) - call pbuf_get_field(pbuf, snow_sed_idx, snow_sed_grid) - call pbuf_get_field(pbuf, nevapr_idx, nevapr_grid) - call pbuf_get_field(pbuf, prain_idx, prain_grid) - call pbuf_get_field(pbuf, dei_idx, dei_grid) - call pbuf_get_field(pbuf, mu_idx, mu_grid) - call pbuf_get_field(pbuf, lambdac_idx, lambdac_grid) - call pbuf_get_field(pbuf, des_idx, des_grid) - call pbuf_get_field(pbuf, ls_flxprc_idx, mgflxprc_grid) - call pbuf_get_field(pbuf, ls_flxsnw_idx, mgflxsnw_grid) - call pbuf_get_field(pbuf, ls_mrprc_idx, mgmrprc_grid) - call pbuf_get_field(pbuf, ls_mrsnw_idx, mgmrsnw_grid) - call pbuf_get_field(pbuf, cv_reffliq_idx, cvreffliq_grid) - call pbuf_get_field(pbuf, cv_reffice_idx, cvreffice_grid) - call pbuf_get_field(pbuf, iciwpst_idx, iciwpst_grid) - call pbuf_get_field(pbuf, iclwpst_idx, iclwpst_grid) - call pbuf_get_field(pbuf, icswp_idx, icswp_grid) - call pbuf_get_field(pbuf, rel_idx, rel_grid) - call pbuf_get_field(pbuf, rei_idx, rei_grid) - call pbuf_get_field(pbuf, wsedl_idx, wsedl_grid) - call pbuf_get_field(pbuf, qme_idx, qme_grid) - - call pbuf_get_field(pbuf, cldo_idx, cldo_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - call pbuf_get_field(pbuf, cldfsnow_idx, cldfsnow_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - call pbuf_get_field(pbuf, cc_t_idx, CC_t_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - call pbuf_get_field(pbuf, cc_qv_idx, CC_qv_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - call pbuf_get_field(pbuf, cc_ql_idx, CC_ql_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - call pbuf_get_field(pbuf, cc_qi_idx, CC_qi_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - call pbuf_get_field(pbuf, cc_nl_idx, CC_nl_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - call pbuf_get_field(pbuf, cc_ni_idx, CC_ni_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - call pbuf_get_field(pbuf, cc_qlst_idx, CC_qlst_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - - if (rate1_cw2pr_st_idx > 0) then - call pbuf_get_field(pbuf, rate1_cw2pr_st_idx, rate1ord_cw2pr_st_grid) - end if - - end if - - !----------------------- - ! These are only on the grid regardless of whether subcolumns are turned on or not - call pbuf_get_field(pbuf, ls_reffrain_idx, mgreffrain_grid) - call pbuf_get_field(pbuf, ls_reffsnow_idx, mgreffsnow_grid) - call pbuf_get_field(pbuf, acpr_idx, acprecl_grid) - call pbuf_get_field(pbuf, acgcme_idx, acgcme_grid) - call pbuf_get_field(pbuf, acnum_idx, acnum_grid) - call pbuf_get_field(pbuf, cmeliq_idx, cmeliq_grid) - call pbuf_get_field(pbuf, ast_idx, ast_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - - - !------------------------------------------------------------------------------------- - ! Microphysics assumes 'liquid stratus frac = ice stratus frac - ! = max( liquid stratus frac, ice stratus frac )'. - alst_mic => ast - aist_mic => ast - - ! Output initial in-cloud LWP (before microphysics) - - iclwpi = 0._r8 - iciwpi = 0._r8 - - do i = 1, ncol - do k = top_lev, pver - iclwpi(i) = iclwpi(i) + & - min(state%q(i,k,ixcldliq) / max(mincld,ast(i,k)),0.005_r8) & - * state%pdel(i,k) / gravit - iciwpi(i) = iciwpi(i) + & - min(state%q(i,k,ixcldice) / max(mincld,ast(i,k)),0.005_r8) & - * state%pdel(i,k) / gravit - end do - end do - - cldo(:ncol,top_lev:pver)=ast(:ncol,top_lev:pver) - - ! Initialize local state from input. - call physics_state_copy(state, state_loc) - - ! Initialize ptend for output. - lq = .false. - lq(1) = .true. - lq(ixcldliq) = .true. - lq(ixcldice) = .true. - lq(ixnumliq) = .true. - lq(ixnumice) = .true. - - ! the name 'cldwat' triggers special tests on cldliq - ! and cldice in physics_update - call physics_ptend_init(ptend, psetcols, "cldwat", ls=.true., lq=lq) - - select case (micro_mg_version) - case (1) - select case (micro_mg_sub_version) - case (0) - - qc = state_loc%q(:,:,ixcldliq) - qi = state_loc%q(:,:,ixcldice) - nc = state_loc%q(:,:,ixnumliq) - ni = state_loc%q(:,:,ixnumice) - - call micro_mg_tend1_0( & - microp_uniform, psetcols, pver, ncol, top_lev, dtime, & - state_loc%t, state_loc%q(:,:,1), qc, qi, nc, & - ni, state_loc%pmid, state_loc%pdel, ast, alst_mic,& - relvar, accre_enhan, & - aist_mic, rate1cld, naai, npccn, & - rndst, nacon, tlat, qvlat, qcten, & - qiten, ncten, niten, rel, rel_fn, & - rei, prect, preci, nevapr, evapsnow, & - prain, prodsnow, cmeice, dei, mu, & - lambdac, qsout, des, rflx, sflx, & - qrout, reff_rain, reff_snow, qcsevap, qisevap, & - qvres, cmeiout, vtrmc, vtrmi, qcsedten, & - qisedten, prao, prco, mnuccco, mnuccto, & - msacwio, psacwso, bergso, bergo, melto, & - homoo, qcreso, prcio, praio, qireso, & - mnuccro, pracso, meltsdt, frzrdt, mnuccdo, & - nrout, nsout, refl, arefl, areflz, & - frefl, csrfl, acsrfl, fcsrfl, rercld, & - ncai, ncal, qrout2, qsout2, nrout2, & - nsout2, drout2, dsout2, freqs, freqr, & - nfice, do_cldice, tnd_qsnow, & - tnd_nsnow, re_ice, errstring) - - - case (5) - - call micro_mg_get_cols1_5(ncol, nlev, top_lev, state%q(:,:,ixcldliq), & - state%q(:,:,ixcldice), mgncol, mgcols) - - call micro_mg_tend1_5( & - mgncol, mgcols, nlev, top_lev, dtime, & - state_loc%t, state_loc%q(:,:,1), & - state_loc%q(:,:,ixcldliq), state_loc%q(:,:,ixcldice), & - state_loc%q(:,:,ixnumliq), state_loc%q(:,:,ixnumice), & - relvar, accre_enhan, & - state_loc%pmid, state_loc%pdel, state_loc%pint, & - ast, alst_mic, aist_mic, & - rate1cld, naai, npccn, rndst, nacon, & - tlat, qvlat, qcten, qiten, ncten, niten, & - rel, rel_fn, rei, prect, preci, & - nevapr, evapsnow, prain, prodsnow, cmeice, dei, & - mu, lambdac, qsout, des, rflx, sflx, & - qrout, reff_rain, reff_snow, & - qcsevap, qisevap, qvres, cmeiout, vtrmc, vtrmi, & - qcsedten, qisedten, prao, prco, mnuccco, mnuccto, & - msacwio, psacwso, bergso, bergo, melto, homoo, & - qcreso, prcio, praio, qireso, & - mnuccro, pracso, meltsdt, frzrdt, mnuccdo, & - nrout, nsout, refl, arefl, areflz, frefl, & - csrfl, acsrfl, fcsrfl, rercld, & - ncai, ncal, qrout2, qsout2, nrout2, nsout2, & - drout2, dsout2, freqs, freqr, nfice, & - tnd_qsnow, tnd_nsnow, re_ice, & - errstring) - - call handle_errmsg(errstring, subname="micro_mg_tend1_5") - end select - end select - - call handle_errmsg(errstring, subname="micro_mg_tend") - - call physics_ptend_init(ptend_loc, psetcols, "micro_mg", ls=.true., lq=lq) - - ! Set local tendency. - ptend_loc%s(:ncol,top_lev:pver) = tlat(:ncol,top_lev:pver) - ptend_loc%q(:ncol,top_lev:pver,1) = qvlat(:ncol,top_lev:pver) - ptend_loc%q(:ncol,top_lev:pver,ixcldliq) = qcten(:ncol,top_lev:pver) - ptend_loc%q(:ncol,top_lev:pver,ixcldice) = qiten(:ncol,top_lev:pver) - ptend_loc%q(:ncol,top_lev:pver,ixnumliq) = ncten(:ncol,top_lev:pver) - ptend_loc%q(:ncol,top_lev:pver,ixnumice) = niten(:ncol,top_lev:pver) - - ! Sum into overall ptend - call physics_ptend_sum(ptend_loc, ptend, ncol) - - ! Update local state - call physics_update(state_loc, ptend_loc, dtime) - - ! Check to make sure that the microphysics code is respecting the flags that control - ! whether MG should be prognosing cloud ice and cloud liquid or not. - if (.not. do_cldice) then - if (any(ptend%q(:ncol,top_lev:pver,ixcldice) /= 0.0_r8)) & - call endrun("micro_mg_cam:ERROR - MG microphysics is configured not to prognose cloud ice,"// & - " but micro_mg_tend has ice mass tendencies.") - if (any(ptend%q(:ncol,top_lev:pver,ixnumice) /= 0.0_r8)) & - call endrun("micro_mg_cam:ERROR - MG microphysics is configured not to prognose cloud ice,"// & - " but micro_mg_tend has ice number tendencies.") - end if - if (.not. do_cldliq) then - if (any(ptend%q(:ncol,top_lev:pver,ixcldliq) /= 0.0_r8)) & - call endrun("micro_mg_cam:ERROR - MG microphysics is configured not to prognose cloud liquid,"// & - " but micro_mg_tend has liquid mass tendencies.") - if (any(ptend%q(:ncol,top_lev:pver,ixnumliq) /= 0.0_r8)) & - call endrun("micro_mg_cam:ERROR - MG microphysics is configured not to prognose cloud liquid,"// & - " but micro_mg_tend has liquid number tendencies.") - end if - - - mnuccdohet = 0._r8 - do k=top_lev,pver - do i=1,ncol - if (naai(i,k) > 0._r8) then - mnuccdohet(i,k) = mnuccdo(i,k) - (naai_hom(i,k)/naai(i,k))*mnuccdo(i,k) - end if - end do - end do - - mgflxprc(:ncol,top_lev:pverp) = rflx(:ncol,top_lev:pverp) + sflx(:ncol,top_lev:pverp) - mgflxsnw(:ncol,top_lev:pverp) = sflx(:ncol,top_lev:pverp) - - mgmrprc(:ncol,top_lev:pver) = qrout(:ncol,top_lev:pver) + qsout(:ncol,top_lev:pver) - mgmrsnw(:ncol,top_lev:pver) = qsout(:ncol,top_lev:pver) - - !! calculate effective radius of convective liquid and ice using dcon and deicon (not used by code, not useful for COSP) - !! hard-coded as average of hard-coded values used for deep/shallow convective detrainment (near line 1502/1505) - cvreffliq(:ncol,top_lev:pver) = 9.0_r8 - cvreffice(:ncol,top_lev:pver) = 37.0_r8 - - - ! Reassign rate1 if modal aerosols - if (rate1_cw2pr_st_idx > 0) then - rate1ord_cw2pr_st(:ncol,top_lev:pver) = rate1cld(:ncol,top_lev:pver) - end if - - ! Sedimentation velocity for liquid stratus cloud droplet - wsedl(:ncol,top_lev:pver) = vtrmc(:ncol,top_lev:pver) - - ! Microphysical tendencies for use in the macrophysics at the next time step - CC_T(:ncol,top_lev:pver) = tlat(:ncol,top_lev:pver)/cpair - CC_qv(:ncol,top_lev:pver) = qvlat(:ncol,top_lev:pver) - CC_ql(:ncol,top_lev:pver) = qcten(:ncol,top_lev:pver) - CC_qi(:ncol,top_lev:pver) = qiten(:ncol,top_lev:pver) - CC_nl(:ncol,top_lev:pver) = ncten(:ncol,top_lev:pver) - CC_ni(:ncol,top_lev:pver) = niten(:ncol,top_lev:pver) - CC_qlst(:ncol,top_lev:pver) = qcten(:ncol,top_lev:pver)/max(0.01_r8,alst_mic(:ncol,top_lev:pver)) - - ! Net micro_mg_cam condensation rate - qme(:ncol,top_lev:pver) = cmeliq(:ncol,top_lev:pver) + cmeiout(:ncol,top_lev:pver) - - ! For precip, accumulate only total precip in prec_pcw and snow_pcw variables. - ! Other precip output variables are set to 0 - prec_pcw(:ncol) = prect(:ncol) - snow_pcw(:ncol) = preci(:ncol) - prec_sed(:ncol) = 0._r8 - snow_sed(:ncol) = 0._r8 - prec_str(:ncol) = prec_pcw(:ncol) + prec_sed(:ncol) - snow_str(:ncol) = snow_pcw(:ncol) + snow_sed(:ncol) - - icecldf(:ncol,top_lev:pver) = ast(:ncol,top_lev:pver) - liqcldf(:ncol,top_lev:pver) = ast(:ncol,top_lev:pver) - - - ! ------------------------------------------------------------ ! - ! Compute in cloud ice and liquid mixing ratios ! - ! Note that 'iclwp, iciwp' are used for radiation computation. ! - ! ------------------------------------------------------------ ! - - - icinc = 0._r8 - icwnc = 0._r8 - iciwpst = 0._r8 - iclwpst = 0._r8 - icswp = 0._r8 - cldfsnow = 0._r8 - - do k = top_lev, pver - do i = 1, ncol - ! Limits for in-cloud mixing ratios consistent with MG microphysics - ! in-cloud mixing ratio maximum limit of 0.005 kg/kg - icimrst(i,k) = min( state_loc%q(i,k,ixcldice) / max(mincld,icecldf(i,k)),0.005_r8 ) - icwmrst(i,k) = min( state_loc%q(i,k,ixcldliq) / max(mincld,liqcldf(i,k)),0.005_r8 ) - icinc(i,k) = state_loc%q(i,k,ixnumice) / max(mincld,icecldf(i,k)) * & - state_loc%pmid(i,k) / (287.15_r8*state_loc%t(i,k)) - icwnc(i,k) = state_loc%q(i,k,ixnumliq) / max(mincld,liqcldf(i,k)) * & - state_loc%pmid(i,k) / (287.15_r8*state_loc%t(i,k)) - ! Calculate micro_mg_cam cloud water paths in each layer - ! Note: uses stratiform cloud fraction! - iciwpst(i,k) = min(state_loc%q(i,k,ixcldice)/max(mincld,ast(i,k)),0.005_r8) * state_loc%pdel(i,k) / gravit - iclwpst(i,k) = min(state_loc%q(i,k,ixcldliq)/max(mincld,ast(i,k)),0.005_r8) * state_loc%pdel(i,k) / gravit - - ! ------------------------------ ! - ! Adjust cloud fraction for snow ! - ! ------------------------------ ! - cldfsnow(i,k) = cld(i,k) - ! If cloud and only ice ( no convective cloud or ice ), then set to 0. - if( ( cldfsnow(i,k) .gt. 1.e-4_r8 ) .and. & - ( concld(i,k) .lt. 1.e-4_r8 ) .and. & - ( state_loc%q(i,k,ixcldliq) .lt. 1.e-10_r8 ) ) then - cldfsnow(i,k) = 0._r8 - end if - ! If no cloud and snow, then set to 0.25 - if( ( cldfsnow(i,k) .lt. 1.e-4_r8 ) .and. ( qsout(i,k) .gt. 1.e-6_r8 ) ) then - cldfsnow(i,k) = 0.25_r8 - end if - ! Calculate in-cloud snow water path - icswp(i,k) = qsout(i,k) / max( mincld, cldfsnow(i,k) ) * state_loc%pdel(i,k) / gravit - end do - end do - - - ! ------------------------------------------------------ ! - ! ------------------------------------------------------ ! - ! All code from here to the end is on grid columns only ! - ! ------------------------------------------------------ ! - ! ------------------------------------------------------ ! - - ! Average the fields which are needed later in this paramterization to be on the grid - if (use_subcol_microp) then - call subcol_field_avg(lambdac, ngrdcol, lchnk, lambdac_grid) - call subcol_field_avg(mu, ngrdcol, lchnk, mu_grid) - call subcol_field_avg(rel, ngrdcol, lchnk, rel_grid) - call subcol_field_avg(rei, ngrdcol, lchnk, rei_grid) - call subcol_field_avg(dei, ngrdcol, lchnk, dei_grid) - call subcol_field_avg(prec_str, ngrdcol, lchnk, prec_str_grid) - call subcol_field_avg(iclwpst, ngrdcol, lchnk, iclwpst_grid) - call subcol_field_avg(cvreffliq, ngrdcol, lchnk, cvreffliq_grid) - call subcol_field_avg(cvreffice, ngrdcol, lchnk, cvreffice_grid) - call subcol_field_avg(mgflxprc, ngrdcol, lchnk, mgflxprc_grid) - call subcol_field_avg(mgflxsnw, ngrdcol, lchnk, mgflxsnw_grid) - call subcol_field_avg(qme, ngrdcol, lchnk, qme_grid) - call subcol_field_avg(nevapr, ngrdcol, lchnk, nevapr_grid) - call subcol_field_avg(prain, ngrdcol, lchnk, prain_grid) - - ! Average fields which are not in pbuf - call subcol_field_avg(qrout, ngrdcol, lchnk, qrout_grid) - call subcol_field_avg(qsout, ngrdcol, lchnk, qsout_grid) - call subcol_field_avg(nsout, ngrdcol, lchnk, nsout_grid) - call subcol_field_avg(nrout, ngrdcol, lchnk, nrout_grid) - call subcol_field_avg(cld, ngrdcol, lchnk, cld_grid) - call subcol_field_avg(qcreso, ngrdcol, lchnk, qcreso_grid) - call subcol_field_avg(melto, ngrdcol, lchnk, melto_grid) - call subcol_field_avg(mnuccco, ngrdcol, lchnk, mnuccco_grid) - call subcol_field_avg(mnuccto, ngrdcol, lchnk, mnuccto_grid) - call subcol_field_avg(bergo, ngrdcol, lchnk, bergo_grid) - call subcol_field_avg(homoo, ngrdcol, lchnk, homoo_grid) - call subcol_field_avg(msacwio, ngrdcol, lchnk, msacwio_grid) - call subcol_field_avg(psacwso, ngrdcol, lchnk, psacwso_grid) - call subcol_field_avg(bergso, ngrdcol, lchnk, bergso_grid) - call subcol_field_avg(cmeiout, ngrdcol, lchnk, cmeiout_grid) - call subcol_field_avg(qireso, ngrdcol, lchnk, qireso_grid) - call subcol_field_avg(prcio, ngrdcol, lchnk, prcio_grid) - call subcol_field_avg(praio, ngrdcol, lchnk, praio_grid) - call subcol_field_avg(icwmrst, ngrdcol, lchnk, icwmrst_grid) - call subcol_field_avg(icimrst, ngrdcol, lchnk, icimrst_grid) - call subcol_field_avg(liqcldf, ngrdcol, lchnk, liqcldf_grid) - call subcol_field_avg(icecldf, ngrdcol, lchnk, icecldf_grid) - call subcol_field_avg(icwnc, ngrdcol, lchnk, icwnc_grid) - call subcol_field_avg(icinc, ngrdcol, lchnk, icinc_grid) - call subcol_field_avg(state_loc%pdel, ngrdcol, lchnk, pdel_grid) - call subcol_field_avg(state_loc%q(:,:,ixnumliq), ngrdcol, lchnk, q_ixnumliq_grid) - call subcol_field_avg(prao, ngrdcol, lchnk, prao_grid) - call subcol_field_avg(prco, ngrdcol, lchnk, prco_grid) - - else ! fields already on grids, so just assign - lambdac_grid => lambdac - mu_grid => mu - rel_grid => rel - rei_grid => rei - dei_grid => dei - prec_str_grid => prec_str - iclwpst_grid => iclwpst - cvreffliq_grid => cvreffliq - cvreffice_grid => cvreffice - mgflxprc_grid => mgflxprc - mgflxsnw_grid => mgflxsnw - qme_grid => qme - nevapr_grid => nevapr - prain_grid => prain - - ! This pbuf field needs to be assigned. There is no corresponding subcol_field_avg - ! as it is reset before it is used and would be a needless calculation - des_grid => des - - qrout_grid = qrout - qsout_grid = qsout - nsout_grid = nsout - nrout_grid = nrout - cld_grid = cld - qcreso_grid = qcreso - melto_grid = melto - mnuccco_grid = mnuccco - mnuccto_grid = mnuccto - bergo_grid = bergo - homoo_grid = homoo - msacwio_grid = msacwio - psacwso_grid = psacwso - bergso_grid = bergso - cmeiout_grid = cmeiout - qireso_grid = qireso - prcio_grid = prcio - praio_grid = praio - icwmrst_grid = icwmrst - icimrst_grid = icimrst - liqcldf_grid = liqcldf - icecldf_grid = icecldf - icwnc_grid = icwnc - icinc_grid = icinc - pdel_grid = state_loc%pdel - q_ixnumliq_grid = state_loc%q(:,:,ixnumliq) - prao_grid = prao - prco_grid = prco - - end if - - ! If on subcolumns, average the rest of the pbuf fields which were modified on subcolumns but are not used further in - ! this parameterization (no need to assign in the non-subcolumn case -- the else step) - if (use_subcol_microp) then - call subcol_field_avg(snow_str, ngrdcol, lchnk, snow_str_grid) - call subcol_field_avg(prec_pcw, ngrdcol, lchnk, prec_pcw_grid) - call subcol_field_avg(snow_pcw, ngrdcol, lchnk, snow_pcw_grid) - call subcol_field_avg(prec_sed, ngrdcol, lchnk, prec_sed_grid) - call subcol_field_avg(snow_sed, ngrdcol, lchnk, snow_sed_grid) - call subcol_field_avg(cldo, ngrdcol, lchnk, cldo_grid) - call subcol_field_avg(mgmrprc, ngrdcol, lchnk, mgmrprc_grid) - call subcol_field_avg(mgmrsnw, ngrdcol, lchnk, mgmrsnw_grid) - call subcol_field_avg(wsedl, ngrdcol, lchnk, wsedl_grid) - call subcol_field_avg(cc_t, ngrdcol, lchnk, cc_t_grid) - call subcol_field_avg(cc_qv, ngrdcol, lchnk, cc_qv_grid) - call subcol_field_avg(cc_ql, ngrdcol, lchnk, cc_ql_grid) - call subcol_field_avg(cc_qi, ngrdcol, lchnk, cc_qi_grid) - call subcol_field_avg(cc_nl, ngrdcol, lchnk, cc_nl_grid) - call subcol_field_avg(cc_ni, ngrdcol, lchnk, cc_ni_grid) - call subcol_field_avg(cc_qlst, ngrdcol, lchnk, cc_qlst_grid) - call subcol_field_avg(iciwpst, ngrdcol, lchnk, iciwpst_grid) - call subcol_field_avg(icswp, ngrdcol, lchnk, icswp_grid) - call subcol_field_avg(cldfsnow, ngrdcol, lchnk, cldfsnow_grid) - - if (rate1_cw2pr_st_idx > 0) then - call subcol_field_avg(rate1ord_cw2pr_st, ngrdcol, lchnk, rate1ord_cw2pr_st_grid) - end if - - end if - - ! ------------------------------------- ! - ! Size distribution calculation ! - ! ------------------------------------- ! - - - ! Calculate rho (on subcolumns if turned on) for size distribution parameter calculations and average it if needed - rho(:ncol,top_lev:) = state%pmid(:ncol,top_lev:) / & - (rair*state%t(:ncol,top_lev:)) - if (use_subcol_microp) then - call subcol_field_avg(rho, ngrdcol, lchnk, rho_grid) - else - rho_grid = rho - end if - - ! Effective radius for cloud liquid, fixed number. - mu_grid = 0._r8 - lambdac_grid = 0._r8 - rel_fn_grid = 10._r8 - ncic_grid = 1.e8_r8 - - call size_dist_param_liq(mg_liq_props, icwmrst_grid(:ngrdcol,top_lev:), & - ncic_grid(:ngrdcol,top_lev:), rho_grid(:ngrdcol,top_lev:), & - mu_grid(:ngrdcol,top_lev:), lambdac_grid(:ngrdcol,top_lev:)) - - where (icwmrst_grid(:ngrdcol,top_lev:) > qsmall) - rel_fn_grid(:ngrdcol,top_lev:) = & - (mu_grid(:ngrdcol,top_lev:) + 3._r8)/ & - lambdac_grid(:ngrdcol,top_lev:)/2._r8 * 1.e6_r8 - end where - - ! Effective radius for cloud liquid, and size parameters mu_grid and lambdac_grid. - mu_grid = 0._r8 - lambdac_grid = 0._r8 - rel_grid = 10._r8 - - ! Calculate ncic (on subcolumns if turned on) and average it if needed - ncic(:ncol,top_lev:) = state_loc%q(:ncol,top_lev:,ixnumliq) / & - max(mincld,liqcldf(:ncol,top_lev:)) - if (use_subcol_microp) then - call subcol_field_avg(ncic, ngrdcol, lchnk, ncic_grid) - else - ncic_grid=ncic - endif - - call size_dist_param_liq(mg_liq_props, icwmrst_grid(:ngrdcol,top_lev:), & - ncic_grid(:ngrdcol,top_lev:), rho_grid(:ngrdcol,top_lev:), & - mu_grid(:ngrdcol,top_lev:), lambdac_grid(:ngrdcol,top_lev:)) - - where (icwmrst_grid(:ngrdcol,top_lev:) >= qsmall) - rel_grid(:ngrdcol,top_lev:) = & - (mu_grid(:ngrdcol,top_lev:) + 3._r8) / & - lambdac_grid(:ngrdcol,top_lev:)/2._r8 * 1.e6_r8 - elsewhere - ! Deal with the fact that size_dist_param_liq sets mu_grid to -100 wherever - ! there is no cloud. - mu_grid(:ngrdcol,top_lev:) = 0._r8 - end where - - ! Rain/Snow effective diameter. - ! Note -- These five fields are calculated in micro_mg_tend but are overwritten here - drout2_grid = 0._r8 - reff_rain_grid = 0._r8 - des_grid = 0._r8 - dsout2_grid = 0._r8 - reff_snow_grid = 0._r8 - - where (qrout_grid(:ngrdcol,top_lev:) >= 1.e-7_r8) - - drout2_grid(:ngrdcol,top_lev:) = avg_diameter(qrout_grid(:ngrdcol,top_lev:), & - nrout_grid(:ngrdcol,top_lev:) * rho_grid(:ngrdcol,top_lev:), & - rho_grid(:ngrdcol,top_lev:), rhow) - - reff_rain_grid(:ngrdcol,top_lev:) = drout2_grid(:ngrdcol,top_lev:) * & - 1.5_r8 * 1.e6_r8 - - end where - - where (qsout_grid(:ngrdcol,top_lev:) >= 1.e-7_r8) - - dsout2_grid(:ngrdcol,top_lev:) = avg_diameter( qsout_grid(:ngrdcol,top_lev:), & - nsout_grid(:ngrdcol,top_lev:) * rho_grid(:ngrdcol,top_lev:), & - rho_grid(:ngrdcol,top_lev:), rhosn) - - des_grid(:ngrdcol,top_lev:) = dsout2_grid(:ngrdcol,top_lev:) * 3._r8 * rhosn/rhows - - reff_snow_grid(:ngrdcol,top_lev:) = dsout2_grid(:ngrdcol,top_lev:) * & - 1.5_r8 * 1.e6_r8 - - end where - - ! Effective radius and diameter for cloud ice. - ! These must always be on the grid - rei_grid = 25._r8 - - ! Calculate niic (on subcolumns if turned on) and average it if needed - niic(:ncol,top_lev:) = state_loc%q(:ncol,top_lev:,ixnumice) / & - max(mincld,icecldf(:ncol,top_lev:)) - if (use_subcol_microp) then - call subcol_field_avg(niic, ngrdcol, lchnk, niic_grid) - else - niic_grid = niic - end if - - call size_dist_param_basic(mg_ice_props, icimrst_grid(:ngrdcol,top_lev:), & - niic_grid(:ngrdcol,top_lev:), rei_grid(:ngrdcol,top_lev:)) - - where (icimrst_grid(:ngrdcol,top_lev:) >= qsmall) - rei_grid(:ngrdcol,top_lev:) = 1.5_r8/rei_grid(:ngrdcol,top_lev:) & - * 1.e6_r8 - elsewhere - rei_grid(:ngrdcol,top_lev:) = 25._r8 - end where - - dei_grid = rei_grid * rhoi/rhows * 2._r8 - - - ! Limiters for low cloud fraction. - do k = top_lev, pver - do i = 1, ngrdcol - ! Convert snow effective diameter to microns - des_grid(i,k) = des_grid(i,k) * 1.e6_r8 - if ( ast_grid(i,k) < 1.e-4_r8 ) then - mu_grid(i,k) = mucon - lambdac_grid(i,k) = (mucon + 1._r8)/dcon - dei_grid(i,k) = deicon - end if - end do - end do - - mgreffrain_grid(:ngrdcol,top_lev:pver) = reff_rain_grid(:ngrdcol,top_lev:pver) - mgreffsnow_grid(:ngrdcol,top_lev:pver) = reff_snow_grid(:ngrdcol,top_lev:pver) - - - ! ------------------------------------- ! - ! Precipitation efficiency Calculation ! - ! ------------------------------------- ! - - - !----------------------------------------------------------------------- - ! Liquid water path - - ! Compute liquid water paths, and column condensation - tgliqwp_grid(:ngrdcol) = 0._r8 - tgcmeliq_grid(:ngrdcol) = 0._r8 - - do k = top_lev, pver - do i = 1, ngrdcol - tgliqwp_grid(i) = tgliqwp_grid(i) + iclwpst_grid(i,k)*cld_grid(i,k) - - if (cmeliq_grid(i,k) > 1.e-12_r8) then - !convert cmeliq to right units: kgh2o/kgair/s * kgair/m2 / kgh2o/m3 = m/s - tgcmeliq_grid(i) = tgcmeliq_grid(i) + cmeliq_grid(i,k) * (pdel_grid(i,k) / gravit) / rhoh2o - end if - end do - end do - - ! note: 1e-6 kgho2/kgair/s * 1000. pa / (9.81 m/s2) / 1000 kgh2o/m3 = 1e-7 m/s - ! this is 1ppmv of h2o in 10hpa - ! alternatively: 0.1 mm/day * 1.e-4 m/mm * 1/86400 day/s = 1.e-9 - - !----------------------------------------------------------------------- - ! precipitation efficiency calculation (accumulate cme and precip) - - minlwp = 0.01_r8 !minimum lwp threshold (kg/m3) - - ! zero out precip efficiency and total averaged precip - pe_grid(:ngrdcol) = 0._r8 - tpr_grid(:ngrdcol) = 0._r8 - pefrac_grid(:ngrdcol) = 0._r8 - - ! accumulate precip and condensation - do i = 1, ngrdcol - - acgcme_grid(i) = acgcme_grid(i) + tgcmeliq_grid(i) - acprecl_grid(i) = acprecl_grid(i) + prec_str_grid(i) - acnum_grid(i) = acnum_grid(i) + 1 - - ! if LWP is zero, then 'end of cloud': calculate precip efficiency - if (tgliqwp_grid(i) < minlwp) then - if (acprecl_grid(i) > 5.e-8_r8) then - tpr_grid(i) = max(acprecl_grid(i)/acnum_grid(i), 1.e-15_r8) - if (acgcme_grid(i) > 1.e-10_r8) then - pe_grid(i) = min(max(acprecl_grid(i)/acgcme_grid(i), 1.e-15_r8), 1.e5_r8) - pefrac_grid(i) = 1._r8 - end if - end if - - ! reset counters - ! if (pe_grid(i) /= 0._r8 .and. (pe_grid(i) < 1.e-8_r8 .or. pe_grid(i) > 1.e3_r8)) then - ! write (iulog,*) 'PE_grid:ANOMALY pe_grid, acprecl_grid, acgcme_grid, tpr_grid, acnum_grid ',pe_grid(i),& - ! acprecl_grid(i), acgcme_grid(i), tpr_grid(i), acnum_grid(i) - ! endif - - acprecl_grid(i) = 0._r8 - acgcme_grid(i) = 0._r8 - acnum_grid(i) = 0 - end if ! end LWP zero conditional - - ! if never find any rain....(after 10^3 timesteps...) - if (acnum_grid(i) > 1000) then - acnum_grid(i) = 0 - acprecl_grid(i) = 0._r8 - acgcme_grid(i) = 0._r8 - end if - - end do - - !----------------------------------------------------------------------- - ! vertical average of non-zero accretion, autoconversion and ratio. - ! vars: vprco_grid(i),vprao_grid(i),racau_grid(i),cnt_grid - - vprao_grid = 0._r8 - cnt_grid = 0 - do k = top_lev, pver - vprao_grid(:ngrdcol) = vprao_grid(:ngrdcol) + prao_grid(:ngrdcol,k) - where (prao_grid(:ngrdcol,k) /= 0._r8) cnt_grid(:ngrdcol) = cnt_grid(:ngrdcol) + 1 - end do - - where (cnt_grid > 0) vprao_grid = vprao_grid/cnt_grid - - vprco_grid = 0._r8 - cnt_grid = 0 - do k = top_lev, pver - vprco_grid(:ngrdcol) = vprco_grid(:ngrdcol) + prco_grid(:ngrdcol,k) - where (prco_grid(:ngrdcol,k) /= 0._r8) cnt_grid(:ngrdcol) = cnt_grid(:ngrdcol) + 1 - end do - - where (cnt_grid > 0) - vprco_grid = vprco_grid/cnt_grid - racau_grid = vprao_grid/vprco_grid - elsewhere - racau_grid = 0._r8 - end where - - racau_grid = min(racau_grid, 1.e10_r8) - - ! --------------------- ! - ! History Output Fields ! - ! --------------------- ! - - ! Column droplet concentration - cdnumc_grid(:ngrdcol) = sum(q_ixnumliq_grid(:ngrdcol,top_lev:pver) * & - pdel_grid(:ngrdcol,top_lev:pver)/gravit, dim=2) - - ! Averaging for new output fields - efcout_grid = 0._r8 - efiout_grid = 0._r8 - ncout_grid = 0._r8 - niout_grid = 0._r8 - freql_grid = 0._r8 - freqi_grid = 0._r8 - liqcldf_grid_out = 0._r8 - icecldf_grid_out = 0._r8 - icwmrst_grid_out = 0._r8 - icimrst_grid_out = 0._r8 - - do k = top_lev, pver - do i = 1, ngrdcol - if ( liqcldf_grid(i,k) > 0.01_r8 .and. icwmrst_grid(i,k) > 5.e-5_r8 ) then - efcout_grid(i,k) = rel_grid(i,k) * liqcldf_grid(i,k) - ncout_grid(i,k) = icwnc_grid(i,k) * liqcldf_grid(i,k) - freql_grid(i,k) = liqcldf_grid(i,k) - liqcldf_grid_out(i,k) = liqcldf_grid(i,k) - icwmrst_grid_out(i,k) = icwmrst_grid(i,k) - end if - if ( icecldf_grid(i,k) > 0.01_r8 .and. icimrst_grid(i,k) > 1.e-6_r8 ) then - efiout_grid(i,k) = rei_grid(i,k) * icecldf_grid(i,k) - niout_grid(i,k) = icinc_grid(i,k) * icecldf_grid(i,k) - freqi_grid(i,k) = icecldf_grid(i,k) - icecldf_grid_out(i,k) = icecldf_grid(i,k) - icimrst_grid_out(i,k) = icimrst_grid(i,k) - end if - end do - end do - - ! Cloud top effective radius and number. - fcti_grid = 0._r8 - fctl_grid = 0._r8 - ctrel_grid = 0._r8 - ctrei_grid = 0._r8 - ctnl_grid = 0._r8 - ctni_grid = 0._r8 - do i = 1, ngrdcol - do k = top_lev, pver - if ( liqcldf_grid(i,k) > 0.01_r8 .and. icwmrst_grid(i,k) > 1.e-7_r8 ) then - ctrel_grid(i) = rel_grid(i,k) * liqcldf_grid(i,k) - ctnl_grid(i) = icwnc_grid(i,k) * liqcldf_grid(i,k) - fctl_grid(i) = liqcldf_grid(i,k) - exit - end if - if ( icecldf_grid(i,k) > 0.01_r8 .and. icimrst_grid(i,k) > 1.e-7_r8 ) then - ctrei_grid(i) = rei_grid(i,k) * icecldf_grid(i,k) - ctni_grid(i) = icinc_grid(i,k) * icecldf_grid(i,k) - fcti_grid(i) = icecldf_grid(i,k) - exit - end if - end do - end do - - - ! Assign the values to the pbuf pointers if they exist in pbuf - if (qrain_idx > 0) qrout_grid_ptr = qrout_grid - if (qsnow_idx > 0) qsout_grid_ptr = qsout_grid - if (nrain_idx > 0) nrout_grid_ptr = nrout_grid - if (nsnow_idx > 0) nsout_grid_ptr = nsout_grid - - ! --------------------------------------------- ! - ! General outfield calls for microphysics ! - ! --------------------------------------------- ! - - ! Output a handle of variables which are calculated on the fly - ftem_grid = 0._r8 - - ftem_grid(:ngrdcol,top_lev:pver) = qcreso_grid(:ngrdcol,top_lev:pver) - call outfld( 'MPDW2V', ftem_grid, pcols, lchnk) - - ftem_grid(:ngrdcol,top_lev:pver) = melto_grid(:ngrdcol,top_lev:pver) - mnuccco_grid(:ngrdcol,top_lev:pver)& + use micro_mg_utils, only: size_dist_param_basic, size_dist_param_liq, & + mg_liq_props, mg_ice_props, avg_diameter, rhoi, rhosn, rhow, rhows, & + qsmall, mincld + + use micro_mg_data, only: MGPacker, MGPostProc, accum_null, accum_mean + + use micro_mg1_0, only: micro_mg_tend1_0 => micro_mg_tend, & + micro_mg_get_cols1_0 => micro_mg_get_cols + use micro_mg1_5, only: micro_mg_tend1_5 => micro_mg_tend, & + micro_mg_get_cols1_5 => micro_mg_get_cols + use micro_mg2_0, only: micro_mg_tend2_0 => micro_mg_tend, & + micro_mg_get_cols2_0 => micro_mg_get_cols + + use physics_buffer, only: pbuf_col_type_index + use subcol, only: subcol_field_avg + + type(physics_state), intent(in) :: state + type(physics_ptend), intent(out) :: ptend + real(r8), intent(in) :: dtime + type(physics_buffer_desc), pointer :: pbuf(:) + + ! Local variables + integer :: lchnk, ncol, psetcols, ngrdcol + + integer :: i, k, itim_old, it + + real(r8), pointer :: naai(:,:) ! ice nucleation number + real(r8), pointer :: naai_hom(:,:) ! ice nucleation number (homogeneous) + real(r8), pointer :: npccn(:,:) ! liquid activation number tendency + real(r8), pointer :: rndst(:,:,:) + real(r8), pointer :: nacon(:,:,:) + real(r8), pointer :: am_evp_st_grid(:,:) ! Evaporation area of stratiform precipitation. 0<= am_evp_st <=1. + real(r8), pointer :: evprain_st_grid(:,:) ! Evaporation rate of stratiform rain [kg/kg/s] + real(r8), pointer :: evpsnow_st_grid(:,:) ! Evaporation rate of stratiform snow [kg/kg/s] + + real(r8), pointer :: prec_str(:) ! [Total] Sfc flux of precip from stratiform [ m/s ] + real(r8), pointer :: snow_str(:) ! [Total] Sfc flux of snow from stratiform [ m/s ] + real(r8), pointer :: prec_sed(:) ! Surface flux of total cloud water from sedimentation + real(r8), pointer :: snow_sed(:) ! Surface flux of cloud ice from sedimentation + real(r8), pointer :: prec_pcw(:) ! Sfc flux of precip from microphysics [ m/s ] + real(r8), pointer :: snow_pcw(:) ! Sfc flux of snow from microphysics [ m/s ] + + real(r8), pointer :: ast(:,:) ! Relative humidity cloud fraction + real(r8), pointer :: alst_mic(:,:) + real(r8), pointer :: aist_mic(:,:) + real(r8), pointer :: cldo(:,:) ! Old cloud fraction + real(r8), pointer :: nevapr(:,:) ! Evaporation of total precipitation (rain + snow) + real(r8), pointer :: prer_evap(:,:) ! precipitation evaporation rate + real(r8), pointer :: relvar(:,:) ! relative variance of cloud water + real(r8), pointer :: accre_enhan(:,:) ! optional accretion enhancement for experimentation + real(r8), pointer :: prain(:,:) ! Total precipitation (rain + snow) + real(r8), pointer :: dei(:,:) ! Ice effective diameter (meters) (AG: microns?) + real(r8), pointer :: mu(:,:) ! Size distribution shape parameter for radiation + real(r8), pointer :: lambdac(:,:) ! Size distribution slope parameter for radiation + real(r8), pointer :: des(:,:) ! Snow effective diameter (m) + + real(r8) :: rho(state%psetcols,pver) + real(r8) :: cldmax(state%psetcols,pver) + + real(r8), target :: rate1cld(state%psetcols,pver) ! array to hold rate1ord_cw2pr_st from microphysics + + real(r8), target :: tlat(state%psetcols,pver) + real(r8), target :: qvlat(state%psetcols,pver) + real(r8), target :: qcten(state%psetcols,pver) + real(r8), target :: qiten(state%psetcols,pver) + real(r8), target :: ncten(state%psetcols,pver) + real(r8), target :: niten(state%psetcols,pver) + + real(r8), target :: qrten(state%psetcols,pver) + real(r8), target :: qsten(state%psetcols,pver) + real(r8), target :: nrten(state%psetcols,pver) + real(r8), target :: nsten(state%psetcols,pver) + + real(r8), target :: prect(state%psetcols) + real(r8), target :: preci(state%psetcols) + real(r8), target :: am_evp_st(state%psetcols,pver) ! Area over which precip evaporates + real(r8), target :: evapsnow(state%psetcols,pver) ! Local evaporation of snow + real(r8), target :: prodsnow(state%psetcols,pver) ! Local production of snow + real(r8), target :: cmeice(state%psetcols,pver) ! Rate of cond-evap of ice within the cloud + real(r8), target :: qsout(state%psetcols,pver) ! Snow mixing ratio + real(r8), target :: rflx(state%psetcols,pverp) ! grid-box average rain flux (kg m^-2 s^-1) + real(r8), target :: sflx(state%psetcols,pverp) ! grid-box average snow flux (kg m^-2 s^-1) + real(r8), target :: qrout(state%psetcols,pver) ! Rain mixing ratio + real(r8), target :: qcsevap(state%psetcols,pver) ! Evaporation of falling cloud water + real(r8), target :: qisevap(state%psetcols,pver) ! Sublimation of falling cloud ice + real(r8), target :: qvres(state%psetcols,pver) ! Residual condensation term to remove excess saturation + real(r8), target :: cmeiout(state%psetcols,pver) ! Deposition/sublimation rate of cloud ice + real(r8), target :: vtrmc(state%psetcols,pver) ! Mass-weighted cloud water fallspeed + real(r8), target :: vtrmi(state%psetcols,pver) ! Mass-weighted cloud ice fallspeed + real(r8), target :: umr(state%psetcols,pver) ! Mass-weighted rain fallspeed + real(r8), target :: ums(state%psetcols,pver) ! Mass-weighted snow fallspeed + real(r8), target :: qcsedten(state%psetcols,pver) ! Cloud water mixing ratio tendency from sedimentation + real(r8), target :: qisedten(state%psetcols,pver) ! Cloud ice mixing ratio tendency from sedimentation + real(r8), target :: qrsedten(state%psetcols,pver) ! Rain mixing ratio tendency from sedimentation + real(r8), target :: qssedten(state%psetcols,pver) ! Snow mixing ratio tendency from sedimentation + + real(r8), target :: prao(state%psetcols,pver) + real(r8), target :: prco(state%psetcols,pver) + real(r8), target :: mnuccco(state%psetcols,pver) + real(r8), target :: mnuccto(state%psetcols,pver) + real(r8), target :: msacwio(state%psetcols,pver) + real(r8), target :: psacwso(state%psetcols,pver) + real(r8), target :: bergso(state%psetcols,pver) + real(r8), target :: bergo(state%psetcols,pver) + real(r8), target :: melto(state%psetcols,pver) + real(r8), target :: homoo(state%psetcols,pver) + real(r8), target :: qcreso(state%psetcols,pver) + real(r8), target :: prcio(state%psetcols,pver) + real(r8), target :: praio(state%psetcols,pver) + real(r8), target :: qireso(state%psetcols,pver) + real(r8), target :: mnuccro(state%psetcols,pver) + real(r8), target :: pracso (state%psetcols,pver) + real(r8), target :: meltsdt(state%psetcols,pver) + real(r8), target :: frzrdt (state%psetcols,pver) + real(r8), target :: mnuccdo(state%psetcols,pver) + real(r8), target :: nrout(state%psetcols,pver) + real(r8), target :: nsout(state%psetcols,pver) + real(r8), target :: refl(state%psetcols,pver) ! analytic radar reflectivity + real(r8), target :: arefl(state%psetcols,pver) ! average reflectivity will zero points outside valid range + real(r8), target :: areflz(state%psetcols,pver) ! average reflectivity in z. + real(r8), target :: frefl(state%psetcols,pver) + real(r8), target :: csrfl(state%psetcols,pver) ! cloudsat reflectivity + real(r8), target :: acsrfl(state%psetcols,pver) ! cloudsat average + real(r8), target :: fcsrfl(state%psetcols,pver) + real(r8), target :: rercld(state%psetcols,pver) ! effective radius calculation for rain + cloud + real(r8), target :: ncai(state%psetcols,pver) ! output number conc of ice nuclei available (1/m3) + real(r8), target :: ncal(state%psetcols,pver) ! output number conc of CCN (1/m3) + real(r8), target :: qrout2(state%psetcols,pver) + real(r8), target :: qsout2(state%psetcols,pver) + real(r8), target :: nrout2(state%psetcols,pver) + real(r8), target :: nsout2(state%psetcols,pver) + real(r8), target :: freqs(state%psetcols,pver) + real(r8), target :: freqr(state%psetcols,pver) + real(r8), target :: nfice(state%psetcols,pver) + real(r8), target :: qcrat(state%psetcols,pver) ! qc limiter ratio (1=no limit) + + ! Object that packs columns with clouds/precip. + type(MGPacker) :: packer + + ! Packed versions of inputs. + real(r8), allocatable :: packed_t(:,:) + real(r8), allocatable :: packed_q(:,:) + real(r8), allocatable :: packed_qc(:,:) + real(r8), allocatable :: packed_nc(:,:) + real(r8), allocatable :: packed_qi(:,:) + real(r8), allocatable :: packed_ni(:,:) + real(r8), allocatable :: packed_qr(:,:) + real(r8), allocatable :: packed_nr(:,:) + real(r8), allocatable :: packed_qs(:,:) + real(r8), allocatable :: packed_ns(:,:) + + real(r8), allocatable :: packed_relvar(:,:) + real(r8), allocatable :: packed_accre_enhan(:,:) + + real(r8), allocatable :: packed_p(:,:) + real(r8), allocatable :: packed_pdel(:,:) + + ! This is only needed for MG1.5, and can be removed when support for + ! that version is dropped. + real(r8), allocatable :: packed_pint(:,:) + + real(r8), allocatable :: packed_cldn(:,:) + real(r8), allocatable :: packed_liqcldf(:,:) + real(r8), allocatable :: packed_icecldf(:,:) + + real(r8), allocatable :: packed_naai(:,:) + real(r8), allocatable :: packed_npccn(:,:) + + real(r8), allocatable :: packed_rndst(:,:,:) + real(r8), allocatable :: packed_nacon(:,:,:) + + ! Optional outputs. + real(r8), pointer :: packed_tnd_qsnow(:,:) + real(r8), pointer :: packed_tnd_nsnow(:,:) + real(r8), pointer :: packed_re_ice(:,:) + + real(r8), pointer :: packed_frzimm(:,:) + real(r8), pointer :: packed_frzcnt(:,:) + real(r8), pointer :: packed_frzdep(:,:) + + ! Output field post-processing. + type(MGPostProc) :: post_proc + + ! Packed versions of outputs. + real(r8), allocatable, target :: packed_rate1ord_cw2pr_st(:,:) + real(r8), allocatable, target :: packed_tlat(:,:) + real(r8), allocatable, target :: packed_qvlat(:,:) + real(r8), allocatable, target :: packed_qctend(:,:) + real(r8), allocatable, target :: packed_qitend(:,:) + real(r8), allocatable, target :: packed_nctend(:,:) + real(r8), allocatable, target :: packed_nitend(:,:) + + real(r8), allocatable, target :: packed_qrtend(:,:) + real(r8), allocatable, target :: packed_qstend(:,:) + real(r8), allocatable, target :: packed_nrtend(:,:) + real(r8), allocatable, target :: packed_nstend(:,:) + + real(r8), allocatable, target :: packed_prect(:) + real(r8), allocatable, target :: packed_preci(:) + real(r8), allocatable, target :: packed_nevapr(:,:) + real(r8), allocatable, target :: packed_am_evp_st(:,:) + real(r8), allocatable, target :: packed_evapsnow(:,:) + real(r8), allocatable, target :: packed_prain(:,:) + real(r8), allocatable, target :: packed_prodsnow(:,:) + real(r8), allocatable, target :: packed_cmeout(:,:) + real(r8), allocatable, target :: packed_qsout(:,:) + real(r8), allocatable, target :: packed_rflx(:,:) + real(r8), allocatable, target :: packed_sflx(:,:) + real(r8), allocatable, target :: packed_qrout(:,:) + real(r8), allocatable, target :: packed_qcsevap(:,:) + real(r8), allocatable, target :: packed_qisevap(:,:) + real(r8), allocatable, target :: packed_qvres(:,:) + real(r8), allocatable, target :: packed_cmei(:,:) + real(r8), allocatable, target :: packed_vtrmc(:,:) + real(r8), allocatable, target :: packed_vtrmi(:,:) + real(r8), allocatable, target :: packed_qcsedten(:,:) + real(r8), allocatable, target :: packed_qisedten(:,:) + real(r8), allocatable, target :: packed_qrsedten(:,:) + real(r8), allocatable, target :: packed_qssedten(:,:) + real(r8), allocatable, target :: packed_umr(:,:) + real(r8), allocatable, target :: packed_ums(:,:) + real(r8), allocatable, target :: packed_pra(:,:) + real(r8), allocatable, target :: packed_prc(:,:) + real(r8), allocatable, target :: packed_mnuccc(:,:) + real(r8), allocatable, target :: packed_mnucct(:,:) + real(r8), allocatable, target :: packed_msacwi(:,:) + real(r8), allocatable, target :: packed_psacws(:,:) + real(r8), allocatable, target :: packed_bergs(:,:) + real(r8), allocatable, target :: packed_berg(:,:) + real(r8), allocatable, target :: packed_melt(:,:) + real(r8), allocatable, target :: packed_homo(:,:) + real(r8), allocatable, target :: packed_qcres(:,:) + real(r8), allocatable, target :: packed_prci(:,:) + real(r8), allocatable, target :: packed_prai(:,:) + real(r8), allocatable, target :: packed_qires(:,:) + real(r8), allocatable, target :: packed_mnuccr(:,:) + real(r8), allocatable, target :: packed_pracs(:,:) + real(r8), allocatable, target :: packed_meltsdt(:,:) + real(r8), allocatable, target :: packed_frzrdt(:,:) + real(r8), allocatable, target :: packed_mnuccd(:,:) + real(r8), allocatable, target :: packed_nrout(:,:) + real(r8), allocatable, target :: packed_nsout(:,:) + real(r8), allocatable, target :: packed_refl(:,:) + real(r8), allocatable, target :: packed_arefl(:,:) + real(r8), allocatable, target :: packed_areflz(:,:) + real(r8), allocatable, target :: packed_frefl(:,:) + real(r8), allocatable, target :: packed_csrfl(:,:) + real(r8), allocatable, target :: packed_acsrfl(:,:) + real(r8), allocatable, target :: packed_fcsrfl(:,:) + real(r8), allocatable, target :: packed_rercld(:,:) + real(r8), allocatable, target :: packed_ncai(:,:) + real(r8), allocatable, target :: packed_ncal(:,:) + real(r8), allocatable, target :: packed_qrout2(:,:) + real(r8), allocatable, target :: packed_qsout2(:,:) + real(r8), allocatable, target :: packed_nrout2(:,:) + real(r8), allocatable, target :: packed_nsout2(:,:) + real(r8), allocatable, target :: packed_freqs(:,:) + real(r8), allocatable, target :: packed_freqr(:,:) + real(r8), allocatable, target :: packed_nfice(:,:) + real(r8), allocatable, target :: packed_prer_evap(:,:) + real(r8), allocatable, target :: packed_qcrat(:,:) + + real(r8), allocatable, target :: packed_rel(:,:) + real(r8), allocatable, target :: packed_rei(:,:) + real(r8), allocatable, target :: packed_lambdac(:,:) + real(r8), allocatable, target :: packed_mu(:,:) + real(r8), allocatable, target :: packed_des(:,:) + real(r8), allocatable, target :: packed_dei(:,:) + + ! Dummy arrays for cases where we throw away the MG version and + ! recalculate sizes on the CAM grid to avoid time/subcolumn averaging + ! issues. + real(r8), allocatable :: rel_fn_dum(:,:) + real(r8), allocatable :: dsout2_dum(:,:) + real(r8), allocatable :: drout_dum(:,:) + real(r8), allocatable :: reff_rain_dum(:,:) + real(r8), allocatable :: reff_snow_dum(:,:) + + ! Heterogeneous-only version of mnuccdo. + real(r8) :: mnuccdohet(state%psetcols,pver) + + ! physics buffer fields for COSP simulator + real(r8), pointer :: mgflxprc(:,:) ! MG grid-box mean flux_large_scale_cloud_rain+snow at interfaces (kg/m2/s) + real(r8), pointer :: mgflxsnw(:,:) ! MG grid-box mean flux_large_scale_cloud_snow at interfaces (kg/m2/s) + real(r8), pointer :: mgmrprc(:,:) ! MG grid-box mean mixingratio_large_scale_cloud_rain+snow at interfaces (kg/kg) + real(r8), pointer :: mgmrsnw(:,:) ! MG grid-box mean mixingratio_large_scale_cloud_snow at interfaces (kg/kg) + real(r8), pointer :: mgreffrain_grid(:,:) ! MG diagnostic rain effective radius (um) + real(r8), pointer :: mgreffsnow_grid(:,:) ! MG diagnostic snow effective radius (um) + real(r8), pointer :: cvreffliq(:,:) ! convective cloud liquid effective radius (um) + real(r8), pointer :: cvreffice(:,:) ! convective cloud ice effective radius (um) + + ! physics buffer fields used with CARMA + real(r8), pointer, dimension(:,:) :: tnd_qsnow ! external tendency on snow mass (kg/kg/s) + real(r8), pointer, dimension(:,:) :: tnd_nsnow ! external tendency on snow number(#/kg/s) + real(r8), pointer, dimension(:,:) :: re_ice ! ice effective radius (m) + + real(r8), pointer :: rate1ord_cw2pr_st(:,:) ! 1st order rate for direct conversion of + ! strat. cloud water to precip (1/s) ! rce 2010/05/01 + real(r8), pointer :: wsedl(:,:) ! Sedimentation velocity of liquid stratus cloud droplet [ m/s ] + + + real(r8), pointer :: CC_T(:,:) ! Grid-mean microphysical tendency + real(r8), pointer :: CC_qv(:,:) ! Grid-mean microphysical tendency + real(r8), pointer :: CC_ql(:,:) ! Grid-mean microphysical tendency + real(r8), pointer :: CC_qi(:,:) ! Grid-mean microphysical tendency + real(r8), pointer :: CC_nl(:,:) ! Grid-mean microphysical tendency + real(r8), pointer :: CC_ni(:,:) ! Grid-mean microphysical tendency + real(r8), pointer :: CC_qlst(:,:) ! In-liquid stratus microphysical tendency + + ! variables for heterogeneous freezing + real(r8), pointer :: frzimm(:,:) + real(r8), pointer :: frzcnt(:,:) + real(r8), pointer :: frzdep(:,:) + + real(r8), pointer :: qme(:,:) + + ! A local copy of state is used for diagnostic calculations + type(physics_state) :: state_loc + type(physics_ptend) :: ptend_loc + + real(r8) :: icecldf(state%psetcols,pver) ! Ice cloud fraction + real(r8) :: liqcldf(state%psetcols,pver) ! Liquid cloud fraction (combined into cloud) + + real(r8), pointer :: rel(:,:) ! Liquid effective drop radius (microns) + real(r8), pointer :: rei(:,:) ! Ice effective drop size (microns) + + real(r8), pointer :: cmeliq(:,:) + + real(r8), pointer :: cld(:,:) ! Total cloud fraction + real(r8), pointer :: concld(:,:) ! Convective cloud fraction + real(r8), pointer :: iciwpst(:,:) ! Stratiform in-cloud ice water path for radiation + real(r8), pointer :: iclwpst(:,:) ! Stratiform in-cloud liquid water path for radiation + real(r8), pointer :: cldfsnow(:,:) ! Cloud fraction for liquid+snow + real(r8), pointer :: icswp(:,:) ! In-cloud snow water path + + real(r8) :: icimrst(state%psetcols,pver) ! In stratus ice mixing ratio + real(r8) :: icwmrst(state%psetcols,pver) ! In stratus water mixing ratio + real(r8) :: icinc(state%psetcols,pver) ! In cloud ice number conc + real(r8) :: icwnc(state%psetcols,pver) ! In cloud water number conc + + real(r8) :: iclwpi(state%psetcols) ! Vertically-integrated in-cloud Liquid WP before microphysics + real(r8) :: iciwpi(state%psetcols) ! Vertically-integrated in-cloud Ice WP before microphysics + + ! Averaging arrays for effective radius and number.... + real(r8) :: efiout_grid(pcols,pver) + real(r8) :: efcout_grid(pcols,pver) + real(r8) :: ncout_grid(pcols,pver) + real(r8) :: niout_grid(pcols,pver) + real(r8) :: freqi_grid(pcols,pver) + real(r8) :: freql_grid(pcols,pver) + + real(r8) :: cdnumc_grid(pcols) ! Vertically-integrated droplet concentration + real(r8) :: icimrst_grid_out(pcols,pver) ! In stratus ice mixing ratio + real(r8) :: icwmrst_grid_out(pcols,pver) ! In stratus water mixing ratio + + ! Cloud fraction used for precipitation. + real(r8) :: cldmax_grid(pcols,pver) + + ! Average cloud top radius & number + real(r8) :: ctrel_grid(pcols) + real(r8) :: ctrei_grid(pcols) + real(r8) :: ctnl_grid(pcols) + real(r8) :: ctni_grid(pcols) + real(r8) :: fcti_grid(pcols) + real(r8) :: fctl_grid(pcols) + + real(r8) :: ftem_grid(pcols,pver) + + ! Variables for precip efficiency calculation + real(r8) :: minlwp ! LWP threshold + + real(r8), pointer, dimension(:) :: acprecl_grid ! accumulated precip across timesteps + real(r8), pointer, dimension(:) :: acgcme_grid ! accumulated condensation across timesteps + integer, pointer, dimension(:) :: acnum_grid ! counter for # timesteps accumulated + + ! Variables for liquid water path and column condensation + real(r8) :: tgliqwp_grid(pcols) ! column liquid + real(r8) :: tgcmeliq_grid(pcols) ! column condensation rate (units) + + real(r8) :: pe_grid(pcols) ! precip efficiency for output + real(r8) :: pefrac_grid(pcols) ! fraction of time precip efficiency is written out + real(r8) :: tpr_grid(pcols) ! average accumulated precipitation rate in pe calculation + + ! variables for autoconversion and accretion vertical averages + real(r8) :: vprco_grid(pcols) ! vertical average autoconversion + real(r8) :: vprao_grid(pcols) ! vertical average accretion + real(r8) :: racau_grid(pcols) ! ratio of vertical averages + integer :: cnt_grid(pcols) ! counters + + logical :: lq(pcnst) + + real(r8) :: icimrst_grid(pcols,pver) ! stratus ice mixing ratio - on grid + real(r8) :: icwmrst_grid(pcols,pver) ! stratus water mixing ratio - on grid + + real(r8), pointer :: lambdac_grid(:,:) + real(r8), pointer :: mu_grid(:,:) + real(r8), pointer :: rel_grid(:,:) + real(r8), pointer :: rei_grid(:,:) + real(r8), pointer :: dei_grid(:,:) + real(r8), pointer :: des_grid(:,:) + real(r8), pointer :: iclwpst_grid(:,:) + + real(r8) :: rho_grid(pcols,pver) + real(r8) :: liqcldf_grid(pcols,pver) + real(r8) :: qsout_grid(pcols,pver) + real(r8) :: ncic_grid(pcols,pver) + real(r8) :: niic_grid(pcols,pver) + real(r8) :: rel_fn_grid(pcols,pver) ! Ice effective drop size at fixed number (indirect effect) (microns) - on grid + real(r8) :: qrout_grid(pcols,pver) + real(r8) :: drout2_grid(pcols,pver) + real(r8) :: dsout2_grid(pcols,pver) + real(r8) :: nsout_grid(pcols,pver) + real(r8) :: nrout_grid(pcols,pver) + real(r8) :: reff_rain_grid(pcols,pver) + real(r8) :: reff_snow_grid(pcols,pver) + real(r8) :: cld_grid(pcols,pver) + real(r8) :: pdel_grid(pcols,pver) + real(r8) :: prco_grid(pcols,pver) + real(r8) :: prao_grid(pcols,pver) + real(r8) :: icecldf_grid(pcols,pver) + real(r8) :: icwnc_grid(pcols,pver) + real(r8) :: icinc_grid(pcols,pver) + real(r8) :: qcreso_grid(pcols,pver) + real(r8) :: melto_grid(pcols,pver) + real(r8) :: mnuccco_grid(pcols,pver) + real(r8) :: mnuccto_grid(pcols,pver) + real(r8) :: bergo_grid(pcols,pver) + real(r8) :: homoo_grid(pcols,pver) + real(r8) :: msacwio_grid(pcols,pver) + real(r8) :: psacwso_grid(pcols,pver) + real(r8) :: bergso_grid(pcols,pver) + real(r8) :: cmeiout_grid(pcols,pver) + real(r8) :: qireso_grid(pcols,pver) + real(r8) :: prcio_grid(pcols,pver) + real(r8) :: praio_grid(pcols,pver) + + real(r8) :: nc_grid(pcols,pver) + real(r8) :: ni_grid(pcols,pver) + real(r8) :: qr_grid(pcols,pver) + real(r8) :: nr_grid(pcols,pver) + real(r8) :: qs_grid(pcols,pver) + real(r8) :: ns_grid(pcols,pver) + + real(r8), pointer :: cmeliq_grid(:,:) + + real(r8), pointer :: prec_str_grid(:) + real(r8), pointer :: snow_str_grid(:) + real(r8), pointer :: prec_pcw_grid(:) + real(r8), pointer :: snow_pcw_grid(:) + real(r8), pointer :: prec_sed_grid(:) + real(r8), pointer :: snow_sed_grid(:) + real(r8), pointer :: cldo_grid(:,:) + real(r8), pointer :: nevapr_grid(:,:) + real(r8), pointer :: prain_grid(:,:) + real(r8), pointer :: mgflxprc_grid(:,:) + real(r8), pointer :: mgflxsnw_grid(:,:) + real(r8), pointer :: mgmrprc_grid(:,:) + real(r8), pointer :: mgmrsnw_grid(:,:) + real(r8), pointer :: cvreffliq_grid(:,:) + real(r8), pointer :: cvreffice_grid(:,:) + real(r8), pointer :: rate1ord_cw2pr_st_grid(:,:) + real(r8), pointer :: wsedl_grid(:,:) + real(r8), pointer :: CC_t_grid(:,:) + real(r8), pointer :: CC_qv_grid(:,:) + real(r8), pointer :: CC_ql_grid(:,:) + real(r8), pointer :: CC_qi_grid(:,:) + real(r8), pointer :: CC_nl_grid(:,:) + real(r8), pointer :: CC_ni_grid(:,:) + real(r8), pointer :: CC_qlst_grid(:,:) + real(r8), pointer :: qme_grid(:,:) + real(r8), pointer :: iciwpst_grid(:,:) + real(r8), pointer :: icswp_grid(:,:) + real(r8), pointer :: ast_grid(:,:) + real(r8), pointer :: cldfsnow_grid(:,:) + + real(r8), pointer :: qrout_grid_ptr(:,:) + real(r8), pointer :: qsout_grid_ptr(:,:) + real(r8), pointer :: nrout_grid_ptr(:,:) + real(r8), pointer :: nsout_grid_ptr(:,:) + + integer :: nlev ! number of levels where cloud physics is done + integer :: mgncol ! size of mgcols + integer, allocatable :: mgcols(:) ! Columns with microphysics performed + + logical :: use_subcol_microp + integer :: col_type ! Flag to store whether accessing grid or sub-columns in pbuf_get_field + + character(128) :: errstring ! return status (non-blank for error return) + + ! For rrtmg optics. specified distribution. + real(r8), parameter :: dcon = 25.e-6_r8 ! Convective size distribution effective radius (meters) + real(r8), parameter :: mucon = 5.3_r8 ! Convective size distribution shape parameter + real(r8), parameter :: deicon = 50._r8 ! Convective ice effective diameter (meters) + + real(r8), pointer :: pckdptr(:,:) + + !------------------------------------------------------------------------------- + + ! Find the number of levels used in the microphysics. + nlev = pver - top_lev + 1 + + lchnk = state%lchnk + ncol = state%ncol + psetcols = state%psetcols + ngrdcol = state%ngrdcol + + itim_old = pbuf_old_tim_idx() + + call phys_getopts(use_subcol_microp_out=use_subcol_microp) + + ! Set the col_type flag to grid or subcolumn dependent on the value of use_subcol_microp + call pbuf_col_type_index(use_subcol_microp, col_type=col_type) + + !----------------------- + ! These physics buffer fields are read only and not set in this parameterization + ! If these fields do not have subcolumn data, copy the grid to the subcolumn if subcolumns is turned on + ! If subcolumns is not turned on, then these fields will be grid data + + call pbuf_get_field(pbuf, naai_idx, naai, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, naai_hom_idx, naai_hom, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, npccn_idx, npccn, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, rndst_idx, rndst, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, nacon_idx, nacon, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, relvar_idx, relvar, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, accre_enhan_idx, accre_enhan, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, cmeliq_idx, cmeliq, col_type=col_type, copy_if_needed=use_subcol_microp) + + call pbuf_get_field(pbuf, cld_idx, cld, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), & + col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, concld_idx, concld, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), & + col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, ast_idx, ast, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), & + col_type=col_type, copy_if_needed=use_subcol_microp) + + if (.not. do_cldice) then + call pbuf_get_field(pbuf, tnd_qsnow_idx, tnd_qsnow, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, tnd_nsnow_idx, tnd_nsnow, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, re_ice_idx, re_ice, col_type=col_type, copy_if_needed=use_subcol_microp) + end if + + if (use_hetfrz_classnuc) then + call pbuf_get_field(pbuf, frzimm_idx, frzimm, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, frzcnt_idx, frzcnt, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, frzdep_idx, frzdep, col_type=col_type, copy_if_needed=use_subcol_microp) + end if + + !----------------------- + ! These physics buffer fields are calculated and set in this parameterization + ! If subcolumns is turned on, then these fields will be calculated on a subcolumn grid, otherwise they will be a normal grid + + call pbuf_get_field(pbuf, prec_str_idx, prec_str, col_type=col_type) + call pbuf_get_field(pbuf, snow_str_idx, snow_str, col_type=col_type) + call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw, col_type=col_type) + call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw, col_type=col_type) + call pbuf_get_field(pbuf, prec_sed_idx, prec_sed, col_type=col_type) + call pbuf_get_field(pbuf, snow_sed_idx, snow_sed, col_type=col_type) + call pbuf_get_field(pbuf, nevapr_idx, nevapr, col_type=col_type) + call pbuf_get_field(pbuf, prer_evap_idx, prer_evap, col_type=col_type) + call pbuf_get_field(pbuf, prain_idx, prain, col_type=col_type) + call pbuf_get_field(pbuf, dei_idx, dei, col_type=col_type) + call pbuf_get_field(pbuf, mu_idx, mu, col_type=col_type) + call pbuf_get_field(pbuf, lambdac_idx, lambdac, col_type=col_type) + call pbuf_get_field(pbuf, des_idx, des, col_type=col_type) + call pbuf_get_field(pbuf, ls_flxprc_idx, mgflxprc, col_type=col_type) + call pbuf_get_field(pbuf, ls_flxsnw_idx, mgflxsnw, col_type=col_type) + call pbuf_get_field(pbuf, ls_mrprc_idx, mgmrprc, col_type=col_type) + call pbuf_get_field(pbuf, ls_mrsnw_idx, mgmrsnw, col_type=col_type) + call pbuf_get_field(pbuf, cv_reffliq_idx, cvreffliq, col_type=col_type) + call pbuf_get_field(pbuf, cv_reffice_idx, cvreffice, col_type=col_type) + call pbuf_get_field(pbuf, iciwpst_idx, iciwpst, col_type=col_type) + call pbuf_get_field(pbuf, iclwpst_idx, iclwpst, col_type=col_type) + call pbuf_get_field(pbuf, icswp_idx, icswp, col_type=col_type) + call pbuf_get_field(pbuf, rel_idx, rel, col_type=col_type) + call pbuf_get_field(pbuf, rei_idx, rei, col_type=col_type) + call pbuf_get_field(pbuf, wsedl_idx, wsedl, col_type=col_type) + call pbuf_get_field(pbuf, qme_idx, qme, col_type=col_type) + + call pbuf_get_field(pbuf, cldo_idx, cldo, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) + call pbuf_get_field(pbuf, cldfsnow_idx, cldfsnow, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) + call pbuf_get_field(pbuf, cc_t_idx, CC_t, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) + call pbuf_get_field(pbuf, cc_qv_idx, CC_qv, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) + call pbuf_get_field(pbuf, cc_ql_idx, CC_ql, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) + call pbuf_get_field(pbuf, cc_qi_idx, CC_qi, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) + call pbuf_get_field(pbuf, cc_nl_idx, CC_nl, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) + call pbuf_get_field(pbuf, cc_ni_idx, CC_ni, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) + call pbuf_get_field(pbuf, cc_qlst_idx, CC_qlst, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) + + if (rate1_cw2pr_st_idx > 0) then + call pbuf_get_field(pbuf, rate1_cw2pr_st_idx, rate1ord_cw2pr_st, col_type=col_type) + end if + + if (qrain_idx > 0) call pbuf_get_field(pbuf, qrain_idx, qrout_grid_ptr) + if (qsnow_idx > 0) call pbuf_get_field(pbuf, qsnow_idx, qsout_grid_ptr) + if (nrain_idx > 0) call pbuf_get_field(pbuf, nrain_idx, nrout_grid_ptr) + if (nsnow_idx > 0) call pbuf_get_field(pbuf, nsnow_idx, nsout_grid_ptr) + + !----------------------- + ! If subcolumns is turned on, all calculated fields which are on subcolumns + ! need to be retrieved on the grid as well for storing averaged values + + if (use_subcol_microp) then + call pbuf_get_field(pbuf, prec_str_idx, prec_str_grid) + call pbuf_get_field(pbuf, snow_str_idx, snow_str_grid) + call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw_grid) + call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw_grid) + call pbuf_get_field(pbuf, prec_sed_idx, prec_sed_grid) + call pbuf_get_field(pbuf, snow_sed_idx, snow_sed_grid) + call pbuf_get_field(pbuf, nevapr_idx, nevapr_grid) + call pbuf_get_field(pbuf, prain_idx, prain_grid) + call pbuf_get_field(pbuf, dei_idx, dei_grid) + call pbuf_get_field(pbuf, mu_idx, mu_grid) + call pbuf_get_field(pbuf, lambdac_idx, lambdac_grid) + call pbuf_get_field(pbuf, des_idx, des_grid) + call pbuf_get_field(pbuf, ls_flxprc_idx, mgflxprc_grid) + call pbuf_get_field(pbuf, ls_flxsnw_idx, mgflxsnw_grid) + call pbuf_get_field(pbuf, ls_mrprc_idx, mgmrprc_grid) + call pbuf_get_field(pbuf, ls_mrsnw_idx, mgmrsnw_grid) + call pbuf_get_field(pbuf, cv_reffliq_idx, cvreffliq_grid) + call pbuf_get_field(pbuf, cv_reffice_idx, cvreffice_grid) + call pbuf_get_field(pbuf, iciwpst_idx, iciwpst_grid) + call pbuf_get_field(pbuf, iclwpst_idx, iclwpst_grid) + call pbuf_get_field(pbuf, icswp_idx, icswp_grid) + call pbuf_get_field(pbuf, rel_idx, rel_grid) + call pbuf_get_field(pbuf, rei_idx, rei_grid) + call pbuf_get_field(pbuf, wsedl_idx, wsedl_grid) + call pbuf_get_field(pbuf, qme_idx, qme_grid) + + call pbuf_get_field(pbuf, cldo_idx, cldo_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, cldfsnow_idx, cldfsnow_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, cc_t_idx, CC_t_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, cc_qv_idx, CC_qv_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, cc_ql_idx, CC_ql_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, cc_qi_idx, CC_qi_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, cc_nl_idx, CC_nl_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, cc_ni_idx, CC_ni_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, cc_qlst_idx, CC_qlst_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + + if (rate1_cw2pr_st_idx > 0) then + call pbuf_get_field(pbuf, rate1_cw2pr_st_idx, rate1ord_cw2pr_st_grid) + end if + + end if + + !----------------------- + ! These are only on the grid regardless of whether subcolumns are turned on or not + call pbuf_get_field(pbuf, ls_reffrain_idx, mgreffrain_grid) + call pbuf_get_field(pbuf, ls_reffsnow_idx, mgreffsnow_grid) + call pbuf_get_field(pbuf, acpr_idx, acprecl_grid) + call pbuf_get_field(pbuf, acgcme_idx, acgcme_grid) + call pbuf_get_field(pbuf, acnum_idx, acnum_grid) + call pbuf_get_field(pbuf, cmeliq_idx, cmeliq_grid) + call pbuf_get_field(pbuf, ast_idx, ast_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + + call pbuf_get_field(pbuf, evprain_st_idx, evprain_st_grid) + call pbuf_get_field(pbuf, evpsnow_st_idx, evpsnow_st_grid) + + ! Only MG 1 defines this field so far. + if (micro_mg_version == 1 .and. micro_mg_sub_version == 0) then + call pbuf_get_field(pbuf, am_evp_st_idx, am_evp_st_grid) + end if + + !------------------------------------------------------------------------------------- + ! Microphysics assumes 'liquid stratus frac = ice stratus frac + ! = max( liquid stratus frac, ice stratus frac )'. + alst_mic => ast + aist_mic => ast + + ! Output initial in-cloud LWP (before microphysics) + + iclwpi = 0._r8 + iciwpi = 0._r8 + + do i = 1, ncol + do k = top_lev, pver + iclwpi(i) = iclwpi(i) + & + min(state%q(i,k,ixcldliq) / max(mincld,ast(i,k)),0.005_r8) & + * state%pdel(i,k) / gravit + iciwpi(i) = iciwpi(i) + & + min(state%q(i,k,ixcldice) / max(mincld,ast(i,k)),0.005_r8) & + * state%pdel(i,k) / gravit + end do + end do + + cldo(:ncol,top_lev:pver)=ast(:ncol,top_lev:pver) + + ! Initialize local state from input. + call physics_state_copy(state, state_loc) + + ! Initialize ptend for output. + lq = .false. + lq(1) = .true. + lq(ixcldliq) = .true. + lq(ixcldice) = .true. + lq(ixnumliq) = .true. + lq(ixnumice) = .true. + if (micro_mg_version > 1) then + lq(ixrain) = .true. + lq(ixsnow) = .true. + lq(ixnumrain) = .true. + lq(ixnumsnow) = .true. + end if + + ! the name 'cldwat' triggers special tests on cldliq + ! and cldice in physics_update + call physics_ptend_init(ptend, psetcols, "cldwat", ls=.true., lq=lq) + + select case (micro_mg_version) + case (1) + select case (micro_mg_sub_version) + case (0) + call micro_mg_get_cols1_0(ncol, nlev, top_lev, state%q(:,:,ixcldliq), & + state%q(:,:,ixcldice), mgncol, mgcols) + case (5) + call micro_mg_get_cols1_5(ncol, nlev, top_lev, state%q(:,:,ixcldliq), & + state%q(:,:,ixcldice), mgncol, mgcols) + end select + case (2) + call micro_mg_get_cols2_0(ncol, nlev, top_lev, state%q(:,:,ixcldliq), & + state%q(:,:,ixcldice), state%q(:,:,ixrain), state%q(:,:,ixsnow), & + mgncol, mgcols) + end select + + packer = MGPacker(psetcols, pver, mgcols, top_lev) + post_proc = MGPostProc(packer) + + allocate(packed_rate1ord_cw2pr_st(mgncol,nlev)) + pckdptr => packed_rate1ord_cw2pr_st ! workaround an apparent pgi compiler bug on goldbach + call post_proc%add_field(p(rate1cld), pckdptr) + allocate(packed_tlat(mgncol,nlev)) + call post_proc%add_field(p(tlat), p(packed_tlat)) + allocate(packed_qvlat(mgncol,nlev)) + call post_proc%add_field(p(qvlat), p(packed_qvlat)) + allocate(packed_qctend(mgncol,nlev)) + call post_proc%add_field(p(qcten), p(packed_qctend)) + allocate(packed_qitend(mgncol,nlev)) + call post_proc%add_field(p(qiten), p(packed_qitend)) + allocate(packed_nctend(mgncol,nlev)) + call post_proc%add_field(p(ncten), p(packed_nctend)) + allocate(packed_nitend(mgncol,nlev)) + call post_proc%add_field(p(niten), p(packed_nitend)) + + if (micro_mg_version > 1) then + allocate(packed_qrtend(mgncol,nlev)) + call post_proc%add_field(p(qrten), p(packed_qrtend)) + allocate(packed_qstend(mgncol,nlev)) + call post_proc%add_field(p(qsten), p(packed_qstend)) + allocate(packed_nrtend(mgncol,nlev)) + call post_proc%add_field(p(nrten), p(packed_nrtend)) + allocate(packed_nstend(mgncol,nlev)) + call post_proc%add_field(p(nsten), p(packed_nstend)) + allocate(packed_umr(mgncol,nlev)) + call post_proc%add_field(p(umr), p(packed_umr)) + allocate(packed_ums(mgncol,nlev)) + call post_proc%add_field(p(ums), p(packed_ums)) + else if (micro_mg_sub_version == 0) then + allocate(packed_am_evp_st(mgncol,nlev)) + call post_proc%add_field(p(am_evp_st), p(packed_am_evp_st)) + end if + + allocate(packed_prect(mgncol)) + call post_proc%add_field(p(prect), p(packed_prect)) + allocate(packed_preci(mgncol)) + call post_proc%add_field(p(preci), p(packed_preci)) + allocate(packed_nevapr(mgncol,nlev)) + call post_proc%add_field(p(nevapr), p(packed_nevapr)) + allocate(packed_evapsnow(mgncol,nlev)) + call post_proc%add_field(p(evapsnow), p(packed_evapsnow)) + allocate(packed_prain(mgncol,nlev)) + call post_proc%add_field(p(prain), p(packed_prain)) + allocate(packed_prodsnow(mgncol,nlev)) + call post_proc%add_field(p(prodsnow), p(packed_prodsnow)) + allocate(packed_cmeout(mgncol,nlev)) + call post_proc%add_field(p(cmeice), p(packed_cmeout)) + allocate(packed_qsout(mgncol,nlev)) + call post_proc%add_field(p(qsout), p(packed_qsout)) + allocate(packed_rflx(mgncol,nlev+1)) + call post_proc%add_field(p(rflx), p(packed_rflx)) + allocate(packed_sflx(mgncol,nlev+1)) + call post_proc%add_field(p(sflx), p(packed_sflx)) + allocate(packed_qrout(mgncol,nlev)) + call post_proc%add_field(p(qrout), p(packed_qrout)) + allocate(packed_qcsevap(mgncol,nlev)) + call post_proc%add_field(p(qcsevap), p(packed_qcsevap)) + allocate(packed_qisevap(mgncol,nlev)) + call post_proc%add_field(p(qisevap), p(packed_qisevap)) + allocate(packed_qvres(mgncol,nlev)) + call post_proc%add_field(p(qvres), p(packed_qvres)) + allocate(packed_cmei(mgncol,nlev)) + call post_proc%add_field(p(cmeiout), p(packed_cmei)) + allocate(packed_vtrmc(mgncol,nlev)) + call post_proc%add_field(p(vtrmc), p(packed_vtrmc)) + allocate(packed_vtrmi(mgncol,nlev)) + call post_proc%add_field(p(vtrmi), p(packed_vtrmi)) + allocate(packed_qcsedten(mgncol,nlev)) + call post_proc%add_field(p(qcsedten), p(packed_qcsedten)) + allocate(packed_qisedten(mgncol,nlev)) + call post_proc%add_field(p(qisedten), p(packed_qisedten)) + if (micro_mg_version > 1) then + allocate(packed_qrsedten(mgncol,nlev)) + call post_proc%add_field(p(qrsedten), p(packed_qrsedten)) + allocate(packed_qssedten(mgncol,nlev)) + call post_proc%add_field(p(qssedten), p(packed_qssedten)) + end if + + allocate(packed_pra(mgncol,nlev)) + call post_proc%add_field(p(prao), p(packed_pra)) + allocate(packed_prc(mgncol,nlev)) + call post_proc%add_field(p(prco), p(packed_prc)) + allocate(packed_mnuccc(mgncol,nlev)) + call post_proc%add_field(p(mnuccco), p(packed_mnuccc)) + allocate(packed_mnucct(mgncol,nlev)) + call post_proc%add_field(p(mnuccto), p(packed_mnucct)) + allocate(packed_msacwi(mgncol,nlev)) + call post_proc%add_field(p(msacwio), p(packed_msacwi)) + allocate(packed_psacws(mgncol,nlev)) + call post_proc%add_field(p(psacwso), p(packed_psacws)) + allocate(packed_bergs(mgncol,nlev)) + call post_proc%add_field(p(bergso), p(packed_bergs)) + allocate(packed_berg(mgncol,nlev)) + call post_proc%add_field(p(bergo), p(packed_berg)) + allocate(packed_melt(mgncol,nlev)) + call post_proc%add_field(p(melto), p(packed_melt)) + allocate(packed_homo(mgncol,nlev)) + call post_proc%add_field(p(homoo), p(packed_homo)) + allocate(packed_qcres(mgncol,nlev)) + call post_proc%add_field(p(qcreso), p(packed_qcres)) + allocate(packed_prci(mgncol,nlev)) + call post_proc%add_field(p(prcio), p(packed_prci)) + allocate(packed_prai(mgncol,nlev)) + call post_proc%add_field(p(praio), p(packed_prai)) + allocate(packed_qires(mgncol,nlev)) + call post_proc%add_field(p(qireso), p(packed_qires)) + allocate(packed_mnuccr(mgncol,nlev)) + call post_proc%add_field(p(mnuccro), p(packed_mnuccr)) + allocate(packed_pracs(mgncol,nlev)) + call post_proc%add_field(p(pracso), p(packed_pracs)) + allocate(packed_meltsdt(mgncol,nlev)) + call post_proc%add_field(p(meltsdt), p(packed_meltsdt)) + allocate(packed_frzrdt(mgncol,nlev)) + call post_proc%add_field(p(frzrdt), p(packed_frzrdt)) + allocate(packed_mnuccd(mgncol,nlev)) + call post_proc%add_field(p(mnuccdo), p(packed_mnuccd)) + allocate(packed_nrout(mgncol,nlev)) + call post_proc%add_field(p(nrout), p(packed_nrout)) + allocate(packed_nsout(mgncol,nlev)) + call post_proc%add_field(p(nsout), p(packed_nsout)) + + allocate(packed_refl(mgncol,nlev)) + call post_proc%add_field(p(refl), p(packed_refl), fillvalue=-9999._r8) + allocate(packed_arefl(mgncol,nlev)) + call post_proc%add_field(p(arefl), p(packed_arefl)) + allocate(packed_areflz(mgncol,nlev)) + call post_proc%add_field(p(areflz), p(packed_areflz)) + allocate(packed_frefl(mgncol,nlev)) + call post_proc%add_field(p(frefl), p(packed_frefl)) + allocate(packed_csrfl(mgncol,nlev)) + call post_proc%add_field(p(csrfl), p(packed_csrfl), fillvalue=-9999._r8) + allocate(packed_acsrfl(mgncol,nlev)) + call post_proc%add_field(p(acsrfl), p(packed_acsrfl)) + allocate(packed_fcsrfl(mgncol,nlev)) + call post_proc%add_field(p(fcsrfl), p(packed_fcsrfl)) + + allocate(packed_rercld(mgncol,nlev)) + call post_proc%add_field(p(rercld), p(packed_rercld)) + allocate(packed_ncai(mgncol,nlev)) + call post_proc%add_field(p(ncai), p(packed_ncai)) + allocate(packed_ncal(mgncol,nlev)) + call post_proc%add_field(p(ncal), p(packed_ncal)) + allocate(packed_qrout2(mgncol,nlev)) + call post_proc%add_field(p(qrout2), p(packed_qrout2)) + allocate(packed_qsout2(mgncol,nlev)) + call post_proc%add_field(p(qsout2), p(packed_qsout2)) + allocate(packed_nrout2(mgncol,nlev)) + call post_proc%add_field(p(nrout2), p(packed_nrout2)) + allocate(packed_nsout2(mgncol,nlev)) + call post_proc%add_field(p(nsout2), p(packed_nsout2)) + allocate(packed_freqs(mgncol,nlev)) + call post_proc%add_field(p(freqs), p(packed_freqs)) + allocate(packed_freqr(mgncol,nlev)) + call post_proc%add_field(p(freqr), p(packed_freqr)) + allocate(packed_nfice(mgncol,nlev)) + call post_proc%add_field(p(nfice), p(packed_nfice)) + if (micro_mg_version /= 1 .or. micro_mg_sub_version /= 0) then + allocate(packed_qcrat(mgncol,nlev)) + call post_proc%add_field(p(qcrat), p(packed_qcrat), fillvalue=1._r8) + end if + + ! The following are all variables related to sizes, where it does not + ! necessarily make sense to average over time steps. Instead, we keep + ! the value from the last substep, which is what "accum_null" does. + allocate(packed_rel(mgncol,nlev)) + call post_proc%add_field(p(rel), p(packed_rel), & + fillvalue=10._r8, accum_method=accum_null) + allocate(packed_rei(mgncol,nlev)) + call post_proc%add_field(p(rei), p(packed_rei), & + fillvalue=25._r8, accum_method=accum_null) + allocate(packed_lambdac(mgncol,nlev)) + call post_proc%add_field(p(lambdac), p(packed_lambdac), & + accum_method=accum_null) + allocate(packed_mu(mgncol,nlev)) + call post_proc%add_field(p(mu), p(packed_mu), & + accum_method=accum_null) + allocate(packed_des(mgncol,nlev)) + call post_proc%add_field(p(des), p(packed_des), & + accum_method=accum_null) + allocate(packed_dei(mgncol,nlev)) + call post_proc%add_field(p(dei), p(packed_dei), & + accum_method=accum_null) + allocate(packed_prer_evap(mgncol,nlev)) + call post_proc%add_field(p(prer_evap), p(packed_prer_evap), & + accum_method=accum_null) + + ! Allocate all the dummies with MG sizes. + allocate(rel_fn_dum(mgncol,nlev)) + allocate(dsout2_dum(mgncol,nlev)) + allocate(drout_dum(mgncol,nlev)) + allocate(reff_rain_dum(mgncol,nlev)) + allocate(reff_snow_dum(mgncol,nlev)) + + ! Pack input variables that are not updated during substeps. + allocate(packed_relvar(mgncol,nlev)) + packed_relvar = packer%pack(relvar) + allocate(packed_accre_enhan(mgncol,nlev)) + packed_accre_enhan = packer%pack(accre_enhan) + + allocate(packed_p(mgncol,nlev)) + packed_p = packer%pack(state_loc%pmid) + allocate(packed_pdel(mgncol,nlev)) + packed_pdel = packer%pack(state_loc%pdel) + + allocate(packed_pint(mgncol,nlev+1)) + packed_pint = packer%pack_interface(state_loc%pint) + + allocate(packed_cldn(mgncol,nlev)) + packed_cldn = packer%pack(ast) + allocate(packed_liqcldf(mgncol,nlev)) + packed_liqcldf = packer%pack(alst_mic) + allocate(packed_icecldf(mgncol,nlev)) + packed_icecldf = packer%pack(aist_mic) + + allocate(packed_naai(mgncol,nlev)) + packed_naai = packer%pack(naai) + allocate(packed_npccn(mgncol,nlev)) + packed_npccn = packer%pack(npccn) + + allocate(packed_rndst(mgncol,nlev,size(rndst, 3))) + packed_rndst = packer%pack(rndst) + allocate(packed_nacon(mgncol,nlev,size(nacon, 3))) + packed_nacon = packer%pack(nacon) + + if (.not. do_cldice) then + allocate(packed_tnd_qsnow(mgncol,nlev)) + packed_tnd_qsnow = packer%pack(tnd_qsnow) + allocate(packed_tnd_nsnow(mgncol,nlev)) + packed_tnd_nsnow = packer%pack(tnd_nsnow) + allocate(packed_re_ice(mgncol,nlev)) + packed_re_ice = packer%pack(re_ice) + else + nullify(packed_tnd_qsnow) + nullify(packed_tnd_nsnow) + nullify(packed_re_ice) + end if + + if (use_hetfrz_classnuc) then + allocate(packed_frzimm(mgncol,nlev)) + packed_frzimm = packer%pack(frzimm) + allocate(packed_frzcnt(mgncol,nlev)) + packed_frzcnt = packer%pack(frzcnt) + allocate(packed_frzdep(mgncol,nlev)) + packed_frzdep = packer%pack(frzdep) + else + nullify(packed_frzimm) + nullify(packed_frzcnt) + nullify(packed_frzdep) + end if + + ! Allocate input variables that are updated during substeps. + allocate(packed_t(mgncol,nlev)) + allocate(packed_q(mgncol,nlev)) + allocate(packed_qc(mgncol,nlev)) + allocate(packed_nc(mgncol,nlev)) + allocate(packed_qi(mgncol,nlev)) + allocate(packed_ni(mgncol,nlev)) + if (micro_mg_version > 1) then + allocate(packed_qr(mgncol,nlev)) + allocate(packed_nr(mgncol,nlev)) + allocate(packed_qs(mgncol,nlev)) + allocate(packed_ns(mgncol,nlev)) + end if + + do it = 1, num_steps + + ! Pack input variables that are updated during substeps. + packed_t = packer%pack(state_loc%t) + packed_q = packer%pack(state_loc%q(:,:,1)) + packed_qc = packer%pack(state_loc%q(:,:,ixcldliq)) + packed_nc = packer%pack(state_loc%q(:,:,ixnumliq)) + packed_qi = packer%pack(state_loc%q(:,:,ixcldice)) + packed_ni = packer%pack(state_loc%q(:,:,ixnumice)) + if (micro_mg_version > 1) then + packed_qr = packer%pack(state_loc%q(:,:,ixrain)) + packed_nr = packer%pack(state_loc%q(:,:,ixnumrain)) + packed_qs = packer%pack(state_loc%q(:,:,ixsnow)) + packed_ns = packer%pack(state_loc%q(:,:,ixnumsnow)) + end if + + select case (micro_mg_version) + case (1) + select case (micro_mg_sub_version) + case (0) + + call micro_mg_tend1_0( & + microp_uniform, mgncol, nlev, mgncol, 1, dtime/num_steps, & + packed_t, packed_q, packed_qc, packed_qi, packed_nc, & + packed_ni, packed_p, packed_pdel, packed_cldn, packed_liqcldf,& + packed_relvar, packed_accre_enhan, & + packed_icecldf, packed_rate1ord_cw2pr_st, packed_naai, packed_npccn, & + packed_rndst, packed_nacon, packed_tlat, packed_qvlat, packed_qctend, & + packed_qitend, packed_nctend, packed_nitend, packed_rel, rel_fn_dum, & + packed_rei, packed_prect, packed_preci, packed_nevapr, packed_evapsnow, packed_am_evp_st, & + packed_prain, packed_prodsnow, packed_cmeout, packed_dei, packed_mu, & + packed_lambdac, packed_qsout, packed_des, packed_rflx, packed_sflx, & + packed_qrout, reff_rain_dum, reff_snow_dum, packed_qcsevap, packed_qisevap, & + packed_qvres, packed_cmei, packed_vtrmc, packed_vtrmi, packed_qcsedten, & + packed_qisedten, packed_pra, packed_prc, packed_mnuccc, packed_mnucct, & + packed_msacwi, packed_psacws, packed_bergs, packed_berg, packed_melt, & + packed_homo, packed_qcres, packed_prci, packed_prai, packed_qires, & + packed_mnuccr, packed_pracs, packed_meltsdt, packed_frzrdt, packed_mnuccd, & + packed_nrout, packed_nsout, packed_refl, packed_arefl, packed_areflz, & + packed_frefl, packed_csrfl, packed_acsrfl, packed_fcsrfl, packed_rercld, & + packed_ncai, packed_ncal, packed_qrout2, packed_qsout2, packed_nrout2, & + packed_nsout2, drout_dum, dsout2_dum, packed_freqs,packed_freqr, & + packed_nfice, packed_prer_evap, do_cldice, errstring, & + packed_tnd_qsnow, packed_tnd_nsnow, packed_re_ice, & + packed_frzimm, packed_frzcnt, packed_frzdep) + + case (5) + + call micro_mg_tend1_5( & + mgncol, nlev, dtime/num_steps, & + packed_t, packed_q, & + packed_qc, packed_qi, & + packed_nc, packed_ni, & + packed_relvar, packed_accre_enhan, & + packed_p, packed_pdel, packed_pint, & + packed_cldn, packed_liqcldf, packed_icecldf, & + packed_rate1ord_cw2pr_st, packed_naai, packed_npccn, packed_rndst, packed_nacon, & + packed_tlat, packed_qvlat, packed_qctend, packed_qitend, packed_nctend, packed_nitend, & + packed_rel, rel_fn_dum, packed_rei, packed_prect, packed_preci, & + packed_nevapr, packed_evapsnow, packed_prain, packed_prodsnow, packed_cmeout, packed_dei, & + packed_mu, packed_lambdac, packed_qsout, packed_des, packed_rflx, packed_sflx, & + packed_qrout, reff_rain_dum, reff_snow_dum, & + packed_qcsevap, packed_qisevap, packed_qvres, packed_cmei, packed_vtrmc, packed_vtrmi, & + packed_qcsedten, packed_qisedten, packed_pra, packed_prc, packed_mnuccc, packed_mnucct, & + packed_msacwi, packed_psacws, packed_bergs, packed_berg, packed_melt, packed_homo, & + packed_qcres, packed_prci, packed_prai, packed_qires, & + packed_mnuccr, packed_pracs, packed_meltsdt, packed_frzrdt, packed_mnuccd, & + packed_nrout, packed_nsout, packed_refl, packed_arefl, packed_areflz, packed_frefl, & + packed_csrfl, packed_acsrfl, packed_fcsrfl, packed_rercld, & + packed_ncai, packed_ncal, packed_qrout2, packed_qsout2, packed_nrout2, packed_nsout2, & + drout_dum, dsout2_dum, packed_freqs, packed_freqr, packed_nfice, packed_qcrat, & + errstring, & + packed_tnd_qsnow, packed_tnd_nsnow, packed_re_ice, packed_prer_evap, & + packed_frzimm, packed_frzcnt, packed_frzdep) + + end select + case(2) + select case (micro_mg_sub_version) + case (0) + + call micro_mg_tend2_0( & + mgncol, nlev, dtime/num_steps,& + packed_t, packed_q, & + packed_qc, packed_qi, & + packed_nc, packed_ni, & + packed_qr, packed_qs, & + packed_nr, packed_ns, & + packed_relvar, packed_accre_enhan, & + packed_p, packed_pdel, & + packed_cldn, packed_liqcldf, packed_icecldf, & + packed_rate1ord_cw2pr_st, & + packed_naai, packed_npccn, & + packed_rndst, packed_nacon, & + packed_tlat, packed_qvlat, & + packed_qctend, packed_qitend, & + packed_nctend, packed_nitend, & + packed_qrtend, packed_qstend, & + packed_nrtend, packed_nstend, & + packed_rel, rel_fn_dum, packed_rei, & + packed_prect, packed_preci, & + packed_nevapr, packed_evapsnow, & + packed_prain, packed_prodsnow, & + packed_cmeout, packed_dei, & + packed_mu, packed_lambdac, & + packed_qsout, packed_des, & + packed_rflx, packed_sflx, packed_qrout, & + reff_rain_dum, reff_snow_dum, & + packed_qcsevap, packed_qisevap, packed_qvres, & + packed_cmei, packed_vtrmc, packed_vtrmi, & + packed_umr, packed_ums, & + packed_qcsedten, packed_qisedten, & + packed_qrsedten, packed_qssedten, & + packed_pra, packed_prc, & + packed_mnuccc, packed_mnucct, packed_msacwi, & + packed_psacws, packed_bergs, packed_berg, & + packed_melt, packed_homo, & + packed_qcres, packed_prci, packed_prai, & + packed_qires, packed_mnuccr, packed_pracs, & + packed_meltsdt, packed_frzrdt, packed_mnuccd, & + packed_nrout, packed_nsout, & + packed_refl, packed_arefl, packed_areflz, & + packed_frefl, packed_csrfl, packed_acsrfl, & + packed_fcsrfl, packed_rercld, & + packed_ncai, packed_ncal, & + packed_qrout2, packed_qsout2, & + packed_nrout2, packed_nsout2, & + drout_dum, dsout2_dum, & + packed_freqs, packed_freqr, & + packed_nfice, packed_qcrat, & + errstring, & + packed_tnd_qsnow,packed_tnd_nsnow,packed_re_ice,& + packed_prer_evap, & + packed_frzimm, packed_frzcnt, packed_frzdep ) + end select + end select + + call handle_errmsg(errstring, subname="micro_mg_tend") + + call physics_ptend_init(ptend_loc, psetcols, "micro_mg", & + ls=.true., lq=lq) + + ! Set local tendency. + ptend_loc%s = packer%unpack(packed_tlat, 0._r8) + ptend_loc%q(:,:,1) = packer%unpack(packed_qvlat, 0._r8) + ptend_loc%q(:,:,ixcldliq) = packer%unpack(packed_qctend, 0._r8) + ptend_loc%q(:,:,ixcldice) = packer%unpack(packed_qitend, 0._r8) + ptend_loc%q(:,:,ixnumliq) = packer%unpack(packed_nctend, & + -state_loc%q(:,:,ixnumliq)/(dtime/num_steps)) + if (do_cldice) then + ptend_loc%q(:,:,ixnumice) = packer%unpack(packed_nitend, & + -state_loc%q(:,:,ixnumice)/(dtime/num_steps)) + else + ! In this case, the tendency should be all 0. + if (any(packed_nitend /= 0._r8)) & + call endrun("micro_mg_cam:ERROR - MG microphysics is configured not to prognose cloud ice,"// & + " but micro_mg_tend has ice number tendencies.") + ptend_loc%q(:,:,ixnumice) = 0._r8 + end if + + if (micro_mg_version > 1) then + ptend_loc%q(:,:,ixrain) = packer%unpack(packed_qrtend, 0._r8) + ptend_loc%q(:,:,ixsnow) = packer%unpack(packed_qstend, 0._r8) + ptend_loc%q(:,:,ixnumrain) = packer%unpack(packed_nrtend, & + -state_loc%q(:,:,ixnumrain)/(dtime/num_steps)) + ptend_loc%q(:,:,ixnumsnow) = packer%unpack(packed_nstend, & + -state_loc%q(:,:,ixnumsnow)/(dtime/num_steps)) + end if + + ! Sum into overall ptend + call physics_ptend_sum(ptend_loc, ptend, ncol) + + ! Update local state + call physics_update(state_loc, ptend_loc, dtime/num_steps) + + ! Sum all outputs for averaging. + call post_proc%accumulate() + + end do + + ! Divide ptend by substeps. + call physics_ptend_scale(ptend, 1._r8/num_steps, ncol) + + ! Use summed outputs to produce averages + call post_proc%process_and_unpack() + + call post_proc%finalize() + + if (associated(packed_tnd_qsnow)) deallocate(packed_tnd_qsnow) + if (associated(packed_tnd_nsnow)) deallocate(packed_tnd_nsnow) + if (associated(packed_re_ice)) deallocate(packed_re_ice) + if (associated(packed_frzimm)) deallocate(packed_frzimm) + if (associated(packed_frzcnt)) deallocate(packed_frzcnt) + if (associated(packed_frzdep)) deallocate(packed_frzdep) + + ! Check to make sure that the microphysics code is respecting the flags that control + ! whether MG should be prognosing cloud ice and cloud liquid or not. + if (.not. do_cldice) then + if (any(ptend%q(:ncol,top_lev:pver,ixcldice) /= 0.0_r8)) & + call endrun("micro_mg_cam:ERROR - MG microphysics is configured not to prognose cloud ice,"// & + " but micro_mg_tend has ice mass tendencies.") + if (any(ptend%q(:ncol,top_lev:pver,ixnumice) /= 0.0_r8)) & + call endrun("micro_mg_cam:ERROR - MG microphysics is configured not to prognose cloud ice,"// & + " but micro_mg_tend has ice number tendencies.") + end if + if (.not. do_cldliq) then + if (any(ptend%q(:ncol,top_lev:pver,ixcldliq) /= 0.0_r8)) & + call endrun("micro_mg_cam:ERROR - MG microphysics is configured not to prognose cloud liquid,"// & + " but micro_mg_tend has liquid mass tendencies.") + if (any(ptend%q(:ncol,top_lev:pver,ixnumliq) /= 0.0_r8)) & + call endrun("micro_mg_cam:ERROR - MG microphysics is configured not to prognose cloud liquid,"// & + " but micro_mg_tend has liquid number tendencies.") + end if + + mnuccdohet = 0._r8 + do k=top_lev,pver + do i=1,ncol + if (naai(i,k) > 0._r8) then + mnuccdohet(i,k) = mnuccdo(i,k) - (naai_hom(i,k)/naai(i,k))*mnuccdo(i,k) + end if + end do + end do + + mgflxprc(:ncol,top_lev:pverp) = rflx(:ncol,top_lev:pverp) + sflx(:ncol,top_lev:pverp) + mgflxsnw(:ncol,top_lev:pverp) = sflx(:ncol,top_lev:pverp) + + mgmrprc(:ncol,top_lev:pver) = qrout(:ncol,top_lev:pver) + qsout(:ncol,top_lev:pver) + mgmrsnw(:ncol,top_lev:pver) = qsout(:ncol,top_lev:pver) + + !! calculate effective radius of convective liquid and ice using dcon and deicon (not used by code, not useful for COSP) + !! hard-coded as average of hard-coded values used for deep/shallow convective detrainment (near line 1502/1505) + cvreffliq(:ncol,top_lev:pver) = 9.0_r8 + cvreffice(:ncol,top_lev:pver) = 37.0_r8 + + ! Reassign rate1 if modal aerosols + if (rate1_cw2pr_st_idx > 0) then + rate1ord_cw2pr_st(:ncol,top_lev:pver) = rate1cld(:ncol,top_lev:pver) + end if + + ! Sedimentation velocity for liquid stratus cloud droplet + wsedl(:ncol,top_lev:pver) = vtrmc(:ncol,top_lev:pver) + + ! Microphysical tendencies for use in the macrophysics at the next time step + CC_T(:ncol,top_lev:pver) = tlat(:ncol,top_lev:pver)/cpair + CC_qv(:ncol,top_lev:pver) = qvlat(:ncol,top_lev:pver) + CC_ql(:ncol,top_lev:pver) = qcten(:ncol,top_lev:pver) + CC_qi(:ncol,top_lev:pver) = qiten(:ncol,top_lev:pver) + CC_nl(:ncol,top_lev:pver) = ncten(:ncol,top_lev:pver) + CC_ni(:ncol,top_lev:pver) = niten(:ncol,top_lev:pver) + CC_qlst(:ncol,top_lev:pver) = qcten(:ncol,top_lev:pver)/max(0.01_r8,alst_mic(:ncol,top_lev:pver)) + + ! Net micro_mg_cam condensation rate + qme(:ncol,top_lev:pver) = cmeliq(:ncol,top_lev:pver) + cmeiout(:ncol,top_lev:pver) + + ! For precip, accumulate only total precip in prec_pcw and snow_pcw variables. + ! Other precip output variables are set to 0 + ! Do not subscript by ncol here, because in physpkg we divide the whole + ! array and need to avoid an FPE due to uninitialized data. + prec_pcw = prect + snow_pcw = preci + prec_sed = 0._r8 + snow_sed = 0._r8 + prec_str = prec_pcw + prec_sed + snow_str = snow_pcw + snow_sed + + icecldf(:ncol,top_lev:pver) = ast(:ncol,top_lev:pver) + liqcldf(:ncol,top_lev:pver) = ast(:ncol,top_lev:pver) + + ! ------------------------------------------------------------ ! + ! Compute in cloud ice and liquid mixing ratios ! + ! Note that 'iclwp, iciwp' are used for radiation computation. ! + ! ------------------------------------------------------------ ! + + icinc = 0._r8 + icwnc = 0._r8 + iciwpst = 0._r8 + iclwpst = 0._r8 + icswp = 0._r8 + cldfsnow = 0._r8 + + do k = top_lev, pver + do i = 1, ncol + ! Limits for in-cloud mixing ratios consistent with MG microphysics + ! in-cloud mixing ratio maximum limit of 0.005 kg/kg + icimrst(i,k) = min( state_loc%q(i,k,ixcldice) / max(mincld,icecldf(i,k)),0.005_r8 ) + icwmrst(i,k) = min( state_loc%q(i,k,ixcldliq) / max(mincld,liqcldf(i,k)),0.005_r8 ) + icinc(i,k) = state_loc%q(i,k,ixnumice) / max(mincld,icecldf(i,k)) * & + state_loc%pmid(i,k) / (287.15_r8*state_loc%t(i,k)) + icwnc(i,k) = state_loc%q(i,k,ixnumliq) / max(mincld,liqcldf(i,k)) * & + state_loc%pmid(i,k) / (287.15_r8*state_loc%t(i,k)) + ! Calculate micro_mg_cam cloud water paths in each layer + ! Note: uses stratiform cloud fraction! + iciwpst(i,k) = min(state_loc%q(i,k,ixcldice)/max(mincld,ast(i,k)),0.005_r8) * state_loc%pdel(i,k) / gravit + iclwpst(i,k) = min(state_loc%q(i,k,ixcldliq)/max(mincld,ast(i,k)),0.005_r8) * state_loc%pdel(i,k) / gravit + + ! ------------------------------ ! + ! Adjust cloud fraction for snow ! + ! ------------------------------ ! + cldfsnow(i,k) = cld(i,k) + ! If cloud and only ice ( no convective cloud or ice ), then set to 0. + if( ( cldfsnow(i,k) .gt. 1.e-4_r8 ) .and. & + ( concld(i,k) .lt. 1.e-4_r8 ) .and. & + ( state_loc%q(i,k,ixcldliq) .lt. 1.e-10_r8 ) ) then + cldfsnow(i,k) = 0._r8 + end if + ! If no cloud and snow, then set to 0.25 + if( ( cldfsnow(i,k) .lt. 1.e-4_r8 ) .and. ( qsout(i,k) .gt. 1.e-6_r8 ) ) then + cldfsnow(i,k) = 0.25_r8 + end if + ! Calculate in-cloud snow water path + icswp(i,k) = qsout(i,k) / max( mincld, cldfsnow(i,k) ) * state_loc%pdel(i,k) / gravit + end do + end do + + ! Calculate cloud fraction for prognostic precip sizes. + if (micro_mg_version > 1) then + ! Cloud fraction for purposes of precipitation is maximum cloud + ! fraction out of all the layers that the precipitation may be + ! falling down from. + cldmax = max(mincld, ast) + do k = top_lev+1, pver + where (state_loc%q(:ncol,k-1,ixrain) >= qsmall .or. & + state_loc%q(:ncol,k-1,ixsnow) >= qsmall) + cldmax(:ncol,k) = max(cldmax(:ncol,k-1), cldmax(:ncol,k)) + end where + end do + end if + + ! ------------------------------------------------------ ! + ! ------------------------------------------------------ ! + ! All code from here to the end is on grid columns only ! + ! ------------------------------------------------------ ! + ! ------------------------------------------------------ ! + + ! Average the fields which are needed later in this paramterization to be on the grid + if (use_subcol_microp) then + call subcol_field_avg(prec_str, ngrdcol, lchnk, prec_str_grid) + call subcol_field_avg(iclwpst, ngrdcol, lchnk, iclwpst_grid) + call subcol_field_avg(cvreffliq, ngrdcol, lchnk, cvreffliq_grid) + call subcol_field_avg(cvreffice, ngrdcol, lchnk, cvreffice_grid) + call subcol_field_avg(mgflxprc, ngrdcol, lchnk, mgflxprc_grid) + call subcol_field_avg(mgflxsnw, ngrdcol, lchnk, mgflxsnw_grid) + call subcol_field_avg(qme, ngrdcol, lchnk, qme_grid) + call subcol_field_avg(nevapr, ngrdcol, lchnk, nevapr_grid) + call subcol_field_avg(prain, ngrdcol, lchnk, prain_grid) + call subcol_field_avg(evapsnow, ngrdcol, lchnk, evpsnow_st_grid) + + if (micro_mg_version == 1 .and. micro_mg_sub_version == 0) then + call subcol_field_avg(am_evp_st, ngrdcol, lchnk, am_evp_st_grid) + end if + + ! Average fields which are not in pbuf + call subcol_field_avg(qrout, ngrdcol, lchnk, qrout_grid) + call subcol_field_avg(qsout, ngrdcol, lchnk, qsout_grid) + call subcol_field_avg(nsout, ngrdcol, lchnk, nsout_grid) + call subcol_field_avg(nrout, ngrdcol, lchnk, nrout_grid) + call subcol_field_avg(cld, ngrdcol, lchnk, cld_grid) + call subcol_field_avg(qcreso, ngrdcol, lchnk, qcreso_grid) + call subcol_field_avg(melto, ngrdcol, lchnk, melto_grid) + call subcol_field_avg(mnuccco, ngrdcol, lchnk, mnuccco_grid) + call subcol_field_avg(mnuccto, ngrdcol, lchnk, mnuccto_grid) + call subcol_field_avg(bergo, ngrdcol, lchnk, bergo_grid) + call subcol_field_avg(homoo, ngrdcol, lchnk, homoo_grid) + call subcol_field_avg(msacwio, ngrdcol, lchnk, msacwio_grid) + call subcol_field_avg(psacwso, ngrdcol, lchnk, psacwso_grid) + call subcol_field_avg(bergso, ngrdcol, lchnk, bergso_grid) + call subcol_field_avg(cmeiout, ngrdcol, lchnk, cmeiout_grid) + call subcol_field_avg(qireso, ngrdcol, lchnk, qireso_grid) + call subcol_field_avg(prcio, ngrdcol, lchnk, prcio_grid) + call subcol_field_avg(praio, ngrdcol, lchnk, praio_grid) + call subcol_field_avg(icwmrst, ngrdcol, lchnk, icwmrst_grid) + call subcol_field_avg(icimrst, ngrdcol, lchnk, icimrst_grid) + call subcol_field_avg(liqcldf, ngrdcol, lchnk, liqcldf_grid) + call subcol_field_avg(icecldf, ngrdcol, lchnk, icecldf_grid) + call subcol_field_avg(icwnc, ngrdcol, lchnk, icwnc_grid) + call subcol_field_avg(icinc, ngrdcol, lchnk, icinc_grid) + call subcol_field_avg(state_loc%pdel, ngrdcol, lchnk, pdel_grid) + call subcol_field_avg(prao, ngrdcol, lchnk, prao_grid) + call subcol_field_avg(prco, ngrdcol, lchnk, prco_grid) + + call subcol_field_avg(state_loc%q(:,:,ixnumliq), ngrdcol, lchnk, nc_grid) + call subcol_field_avg(state_loc%q(:,:,ixnumice), ngrdcol, lchnk, ni_grid) + + if (micro_mg_version > 1) then + call subcol_field_avg(cldmax, ngrdcol, lchnk, cldmax_grid) + + call subcol_field_avg(state_loc%q(:,:,ixrain), ngrdcol, lchnk, qr_grid) + call subcol_field_avg(state_loc%q(:,:,ixnumrain), ngrdcol, lchnk, nr_grid) + call subcol_field_avg(state_loc%q(:,:,ixsnow), ngrdcol, lchnk, qs_grid) + call subcol_field_avg(state_loc%q(:,:,ixnumsnow), ngrdcol, lchnk, ns_grid) + end if + + else + ! These pbuf fields need to be assigned. There is no corresponding subcol_field_avg + ! as they are reset before being used, so it would be a needless calculation + lambdac_grid => lambdac + mu_grid => mu + rel_grid => rel + rei_grid => rei + dei_grid => dei + des_grid => des + + ! fields already on grids, so just assign + prec_str_grid => prec_str + iclwpst_grid => iclwpst + cvreffliq_grid => cvreffliq + cvreffice_grid => cvreffice + mgflxprc_grid => mgflxprc + mgflxsnw_grid => mgflxsnw + qme_grid => qme + nevapr_grid => nevapr + prain_grid => prain + + if (micro_mg_version == 1 .and. micro_mg_sub_version == 0) then + am_evp_st_grid = am_evp_st + end if + + evpsnow_st_grid = evapsnow + qrout_grid = qrout + qsout_grid = qsout + nsout_grid = nsout + nrout_grid = nrout + cld_grid = cld + qcreso_grid = qcreso + melto_grid = melto + mnuccco_grid = mnuccco + mnuccto_grid = mnuccto + bergo_grid = bergo + homoo_grid = homoo + msacwio_grid = msacwio + psacwso_grid = psacwso + bergso_grid = bergso + cmeiout_grid = cmeiout + qireso_grid = qireso + prcio_grid = prcio + praio_grid = praio + icwmrst_grid = icwmrst + icimrst_grid = icimrst + liqcldf_grid = liqcldf + icecldf_grid = icecldf + icwnc_grid = icwnc + icinc_grid = icinc + pdel_grid = state_loc%pdel + prao_grid = prao + prco_grid = prco + + nc_grid = state_loc%q(:,:,ixnumliq) + ni_grid = state_loc%q(:,:,ixnumice) + + if (micro_mg_version > 1) then + cldmax_grid = cldmax + + qr_grid = state_loc%q(:,:,ixrain) + nr_grid = state_loc%q(:,:,ixnumrain) + qs_grid = state_loc%q(:,:,ixsnow) + ns_grid = state_loc%q(:,:,ixnumsnow) + end if + + end if + + ! If on subcolumns, average the rest of the pbuf fields which were modified on subcolumns but are not used further in + ! this parameterization (no need to assign in the non-subcolumn case -- the else step) + if (use_subcol_microp) then + call subcol_field_avg(snow_str, ngrdcol, lchnk, snow_str_grid) + call subcol_field_avg(prec_pcw, ngrdcol, lchnk, prec_pcw_grid) + call subcol_field_avg(snow_pcw, ngrdcol, lchnk, snow_pcw_grid) + call subcol_field_avg(prec_sed, ngrdcol, lchnk, prec_sed_grid) + call subcol_field_avg(snow_sed, ngrdcol, lchnk, snow_sed_grid) + call subcol_field_avg(cldo, ngrdcol, lchnk, cldo_grid) + call subcol_field_avg(mgmrprc, ngrdcol, lchnk, mgmrprc_grid) + call subcol_field_avg(mgmrsnw, ngrdcol, lchnk, mgmrsnw_grid) + call subcol_field_avg(wsedl, ngrdcol, lchnk, wsedl_grid) + call subcol_field_avg(cc_t, ngrdcol, lchnk, cc_t_grid) + call subcol_field_avg(cc_qv, ngrdcol, lchnk, cc_qv_grid) + call subcol_field_avg(cc_ql, ngrdcol, lchnk, cc_ql_grid) + call subcol_field_avg(cc_qi, ngrdcol, lchnk, cc_qi_grid) + call subcol_field_avg(cc_nl, ngrdcol, lchnk, cc_nl_grid) + call subcol_field_avg(cc_ni, ngrdcol, lchnk, cc_ni_grid) + call subcol_field_avg(cc_qlst, ngrdcol, lchnk, cc_qlst_grid) + call subcol_field_avg(iciwpst, ngrdcol, lchnk, iciwpst_grid) + call subcol_field_avg(icswp, ngrdcol, lchnk, icswp_grid) + call subcol_field_avg(cldfsnow, ngrdcol, lchnk, cldfsnow_grid) + + if (rate1_cw2pr_st_idx > 0) then + call subcol_field_avg(rate1ord_cw2pr_st, ngrdcol, lchnk, rate1ord_cw2pr_st_grid) + end if + + end if + + ! ------------------------------------- ! + ! Size distribution calculation ! + ! ------------------------------------- ! + + ! Calculate rho (on subcolumns if turned on) for size distribution + ! parameter calculations and average it if needed + ! + ! State instead of state_loc to preserve answers for MG1 (and in any + ! case, it is unlikely to make much difference). + rho(:ncol,top_lev:) = state%pmid(:ncol,top_lev:) / & + (rair*state%t(:ncol,top_lev:)) + if (use_subcol_microp) then + call subcol_field_avg(rho, ngrdcol, lchnk, rho_grid) + else + rho_grid = rho + end if + + ! Effective radius for cloud liquid, fixed number. + mu_grid = 0._r8 + lambdac_grid = 0._r8 + rel_fn_grid = 10._r8 + + ncic_grid = 1.e8_r8 + + call size_dist_param_liq(mg_liq_props, icwmrst_grid(:ngrdcol,top_lev:), & + ncic_grid(:ngrdcol,top_lev:), rho_grid(:ngrdcol,top_lev:), & + mu_grid(:ngrdcol,top_lev:), lambdac_grid(:ngrdcol,top_lev:)) + + where (icwmrst_grid(:ngrdcol,top_lev:) > qsmall) + rel_fn_grid(:ngrdcol,top_lev:) = & + (mu_grid(:ngrdcol,top_lev:) + 3._r8)/ & + lambdac_grid(:ngrdcol,top_lev:)/2._r8 * 1.e6_r8 + end where + + ! Effective radius for cloud liquid, and size parameters + ! mu_grid and lambdac_grid. + mu_grid = 0._r8 + lambdac_grid = 0._r8 + rel_grid = 10._r8 + + ! Calculate ncic on the grid + ncic_grid(:ngrdcol,top_lev:) = nc_grid(:ngrdcol,top_lev:) / & + max(mincld,liqcldf_grid(:ngrdcol,top_lev:)) + + call size_dist_param_liq(mg_liq_props, icwmrst_grid(:ngrdcol,top_lev:), & + ncic_grid(:ngrdcol,top_lev:), rho_grid(:ngrdcol,top_lev:), & + mu_grid(:ngrdcol,top_lev:), lambdac_grid(:ngrdcol,top_lev:)) + + where (icwmrst_grid(:ngrdcol,top_lev:) >= qsmall) + rel_grid(:ngrdcol,top_lev:) = & + (mu_grid(:ngrdcol,top_lev:) + 3._r8) / & + lambdac_grid(:ngrdcol,top_lev:)/2._r8 * 1.e6_r8 + elsewhere + ! Deal with the fact that size_dist_param_liq sets mu_grid to -100 + ! wherever there is no cloud. + mu_grid(:ngrdcol,top_lev:) = 0._r8 + end where + + ! Rain/Snow effective diameter. + drout2_grid = 0._r8 + reff_rain_grid = 0._r8 + des_grid = 0._r8 + dsout2_grid = 0._r8 + reff_snow_grid = 0._r8 + + if (micro_mg_version > 1) then + ! Prognostic precipitation + + where (qr_grid(:ngrdcol,top_lev:) >= 1.e-7_r8) + drout2_grid(:ngrdcol,top_lev:) = avg_diameter( & + qr_grid(:ngrdcol,top_lev:), & + nr_grid(:ngrdcol,top_lev:) * rho_grid(:ngrdcol,top_lev:), & + rho_grid(:ngrdcol,top_lev:), rhow) + + reff_rain_grid(:ngrdcol,top_lev:) = drout2_grid(:ngrdcol,top_lev:) * & + 1.5_r8 * 1.e6_r8 + end where + + where (qs_grid(:ngrdcol,top_lev:) >= 1.e-7_r8) + dsout2_grid(:ngrdcol,top_lev:) = avg_diameter( & + qs_grid(:ngrdcol,top_lev:), & + ns_grid(:ngrdcol,top_lev:) * rho_grid(:ngrdcol,top_lev:), & + rho_grid(:ngrdcol,top_lev:), rhosn) + + des_grid(:ngrdcol,top_lev:) = dsout2_grid(:ngrdcol,top_lev:) *& + 3._r8 * rhosn/rhows + + reff_snow_grid(:ngrdcol,top_lev:) = dsout2_grid(:ngrdcol,top_lev:) * & + 1.5_r8 * 1.e6_r8 + end where + + else + ! Diagnostic precipitation + + where (qrout_grid(:ngrdcol,top_lev:) >= 1.e-7_r8) + drout2_grid(:ngrdcol,top_lev:) = avg_diameter( & + qrout_grid(:ngrdcol,top_lev:), & + nrout_grid(:ngrdcol,top_lev:) * rho_grid(:ngrdcol,top_lev:), & + rho_grid(:ngrdcol,top_lev:), rhow) + + reff_rain_grid(:ngrdcol,top_lev:) = drout2_grid(:ngrdcol,top_lev:) * & + 1.5_r8 * 1.e6_r8 + end where + + where (qsout_grid(:ngrdcol,top_lev:) >= 1.e-7_r8) + dsout2_grid(:ngrdcol,top_lev:) = avg_diameter( & + qsout_grid(:ngrdcol,top_lev:), & + nsout_grid(:ngrdcol,top_lev:) * rho_grid(:ngrdcol,top_lev:), & + rho_grid(:ngrdcol,top_lev:), rhosn) + + des_grid(:ngrdcol,top_lev:) = dsout2_grid(:ngrdcol,top_lev:) & + * 3._r8 * rhosn/rhows + + reff_snow_grid(:ngrdcol,top_lev:) = & + dsout2_grid(:ngrdcol,top_lev:) * 1.5_r8 * 1.e6_r8 + end where + + end if + + ! Effective radius and diameter for cloud ice. + rei_grid = 25._r8 + + niic_grid(:ngrdcol,top_lev:) = ni_grid(:ngrdcol,top_lev:) / & + max(mincld,icecldf_grid(:ngrdcol,top_lev:)) + + call size_dist_param_basic(mg_ice_props, icimrst_grid(:ngrdcol,top_lev:), & + niic_grid(:ngrdcol,top_lev:), rei_grid(:ngrdcol,top_lev:)) + + where (icimrst_grid(:ngrdcol,top_lev:) >= qsmall) + rei_grid(:ngrdcol,top_lev:) = 1.5_r8/rei_grid(:ngrdcol,top_lev:) & + * 1.e6_r8 + elsewhere + rei_grid(:ngrdcol,top_lev:) = 25._r8 + end where + + dei_grid = rei_grid * rhoi/rhows * 2._r8 + + ! Limiters for low cloud fraction. + do k = top_lev, pver + do i = 1, ngrdcol + ! Convert snow effective diameter to microns + des_grid(i,k) = des_grid(i,k) * 1.e6_r8 + if ( ast_grid(i,k) < 1.e-4_r8 ) then + mu_grid(i,k) = mucon + lambdac_grid(i,k) = (mucon + 1._r8)/dcon + dei_grid(i,k) = deicon + end if + end do + end do + + mgreffrain_grid(:ngrdcol,top_lev:pver) = reff_rain_grid(:ngrdcol,top_lev:pver) + mgreffsnow_grid(:ngrdcol,top_lev:pver) = reff_snow_grid(:ngrdcol,top_lev:pver) + + ! ------------------------------------- ! + ! Precipitation efficiency Calculation ! + ! ------------------------------------- ! + + !----------------------------------------------------------------------- + ! Liquid water path + + ! Compute liquid water paths, and column condensation + tgliqwp_grid(:ngrdcol) = 0._r8 + tgcmeliq_grid(:ngrdcol) = 0._r8 + do k = top_lev, pver + do i = 1, ngrdcol + tgliqwp_grid(i) = tgliqwp_grid(i) + iclwpst_grid(i,k)*cld_grid(i,k) + + if (cmeliq_grid(i,k) > 1.e-12_r8) then + !convert cmeliq to right units: kgh2o/kgair/s * kgair/m2 / kgh2o/m3 = m/s + tgcmeliq_grid(i) = tgcmeliq_grid(i) + cmeliq_grid(i,k) * & + (pdel_grid(i,k) / gravit) / rhoh2o + end if + end do + end do + + ! note: 1e-6 kgho2/kgair/s * 1000. pa / (9.81 m/s2) / 1000 kgh2o/m3 = 1e-7 m/s + ! this is 1ppmv of h2o in 10hpa + ! alternatively: 0.1 mm/day * 1.e-4 m/mm * 1/86400 day/s = 1.e-9 + + !----------------------------------------------------------------------- + ! precipitation efficiency calculation (accumulate cme and precip) + + minlwp = 0.01_r8 !minimum lwp threshold (kg/m3) + + ! zero out precip efficiency and total averaged precip + pe_grid(:ngrdcol) = 0._r8 + tpr_grid(:ngrdcol) = 0._r8 + pefrac_grid(:ngrdcol) = 0._r8 + + ! accumulate precip and condensation + do i = 1, ngrdcol + + acgcme_grid(i) = acgcme_grid(i) + tgcmeliq_grid(i) + acprecl_grid(i) = acprecl_grid(i) + prec_str_grid(i) + acnum_grid(i) = acnum_grid(i) + 1 + + ! if LWP is zero, then 'end of cloud': calculate precip efficiency + if (tgliqwp_grid(i) < minlwp) then + if (acprecl_grid(i) > 5.e-8_r8) then + tpr_grid(i) = max(acprecl_grid(i)/acnum_grid(i), 1.e-15_r8) + if (acgcme_grid(i) > 1.e-10_r8) then + pe_grid(i) = min(max(acprecl_grid(i)/acgcme_grid(i), 1.e-15_r8), 1.e5_r8) + pefrac_grid(i) = 1._r8 + end if + end if + + ! reset counters +! if (pe_grid(i) /= 0._r8 .and. (pe_grid(i) < 1.e-8_r8 .or. pe_grid(i) > 1.e3_r8)) then +! write (iulog,*) 'PE_grid:ANOMALY pe_grid, acprecl_grid, acgcme_grid, tpr_grid, acnum_grid ', & +! pe_grid(i),acprecl_grid(i), acgcme_grid(i), tpr_grid(i), acnum_grid(i) +! endif + + acprecl_grid(i) = 0._r8 + acgcme_grid(i) = 0._r8 + acnum_grid(i) = 0 + end if ! end LWP zero conditional + + ! if never find any rain....(after 10^3 timesteps...) + if (acnum_grid(i) > 1000) then + acnum_grid(i) = 0 + acprecl_grid(i) = 0._r8 + acgcme_grid(i) = 0._r8 + end if + + end do + + !----------------------------------------------------------------------- + ! vertical average of non-zero accretion, autoconversion and ratio. + ! vars: vprco_grid(i),vprao_grid(i),racau_grid(i),cnt_grid + + vprao_grid = 0._r8 + cnt_grid = 0 + do k = top_lev, pver + vprao_grid(:ngrdcol) = vprao_grid(:ngrdcol) + prao_grid(:ngrdcol,k) + where (prao_grid(:ngrdcol,k) /= 0._r8) cnt_grid(:ngrdcol) = cnt_grid(:ngrdcol) + 1 + end do + + where (cnt_grid > 0) vprao_grid = vprao_grid/cnt_grid + + vprco_grid = 0._r8 + cnt_grid = 0 + do k = top_lev, pver + vprco_grid(:ngrdcol) = vprco_grid(:ngrdcol) + prco_grid(:ngrdcol,k) + where (prco_grid(:ngrdcol,k) /= 0._r8) cnt_grid(:ngrdcol) = cnt_grid(:ngrdcol) + 1 + end do + + where (cnt_grid > 0) + vprco_grid = vprco_grid/cnt_grid + racau_grid = vprao_grid/vprco_grid + elsewhere + racau_grid = 0._r8 + end where + + racau_grid = min(racau_grid, 1.e10_r8) + + ! --------------------- ! + ! History Output Fields ! + ! --------------------- ! + + ! Column droplet concentration + cdnumc_grid(:ngrdcol) = sum(nc_grid(:ngrdcol,top_lev:pver) * & + pdel_grid(:ngrdcol,top_lev:pver)/gravit, dim=2) + + ! Averaging for new output fields + efcout_grid = 0._r8 + efiout_grid = 0._r8 + ncout_grid = 0._r8 + niout_grid = 0._r8 + freql_grid = 0._r8 + freqi_grid = 0._r8 + icwmrst_grid_out = 0._r8 + icimrst_grid_out = 0._r8 + + do k = top_lev, pver + do i = 1, ngrdcol + if ( liqcldf_grid(i,k) > 0.01_r8 .and. icwmrst_grid(i,k) > 5.e-5_r8 ) then + efcout_grid(i,k) = rel_grid(i,k) * liqcldf_grid(i,k) + ncout_grid(i,k) = icwnc_grid(i,k) * liqcldf_grid(i,k) + freql_grid(i,k) = liqcldf_grid(i,k) + icwmrst_grid_out(i,k) = icwmrst_grid(i,k) + end if + if ( icecldf_grid(i,k) > 0.01_r8 .and. icimrst_grid(i,k) > 1.e-6_r8 ) then + efiout_grid(i,k) = rei_grid(i,k) * icecldf_grid(i,k) + niout_grid(i,k) = icinc_grid(i,k) * icecldf_grid(i,k) + freqi_grid(i,k) = icecldf_grid(i,k) + icimrst_grid_out(i,k) = icimrst_grid(i,k) + end if + end do + end do + + ! Cloud top effective radius and number. + fcti_grid = 0._r8 + fctl_grid = 0._r8 + ctrel_grid = 0._r8 + ctrei_grid = 0._r8 + ctnl_grid = 0._r8 + ctni_grid = 0._r8 + do i = 1, ngrdcol + do k = top_lev, pver + if ( liqcldf_grid(i,k) > 0.01_r8 .and. icwmrst_grid(i,k) > 1.e-7_r8 ) then + ctrel_grid(i) = rel_grid(i,k) * liqcldf_grid(i,k) + ctnl_grid(i) = icwnc_grid(i,k) * liqcldf_grid(i,k) + fctl_grid(i) = liqcldf_grid(i,k) + exit + end if + if ( icecldf_grid(i,k) > 0.01_r8 .and. icimrst_grid(i,k) > 1.e-7_r8 ) then + ctrei_grid(i) = rei_grid(i,k) * icecldf_grid(i,k) + ctni_grid(i) = icinc_grid(i,k) * icecldf_grid(i,k) + fcti_grid(i) = icecldf_grid(i,k) + exit + end if + end do + end do + + ! Evaporation of stratiform precipitation fields for UNICON + evprain_st_grid(:ngrdcol,:pver) = nevapr_grid(:ngrdcol,:pver) - evpsnow_st_grid(:ngrdcol,:pver) + do k = top_lev, pver + do i = 1, ngrdcol + evprain_st_grid(i,k) = max(evprain_st_grid(i,k), 0._r8) + evpsnow_st_grid(i,k) = max(evpsnow_st_grid(i,k), 0._r8) + end do + end do + + ! Assign the values to the pbuf pointers if they exist in pbuf + if (qrain_idx > 0) qrout_grid_ptr = qrout_grid + if (qsnow_idx > 0) qsout_grid_ptr = qsout_grid + if (nrain_idx > 0) nrout_grid_ptr = nrout_grid + if (nsnow_idx > 0) nsout_grid_ptr = nsout_grid + + ! --------------------------------------------- ! + ! General outfield calls for microphysics ! + ! --------------------------------------------- ! + + ! Output a handle of variables which are calculated on the fly + ftem_grid = 0._r8 + + ftem_grid(:ngrdcol,top_lev:pver) = qcreso_grid(:ngrdcol,top_lev:pver) + call outfld( 'MPDW2V', ftem_grid, pcols, lchnk) + + ftem_grid(:ngrdcol,top_lev:pver) = melto_grid(:ngrdcol,top_lev:pver) - mnuccco_grid(:ngrdcol,top_lev:pver)& - mnuccto_grid(:ngrdcol,top_lev:pver) - bergo_grid(:ngrdcol,top_lev:pver) - homoo_grid(:ngrdcol,top_lev:pver)& - msacwio_grid(:ngrdcol,top_lev:pver) - call outfld( 'MPDW2I', ftem_grid, pcols, lchnk) + call outfld( 'MPDW2I', ftem_grid, pcols, lchnk) - ftem_grid(:ngrdcol,top_lev:pver) = -prao_grid(:ngrdcol,top_lev:pver) - prco_grid(:ngrdcol,top_lev:pver)& + ftem_grid(:ngrdcol,top_lev:pver) = -prao_grid(:ngrdcol,top_lev:pver) - prco_grid(:ngrdcol,top_lev:pver)& - psacwso_grid(:ngrdcol,top_lev:pver) - bergso_grid(:ngrdcol,top_lev:pver) - call outfld( 'MPDW2P', ftem_grid, pcols, lchnk) - - ftem_grid(:ngrdcol,top_lev:pver) = cmeiout_grid(:ngrdcol,top_lev:pver) + qireso_grid(:ngrdcol,top_lev:pver) - call outfld( 'MPDI2V', ftem_grid, pcols, lchnk) - - ftem_grid(:ngrdcol,top_lev:pver) = -melto_grid(:ngrdcol,top_lev:pver) + mnuccco_grid(:ngrdcol,top_lev:pver) & - + mnuccto_grid(:ngrdcol,top_lev:pver) + bergo_grid(:ngrdcol,top_lev:pver) + homoo_grid(:ngrdcol,top_lev:pver)& - + msacwio_grid(:ngrdcol,top_lev:pver) - call outfld( 'MPDI2W', ftem_grid, pcols, lchnk) - - ftem_grid(:ngrdcol,top_lev:pver) = -prcio_grid(:ngrdcol,top_lev:pver) - praio_grid(:ngrdcol,top_lev:pver) - call outfld( 'MPDI2P', ftem_grid, pcols, lchnk) - - ! Output fields which have not been averaged already, averaging if use_subcol_microp is true - call outfld('MPICLWPI', iclwpi, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('MPICIWPI', iciwpi, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('REFL', refl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('AREFL', arefl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('AREFLZ', areflz, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('FREFL', frefl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('CSRFL', csrfl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('ACSRFL', acsrfl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('FCSRFL', fcsrfl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('RERCLD', rercld, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('NCAL', ncal, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('NCAI', ncai, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('AQRAIN', qrout2, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('AQSNOW', qsout2, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('ANRAIN', nrout2, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('ANSNOW', nsout2, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('FREQR', freqr, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('FREQS', freqs, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('MPDT', tlat, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('MPDQ', qvlat, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('MPDLIQ', qcten, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('MPDICE', qiten, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('EVAPSNOW', evapsnow, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('QCSEVAP', qcsevap, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('QISEVAP', qisevap, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('QVRES', qvres, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('VTRMC', vtrmc, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('VTRMI', vtrmi, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('QCSEDTEN', qcsedten, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('QISEDTEN', qisedten, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('MNUCCDO', mnuccdo, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('MNUCCDOhet', mnuccdohet, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('MNUCCRO', mnuccro, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('PRACSO', pracso , psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('MELTSDT', meltsdt, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('FRZRDT', frzrdt , psetcols, lchnk, avg_subcol_field=use_subcol_microp) - call outfld('FICE', nfice, psetcols, lchnk, avg_subcol_field=use_subcol_microp) - - ! Example subcolumn outfld call - if (use_subcol_microp) then - call outfld('FICE_SCOL', nfice, psubcols*pcols, lchnk) - end if - - - ! Output fields which are already on the grid - call outfld('QRAIN', qrout_grid, pcols, lchnk) - call outfld('QSNOW', qsout_grid, pcols, lchnk) - call outfld('NRAIN', nrout_grid, pcols, lchnk) - call outfld('NSNOW', nsout_grid, pcols, lchnk) - call outfld('CV_REFFLIQ', cvreffliq_grid, pcols, lchnk) - call outfld('CV_REFFICE', cvreffice_grid, pcols, lchnk) - call outfld('LS_FLXPRC', mgflxprc_grid, pcols, lchnk) - call outfld('LS_FLXSNW', mgflxsnw_grid, pcols, lchnk) - call outfld('CME', qme_grid, pcols, lchnk) - call outfld('PRODPREC', prain_grid, pcols, lchnk) - call outfld('EVAPPREC', nevapr_grid, pcols, lchnk) - call outfld('QCRESO', qcreso_grid, pcols, lchnk) - call outfld('LS_REFFRAIN', mgreffrain_grid, pcols, lchnk) - call outfld('LS_REFFSNOW', mgreffsnow_grid, pcols, lchnk) - call outfld('DSNOW', des_grid, pcols, lchnk) - call outfld('ADRAIN', drout2_grid, pcols, lchnk) - call outfld('ADSNOW', dsout2_grid, pcols, lchnk) - call outfld('PE', pe_grid, pcols, lchnk) - call outfld('PEFRAC', pefrac_grid, pcols, lchnk) - call outfld('APRL', tpr_grid, pcols, lchnk) - call outfld('VPRAO', vprao_grid, pcols, lchnk) - call outfld('VPRCO', vprco_grid, pcols, lchnk) - call outfld('RACAU', racau_grid, pcols, lchnk) - call outfld('AREL', efcout_grid, pcols, lchnk) - call outfld('AREI', efiout_grid, pcols, lchnk) - call outfld('AWNC' , ncout_grid, pcols, lchnk) - call outfld('AWNI' , niout_grid, pcols, lchnk) - call outfld('FREQL', freql_grid, pcols, lchnk) - call outfld('FREQI', freqi_grid, pcols, lchnk) - call outfld('ACTREL', ctrel_grid, pcols, lchnk) - call outfld('ACTREI', ctrei_grid, pcols, lchnk) - call outfld('ACTNL', ctnl_grid, pcols, lchnk) - call outfld('ACTNI', ctni_grid, pcols, lchnk) - call outfld('FCTL', fctl_grid, pcols, lchnk) - call outfld('FCTI', fcti_grid, pcols, lchnk) - call outfld('ICINC', icinc_grid, pcols, lchnk) - call outfld('ICWNC', icwnc_grid, pcols, lchnk) - call outfld('EFFLIQ_IND', rel_fn_grid, pcols, lchnk) - call outfld('CDNUMC', cdnumc_grid, pcols, lchnk) - call outfld('REL', rel_grid, pcols, lchnk) - call outfld('REI', rei_grid, pcols, lchnk) - call outfld('ICIMRST', icimrst_grid_out, pcols, lchnk) - call outfld('ICWMRST', icwmrst_grid_out, pcols, lchnk) - call outfld('CMEIOUT', cmeiout_grid, pcols, lchnk) - call outfld('PRAO', prao_grid, pcols, lchnk) - call outfld('PRCO', prco_grid, pcols, lchnk) - call outfld('MNUCCCO', mnuccco_grid, pcols, lchnk) - call outfld('MNUCCTO', mnuccto_grid, pcols, lchnk) - call outfld('MSACWIO', msacwio_grid, pcols, lchnk) - call outfld('PSACWSO', psacwso_grid, pcols, lchnk) - call outfld('BERGSO', bergso_grid, pcols, lchnk) - call outfld('BERGO', bergo_grid, pcols, lchnk) - call outfld('MELTO', melto_grid, pcols, lchnk) - call outfld('HOMOO', homoo_grid, pcols, lchnk) - call outfld('PRCIO', prcio_grid, pcols, lchnk) - call outfld('PRAIO', praio_grid, pcols, lchnk) - call outfld('QIRESO', qireso_grid, pcols, lchnk) - - ! ptend_loc is deallocated in physics_update above - call physics_state_dealloc(state_loc) + call outfld( 'MPDW2P', ftem_grid, pcols, lchnk) + + ftem_grid(:ngrdcol,top_lev:pver) = cmeiout_grid(:ngrdcol,top_lev:pver) + qireso_grid(:ngrdcol,top_lev:pver) + call outfld( 'MPDI2V', ftem_grid, pcols, lchnk) + + ftem_grid(:ngrdcol,top_lev:pver) = -melto_grid(:ngrdcol,top_lev:pver) + mnuccco_grid(:ngrdcol,top_lev:pver) & + + mnuccto_grid(:ngrdcol,top_lev:pver) + bergo_grid(:ngrdcol,top_lev:pver) + homoo_grid(:ngrdcol,top_lev:pver)& + + msacwio_grid(:ngrdcol,top_lev:pver) + call outfld( 'MPDI2W', ftem_grid, pcols, lchnk) + + ftem_grid(:ngrdcol,top_lev:pver) = -prcio_grid(:ngrdcol,top_lev:pver) - praio_grid(:ngrdcol,top_lev:pver) + call outfld( 'MPDI2P', ftem_grid, pcols, lchnk) + + ! Output fields which have not been averaged already, averaging if use_subcol_microp is true + call outfld('MPICLWPI', iclwpi, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MPICIWPI', iciwpi, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('REFL', refl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('AREFL', arefl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('AREFLZ', areflz, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('FREFL', frefl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('CSRFL', csrfl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('ACSRFL', acsrfl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('FCSRFL', fcsrfl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('RERCLD', rercld, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('NCAL', ncal, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('NCAI', ncai, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('AQRAIN', qrout2, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('AQSNOW', qsout2, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('ANRAIN', nrout2, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('ANSNOW', nsout2, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('FREQR', freqr, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('FREQS', freqs, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MPDT', tlat, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MPDQ', qvlat, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MPDLIQ', qcten, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MPDICE', qiten, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('EVAPSNOW', evapsnow, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('QCSEVAP', qcsevap, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('QISEVAP', qisevap, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('QVRES', qvres, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('VTRMC', vtrmc, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('VTRMI', vtrmi, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('QCSEDTEN', qcsedten, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('QISEDTEN', qisedten, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + if (micro_mg_version > 1) then + call outfld('QRSEDTEN', qrsedten, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('QSSEDTEN', qssedten, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + end if + call outfld('MNUCCDO', mnuccdo, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MNUCCDOhet', mnuccdohet, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MNUCCRO', mnuccro, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('PRACSO', pracso , psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MELTSDT', meltsdt, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('FRZRDT', frzrdt , psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('FICE', nfice, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + + if (micro_mg_version > 1) then + call outfld('UMR', umr, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('UMS', ums, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + end if + + if (.not. (micro_mg_version == 1 .and. micro_mg_sub_version == 0)) then + call outfld('QCRAT', qcrat, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + end if + + ! Example subcolumn outfld call + if (use_subcol_microp) then + call outfld('FICE_SCOL', nfice, psubcols*pcols, lchnk) + end if + + ! Output fields which are already on the grid + call outfld('QRAIN', qrout_grid, pcols, lchnk) + call outfld('QSNOW', qsout_grid, pcols, lchnk) + call outfld('NRAIN', nrout_grid, pcols, lchnk) + call outfld('NSNOW', nsout_grid, pcols, lchnk) + call outfld('CV_REFFLIQ', cvreffliq_grid, pcols, lchnk) + call outfld('CV_REFFICE', cvreffice_grid, pcols, lchnk) + call outfld('LS_FLXPRC', mgflxprc_grid, pcols, lchnk) + call outfld('LS_FLXSNW', mgflxsnw_grid, pcols, lchnk) + call outfld('CME', qme_grid, pcols, lchnk) + call outfld('PRODPREC', prain_grid, pcols, lchnk) + call outfld('EVAPPREC', nevapr_grid, pcols, lchnk) + call outfld('QCRESO', qcreso_grid, pcols, lchnk) + call outfld('LS_REFFRAIN', mgreffrain_grid, pcols, lchnk) + call outfld('LS_REFFSNOW', mgreffsnow_grid, pcols, lchnk) + call outfld('DSNOW', des_grid, pcols, lchnk) + call outfld('ADRAIN', drout2_grid, pcols, lchnk) + call outfld('ADSNOW', dsout2_grid, pcols, lchnk) + call outfld('PE', pe_grid, pcols, lchnk) + call outfld('PEFRAC', pefrac_grid, pcols, lchnk) + call outfld('APRL', tpr_grid, pcols, lchnk) + call outfld('VPRAO', vprao_grid, pcols, lchnk) + call outfld('VPRCO', vprco_grid, pcols, lchnk) + call outfld('RACAU', racau_grid, pcols, lchnk) + call outfld('AREL', efcout_grid, pcols, lchnk) + call outfld('AREI', efiout_grid, pcols, lchnk) + call outfld('AWNC' , ncout_grid, pcols, lchnk) + call outfld('AWNI' , niout_grid, pcols, lchnk) + call outfld('FREQL', freql_grid, pcols, lchnk) + call outfld('FREQI', freqi_grid, pcols, lchnk) + call outfld('ACTREL', ctrel_grid, pcols, lchnk) + call outfld('ACTREI', ctrei_grid, pcols, lchnk) + call outfld('ACTNL', ctnl_grid, pcols, lchnk) + call outfld('ACTNI', ctni_grid, pcols, lchnk) + call outfld('FCTL', fctl_grid, pcols, lchnk) + call outfld('FCTI', fcti_grid, pcols, lchnk) + call outfld('ICINC', icinc_grid, pcols, lchnk) + call outfld('ICWNC', icwnc_grid, pcols, lchnk) + call outfld('EFFLIQ_IND', rel_fn_grid, pcols, lchnk) + call outfld('CDNUMC', cdnumc_grid, pcols, lchnk) + call outfld('REL', rel_grid, pcols, lchnk) + call outfld('REI', rei_grid, pcols, lchnk) + call outfld('ICIMRST', icimrst_grid_out, pcols, lchnk) + call outfld('ICWMRST', icwmrst_grid_out, pcols, lchnk) + call outfld('CMEIOUT', cmeiout_grid, pcols, lchnk) + call outfld('PRAO', prao_grid, pcols, lchnk) + call outfld('PRCO', prco_grid, pcols, lchnk) + call outfld('MNUCCCO', mnuccco_grid, pcols, lchnk) + call outfld('MNUCCTO', mnuccto_grid, pcols, lchnk) + call outfld('MSACWIO', msacwio_grid, pcols, lchnk) + call outfld('PSACWSO', psacwso_grid, pcols, lchnk) + call outfld('BERGSO', bergso_grid, pcols, lchnk) + call outfld('BERGO', bergo_grid, pcols, lchnk) + call outfld('MELTO', melto_grid, pcols, lchnk) + call outfld('HOMOO', homoo_grid, pcols, lchnk) + call outfld('PRCIO', prcio_grid, pcols, lchnk) + call outfld('PRAIO', praio_grid, pcols, lchnk) + call outfld('QIRESO', qireso_grid, pcols, lchnk) + + ! ptend_loc is deallocated in physics_update above + call physics_state_dealloc(state_loc) end subroutine micro_mg_cam_tend +function p1(tin) result(pout) + real(r8), target, intent(in) :: tin(:) + real(r8), pointer :: pout(:) + pout => tin +end function p1 + +function p2(tin) result(pout) + real(r8), target, intent(in) :: tin(:,:) + real(r8), pointer :: pout(:,:) + pout => tin +end function p2 + end module micro_mg_cam diff --git a/models/atm/cam/src/physics/cam/micro_mg_data.F90 b/models/atm/cam/src/physics/cam/micro_mg_data.F90 new file mode 100644 index 000000000000..9a4d0c4a5ed2 --- /dev/null +++ b/models/atm/cam/src/physics/cam/micro_mg_data.F90 @@ -0,0 +1,550 @@ +module micro_mg_data + +! +! Packing and time averaging for the MG interface. +! +! Use is as follows: +! +! 1) Figure out which columns will do averaging (mgncol) and the number of +! levels where the microphysics will run (nlev). +! +! 2) Create an MGPacker object and assign it as follows: +! +! packer = MGPacker(pcols, pver, mgcols, top_lev) +! +! Where [pcols, pver] is the shape of the ultimate input/output arrays +! that are defined at level midpoints. +! +! 3) Create a post-processing array of type MGPostProc: +! +! post_proc = MGPostProc(packer) +! +! 4) Add pairs of pointers for packed and unpacked representations, already +! associated with buffers of the correct dimensions: +! +! call post_proc%add_field(unpacked_pointer, packed_pointer, & +! fillvalue, accum_mean) +! +! The third value is the default value used to "unpack" for points with +! no "packed" part, and the fourth value is the method used to +! accumulate values over time steps. These two arguments can be omitted, +! in which case the default value will be 0 and the accumulation method +! will take the mean. +! +! 5) Use the packed fields in MG, and for each MG iteration, do: +! +! call post_proc%accumulate() +! +! 6) Perform final accumulation and scatter values into the unpacked arrays: +! +! call post_proc%process_and_unpack() +! +! 7) Destroy the object when complete: +! +! call post_proc%finalize() +! +! Caveat: MGFieldPostProc will hit a divide-by-zero error if you try to +! take the mean over 0 steps. +! + +! This include header defines CPP macros that only have an effect for debug +! builds. +#include "shr_assert.h" + +use shr_kind_mod, only: r8 => shr_kind_r8 +use shr_log_mod, only: & + errMsg => shr_log_errMsg, & + OOBMsg => shr_log_OOBMsg +use shr_sys_mod, only: shr_sys_abort + +implicit none +private + +public :: MGPacker +public :: MGFieldPostProc +public :: accum_null +public :: accum_mean +public :: MGPostProc + +type :: MGPacker + ! Unpacked array dimensions. + integer :: pcols + integer :: pver + ! Calculated packed dimensions, stored for convenience. + integer :: mgncol + integer :: nlev + ! Which columns are packed. + integer, allocatable :: mgcols(:) + ! Topmost level to copy into the packed array. + integer :: top_lev + contains + procedure, private :: pack_1D + procedure, private :: pack_2D + procedure, private :: pack_3D + generic :: pack => pack_1D, pack_2D, pack_3D + procedure :: pack_interface + procedure, private :: unpack_1D + procedure, private :: unpack_1D_array_fill + procedure, private :: unpack_2D + procedure, private :: unpack_2D_array_fill + procedure, private :: unpack_3D + procedure, private :: unpack_3D_array_fill + generic :: unpack => unpack_1D, unpack_1D_array_fill, & + unpack_2D, unpack_2D_array_fill, unpack_3D, unpack_3D_array_fill + procedure :: finalize => MGPacker_finalize +end type MGPacker + +interface MGPacker + module procedure new_MGPacker +end interface + +! Enum for time accumulation/averaging methods. +integer, parameter :: accum_null = 0 +integer, parameter :: accum_mean = 1 + +type :: MGFieldPostProc + integer :: accum_method = -1 + integer :: rank = -1 + integer :: num_steps = 0 + real(r8) :: fillvalue = 0._r8 + real(r8), pointer :: unpacked_1D(:) => null() + real(r8), pointer :: packed_1D(:) => null() + real(r8), allocatable :: buffer_1D(:) + real(r8), pointer :: unpacked_2D(:,:) => null() + real(r8), pointer :: packed_2D(:,:) => null() + real(r8), allocatable :: buffer_2D(:,:) + contains + procedure :: accumulate => MGFieldPostProc_accumulate + procedure :: process_and_unpack => MGFieldPostProc_process_and_unpack + procedure :: unpack_only => MGFieldPostProc_unpack_only + procedure :: finalize => MGFieldPostProc_finalize +end type MGFieldPostProc + +interface MGFieldPostProc + module procedure MGFieldPostProc_1D + module procedure MGFieldPostProc_2D +end interface MGFieldPostProc + +#define VECTOR_NAME MGFieldPostProcVec +#define TYPE_NAME type(MGFieldPostProc) +#define THROW(string) call shr_sys_abort(string) + +public :: VECTOR_NAME + +#include "dynamic_vector_typedef.inc" + +type MGPostProc + type(MGPacker) :: packer + type(MGFieldPostProcVec) :: field_procs + contains + procedure, private :: add_field_1D + procedure, private :: add_field_2D + generic :: add_field => add_field_1D, add_field_2D + procedure :: accumulate => MGPostProc_accumulate + procedure :: process_and_unpack => MGPostProc_process_and_unpack + procedure :: unpack_only => MGPostProc_unpack_only + procedure :: finalize => MGPostProc_finalize + procedure, private :: MGPostProc_copy + generic :: assignment(=) => MGPostProc_copy +end type MGPostProc + +interface MGPostProc + module procedure new_MGPostProc +end interface MGPostProc + +contains + +function new_MGPacker(pcols, pver, mgcols, top_lev) + integer, intent(in) :: pcols, pver + integer, intent(in) :: mgcols(:) + integer, intent(in) :: top_lev + + type(MGPacker) :: new_MGPacker + + new_MGPacker%pcols = pcols + new_MGPacker%pver = pver + new_MGPacker%mgncol = size(mgcols) + new_MGPacker%nlev = pver - top_lev + 1 + + allocate(new_MGPacker%mgcols(new_MGPacker%mgncol)) + new_MGPacker%mgcols = mgcols + new_MGPacker%top_lev = top_lev + +end function new_MGPacker + +! Rely on the fact that intent(out) forces the compiler to deallocate all +! allocatable components and restart the type from scratch. Although +! compiler support for finalization varies, this seems to be one of the few +! cases where all major compilers are reliable, and humans are not. +subroutine MGPacker_finalize(self) + class(MGPacker), intent(out) :: self +end subroutine MGPacker_finalize + +function pack_1D(self, unpacked) result(packed) + class(MGPacker), intent(in) :: self + real(r8), intent(in) :: unpacked(:) + + real(r8) :: packed(self%mgncol) + + SHR_ASSERT(size(unpacked) == self%pcols, errMsg(__FILE__, __LINE__)) + + packed = unpacked(self%mgcols) + +end function pack_1D + +! Separation of pack and pack_interface is to workaround a PGI bug. +function pack_2D(self, unpacked) result(packed) + class(MGPacker), intent(in) :: self + real(r8), intent(in) :: unpacked(:,:) + + real(r8) :: packed(self%mgncol,self%nlev) + + SHR_ASSERT(size(unpacked, 1) == self%pcols, errMsg(__FILE__, __LINE__)) + + packed = unpacked(self%mgcols,self%top_lev:) + +end function pack_2D + +function pack_interface(self, unpacked) result(packed) + class(MGPacker), intent(in) :: self + real(r8), intent(in) :: unpacked(:,:) + + real(r8) :: packed(self%mgncol,self%nlev+1) + + packed = unpacked(self%mgcols,self%top_lev:) + +end function pack_interface + +function pack_3D(self, unpacked) result(packed) + class(MGPacker), intent(in) :: self + real(r8), intent(in) :: unpacked(:,:,:) + + real(r8) :: packed(self%mgncol,self%nlev,size(unpacked, 3)) + + SHR_ASSERT(size(unpacked,1) == self%pcols, errMsg(__FILE__, __LINE__)) + + packed = unpacked(self%mgcols,self%top_lev:,:) + +end function pack_3D + +function unpack_1D(self, packed, fill) result(unpacked) + class(MGPacker), intent(in) :: self + real(r8), intent(in) :: packed(:) + real(r8), intent(in) :: fill + + real(r8) :: unpacked(self%pcols) + + SHR_ASSERT(size(packed) == self%mgncol, errMsg(__FILE__, __LINE__)) + + unpacked = fill + unpacked(self%mgcols) = packed + +end function unpack_1D + +function unpack_1D_array_fill(self, packed, fill) result(unpacked) + class(MGPacker), intent(in) :: self + real(r8), intent(in) :: packed(:) + real(r8), intent(in) :: fill(:) + + real(r8) :: unpacked(self%pcols) + + SHR_ASSERT(size(packed) == self%mgncol, errMsg(__FILE__, __LINE__)) + + unpacked = fill + unpacked(self%mgcols) = packed + +end function unpack_1D_array_fill + +function unpack_2D(self, packed, fill) result(unpacked) + class(MGPacker), intent(in) :: self + real(r8), intent(in) :: packed(:,:) + real(r8), intent(in) :: fill + + real(r8) :: unpacked(self%pcols,self%pver+size(packed, 2)-self%nlev) + + SHR_ASSERT(size(packed, 1) == self%mgncol, errMsg(__FILE__, __LINE__)) + + unpacked = fill + unpacked(self%mgcols,self%top_lev:) = packed + +end function unpack_2D + +function unpack_2D_array_fill(self, packed, fill) result(unpacked) + class(MGPacker), intent(in) :: self + real(r8), intent(in) :: packed(:,:) + real(r8), intent(in) :: fill(:,:) + + real(r8) :: unpacked(self%pcols,self%pver+size(packed, 2)-self%nlev) + + SHR_ASSERT(size(packed, 1) == self%mgncol, errMsg(__FILE__, __LINE__)) + + unpacked = fill + unpacked(self%mgcols,self%top_lev:) = packed + +end function unpack_2D_array_fill + +function unpack_3D(self, packed, fill) result(unpacked) + class(MGPacker), intent(in) :: self + real(r8), intent(in) :: packed(:,:,:) + real(r8), intent(in) :: fill + + real(r8) :: unpacked(self%pcols,self%pver,size(packed, 3)) + + SHR_ASSERT(size(packed, 1) == self%mgncol, errMsg(__FILE__, __LINE__)) + + unpacked = fill + unpacked(self%mgcols,self%top_lev:,:) = packed + +end function unpack_3D + +function unpack_3D_array_fill(self, packed, fill) result(unpacked) + class(MGPacker), intent(in) :: self + real(r8), intent(in) :: packed(:,:,:) + real(r8), intent(in) :: fill(:,:,:) + + real(r8) :: unpacked(self%pcols,self%pver,size(packed, 3)) + + SHR_ASSERT(size(packed, 1) == self%mgncol, errMsg(__FILE__, __LINE__)) + + unpacked = fill + unpacked(self%mgcols,self%top_lev:,:) = packed + +end function unpack_3D_array_fill + +function MGFieldPostProc_1D(unpacked_ptr, packed_ptr, fillvalue, & + accum_method) result(field_proc) + real(r8), pointer, intent(in) :: unpacked_ptr(:) + real(r8), pointer, intent(in) :: packed_ptr(:) + real(r8), intent(in), optional :: fillvalue + integer, intent(in), optional :: accum_method + type(MGFieldPostProc) :: field_proc + + field_proc%rank = 1 + field_proc%unpacked_1D => unpacked_ptr + field_proc%packed_1D => packed_ptr + if (present(fillvalue)) then + field_proc%fillvalue = fillvalue + else + field_proc%fillvalue = 0._r8 + end if + if (present(accum_method)) then + field_proc%accum_method = accum_method + else + field_proc%accum_method = accum_mean + end if + +end function MGFieldPostProc_1D + +function MGFieldPostProc_2D(unpacked_ptr, packed_ptr, fillvalue, & + accum_method) result(field_proc) + real(r8), pointer, intent(in) :: unpacked_ptr(:,:) + real(r8), pointer, intent(in) :: packed_ptr(:,:) + real(r8), intent(in), optional :: fillvalue + integer, intent(in), optional :: accum_method + type(MGFieldPostProc) :: field_proc + + field_proc%rank = 2 + field_proc%unpacked_2D => unpacked_ptr + field_proc%packed_2D => packed_ptr + if (present(fillvalue)) then + field_proc%fillvalue = fillvalue + else + field_proc%fillvalue = 0._r8 + end if + if (present(accum_method)) then + field_proc%accum_method = accum_method + else + field_proc%accum_method = accum_mean + end if + +end function MGFieldPostProc_2D + +! Use the same intent(out) trick as for MGPacker, which is actually more +! useful here. +subroutine MGFieldPostProc_finalize(self) + class(MGFieldPostProc), intent(out) :: self +end subroutine MGFieldPostProc_finalize + +subroutine MGFieldPostProc_accumulate(self) + class(MGFieldPostProc), intent(inout) :: self + + select case (self%accum_method) + case (accum_null) + ! "Null" method does nothing. + case (accum_mean) + ! Allocation is done on the first accumulation step to allow the + ! MGFieldPostProc to be copied after construction without copying the + ! allocated array (until this function is first called). + self%num_steps = self%num_steps + 1 + select case (self%rank) + case (1) + SHR_ASSERT(associated(self%packed_1D), errMsg(__FILE__, __LINE__)) + if (.not. allocated(self%buffer_1D)) then + allocate(self%buffer_1D(size(self%packed_1D))) + self%buffer_1D = 0._r8 + end if + self%buffer_1D = self%buffer_1D + self%packed_1D + case (2) + SHR_ASSERT(associated(self%packed_2D), errMsg(__FILE__, __LINE__)) + if (.not. allocated(self%buffer_2D)) then + ! Awkward; in F2008 can be replaced by source/mold. + allocate(self%buffer_2D(& + size(self%packed_2D, 1),size(self%packed_2D, 2))) + self%buffer_2D = 0._r8 + end if + self%buffer_2D = self%buffer_2D + self%packed_2D + case default + call shr_sys_abort(errMsg(__FILE__, __LINE__) // & + " Unsupported rank for MGFieldPostProc accumulation.") + end select + case default + call shr_sys_abort(errMsg(__FILE__, __LINE__) // & + " Unrecognized MGFieldPostProc accumulation method.") + end select + +end subroutine MGFieldPostProc_accumulate + +subroutine MGFieldPostProc_process_and_unpack(self, packer) + class(MGFieldPostProc), intent(inout) :: self + class(MGPacker), intent(in) :: packer + + select case (self%accum_method) + case (accum_null) + ! "Null" method just leaves the value as the last time step, so don't + ! actually need to do anything. + case (accum_mean) + select case (self%rank) + case (1) + SHR_ASSERT(associated(self%packed_1D), errMsg(__FILE__, __LINE__)) + self%packed_1D = self%buffer_1D/self%num_steps + case (2) + SHR_ASSERT(associated(self%packed_2D), errMsg(__FILE__, __LINE__)) + self%packed_2D = self%buffer_2D/self%num_steps + case default + call shr_sys_abort(errMsg(__FILE__, __LINE__) // & + " Unsupported rank for MGFieldPostProc accumulation.") + end select + case default + call shr_sys_abort(errMsg(__FILE__, __LINE__) // & + " Unrecognized MGFieldPostProc accumulation method.") + end select + + call self%unpack_only(packer) + +end subroutine MGFieldPostProc_process_and_unpack + +subroutine MGFieldPostProc_unpack_only(self, packer) + class(MGFieldPostProc), intent(inout) :: self + class(MGPacker), intent(in) :: packer + + select case (self%rank) + case (1) + SHR_ASSERT(associated(self%unpacked_1D), errMsg(__FILE__, __LINE__)) + self%unpacked_1D = packer%unpack(self%packed_1D, self%fillvalue) + case (2) + SHR_ASSERT(associated(self%unpacked_2D), errMsg(__FILE__, __LINE__)) + self%unpacked_2D = packer%unpack(self%packed_2D, self%fillvalue) + case default + call shr_sys_abort(errMsg(__FILE__, __LINE__) // & + " Unsupported rank for MGFieldPostProc unpacking.") + end select + +end subroutine MGFieldPostProc_unpack_only + +#include "dynamic_vector_procdef.inc" + +function new_MGPostProc(packer) result(post_proc) + type(MGPacker), intent(in) :: packer + + type(MGPostProc) :: post_proc + + post_proc%packer = packer + call post_proc%field_procs%clear() + +end function new_MGPostProc + +! Can't use the same intent(out) trick, because PGI doesn't get the +! recursive deallocation right. +subroutine MGPostProc_finalize(self) + class(MGPostProc), intent(inout) :: self + + integer :: i + + call self%packer%finalize() + do i = 1, self%field_procs%vsize() + call self%field_procs%data(i)%finalize() + end do + call self%field_procs%clear() + call self%field_procs%shrink_to_fit() + +end subroutine MGPostProc_finalize + +subroutine add_field_1D(self, unpacked_ptr, packed_ptr, fillvalue, & + accum_method) + class(MGPostProc), intent(inout) :: self + real(r8), pointer, intent(in) :: unpacked_ptr(:) + real(r8), pointer, intent(in) :: packed_ptr(:) + real(r8), intent(in), optional :: fillvalue + integer, intent(in), optional :: accum_method + + call self%field_procs%push_back(MGFieldPostProc(unpacked_ptr, & + packed_ptr, fillvalue, accum_method)) + +end subroutine add_field_1D + +subroutine add_field_2D(self, unpacked_ptr, packed_ptr, fillvalue, & + accum_method) + class(MGPostProc), intent(inout) :: self + real(r8), pointer, intent(in) :: unpacked_ptr(:,:) + real(r8), pointer, intent(in) :: packed_ptr(:,:) + real(r8), intent(in), optional :: fillvalue + integer, intent(in), optional :: accum_method + + call self%field_procs%push_back(MGFieldPostProc(unpacked_ptr, & + packed_ptr, fillvalue, accum_method)) + +end subroutine add_field_2D + +subroutine MGPostProc_accumulate(self) + class(MGPostProc), intent(inout) :: self + + integer :: i + + do i = 1, self%field_procs%vsize() + call self%field_procs%data(i)%accumulate() + end do + +end subroutine MGPostProc_accumulate + +subroutine MGPostProc_process_and_unpack(self) + class(MGPostProc), intent(inout) :: self + + integer :: i + + do i = 1, self%field_procs%vsize() + call self%field_procs%data(i)%process_and_unpack(self%packer) + end do + +end subroutine MGPostProc_process_and_unpack + +subroutine MGPostProc_unpack_only(self) + class(MGPostProc), intent(inout) :: self + + integer :: i + + do i = 1, self%field_procs%vsize() + call self%field_procs%data(i)%unpack_only(self%packer) + end do + +end subroutine MGPostProc_unpack_only + +! This is necessary only to work around Intel/PGI bugs. +subroutine MGPostProc_copy(lhs, rhs) + class(MGPostProc), intent(out) :: lhs + type(MGPostProc), intent(in) :: rhs + + lhs%packer = rhs%packer + lhs%field_procs = rhs%field_procs +end subroutine MGPostProc_copy + +end module micro_mg_data diff --git a/models/atm/cam/src/physics/cam/micro_mg_utils.F90 b/models/atm/cam/src/physics/cam/micro_mg_utils.F90 index ef14ba9aeec3..55486a627b21 100644 --- a/models/atm/cam/src/physics/cam/micro_mg_utils.F90 +++ b/models/atm/cam/src/physics/cam/micro_mg_utils.F90 @@ -48,6 +48,7 @@ module micro_mg_utils size_dist_param_liq, & size_dist_param_basic, & avg_diameter, & + rising_factorial, & ice_deposition_sublimation, & kk2000_liq_autoconversion, & ice_autoconversion, & @@ -115,9 +116,6 @@ module micro_mg_utils real(r8), parameter, public :: rhow = 1000._r8 ! bulk density liquid real(r8), parameter, public :: rhows = 917._r8 ! bulk density water solid -! autoconversion size threshold for cloud ice to snow (m) -real(r8) :: dcs - ! fall speed parameters, V = aD^b (V is in m/s) ! droplets real(r8), parameter, public :: ac = 3.e7_r8 @@ -133,8 +131,7 @@ module micro_mg_utils real(r8), parameter, public :: br = 0.8_r8 ! mass of new crystal due to aerosol freezing and growth (kg) -real(r8), parameter, public :: mi0 = & - 4._r8/3._r8*pi*rhoi*(10.e-6_r8)*(10.e-6_r8)*(10.e-6_r8) +real(r8), parameter, public :: mi0 = 4._r8/3._r8*pi*rhoi*(10.e-6_r8)**3 !================================================= ! Private module parameters @@ -153,9 +150,6 @@ module micro_mg_utils real(r8), parameter :: dsph = 3._r8 ! Bounds for mean diameter for different constituents. -! (E.g. ice must be at least 10 microns but no more than twice the -! threshold for autoconversion to snow. -real(r8) :: lam_bnd_ice(2) real(r8), parameter :: lam_bnd_rain(2) = 1._r8/[500.e-6_r8, 20.e-6_r8] real(r8), parameter :: lam_bnd_snow(2) = 1._r8/[2000.e-6_r8, 10.e-6_r8] @@ -173,7 +167,7 @@ module micro_mg_utils ! collection efficiencies ! aggregation of cloud ice and snow -real(r8), parameter :: eii = 0.1_r8 +real(r8), parameter :: eii = 0.5_r8 ! immersion freezing parameters, bigg 1953 real(r8), parameter :: bimm = 100._r8 @@ -201,6 +195,21 @@ module micro_mg_utils real(r8) :: gamma_half_br_plus5 real(r8) :: gamma_half_bs_plus5 +!========================================================= +! Utilities that are cheaper if the compiler knows that +! some argument is an integer. +!========================================================= + +interface rising_factorial + module procedure rising_factorial_r8 + module procedure rising_factorial_integer +end interface rising_factorial + +interface var_coef + module procedure var_coef_r8 + module procedure var_coef_integer +end interface var_coef + !========================================================================== contains !========================================================================== @@ -216,7 +225,7 @@ module micro_mg_utils ! Check the list at the top of this module for descriptions of all other ! arguments. subroutine micro_mg_utils_init( kind, rh2o, cpair, tmelt_in, latvap, & - latice, errstring, dcs_in) + latice, dcs, errstring) integer, intent(in) :: kind real(r8), intent(in) :: rh2o @@ -224,10 +233,14 @@ subroutine micro_mg_utils_init( kind, rh2o, cpair, tmelt_in, latvap, & real(r8), intent(in) :: tmelt_in real(r8), intent(in) :: latvap real(r8), intent(in) :: latice - real(r8), intent(in) :: dcs_in + real(r8), intent(in) :: dcs character(128), intent(out) :: errstring + ! Name this array to workaround an XLF bug (otherwise could just use the + ! expression that sets it). + real(r8) :: ice_lambda_bounds(2) + !----------------------------------------------------------------------- errstring = ' ' @@ -242,9 +255,6 @@ subroutine micro_mg_utils_init( kind, rh2o, cpair, tmelt_in, latvap, & rv= rh2o ! water vapor gas constant cpp = cpair ! specific heat of dry air tmelt = tmelt_in - dcs = dcs_in - lam_bnd_ice(1) = 1._r8/(2._r8*dcs) - lam_bnd_ice(2) = 1._r8/10.e-6_r8 ! latent heats @@ -259,8 +269,15 @@ subroutine micro_mg_utils_init( kind, rh2o, cpair, tmelt_in, latvap, & ! Don't specify lambda bounds for cloud liquid, as they are determined by ! pgam dynamically. - mg_liq_props = MGHydrometeorProps(rhow, dsph, min_mean_mass=min_mean_mass_liq) - mg_ice_props = MGHydrometeorProps(rhoi, dsph, lam_bnd_ice, min_mean_mass_ice) + mg_liq_props = MGHydrometeorProps(rhow, dsph, & + min_mean_mass=min_mean_mass_liq) + + ! Mean ice diameter can not grow bigger than twice the autoconversion + ! threshold for snow. + ice_lambda_bounds = 1._r8/[2._r8*dcs, 10.e-6_r8] + mg_ice_props = MGHydrometeorProps(rhoi, dsph, & + ice_lambda_bounds, min_mean_mass_ice) + mg_rain_props = MGHydrometeorProps(rhow, dsph, lam_bnd_rain) mg_snow_props = MGHydrometeorProps(rhosn, dsph, lam_bnd_snow) @@ -294,6 +311,34 @@ end function NewMGHydrometeorProps !FORMULAS !======================================================================== +! Use gamma function to implement rising factorial extended to the reals. +pure function rising_factorial_r8(x, n) result(res) + real(r8), intent(in) :: x, n + real(r8) :: res + + res = gamma(x+n)/gamma(x) + +end function rising_factorial_r8 + +! Rising factorial can be performed much cheaper if n is a small integer. +pure function rising_factorial_integer(x, n) result(res) + real(r8), intent(in) :: x + integer, intent(in) :: n + real(r8) :: res + + integer :: i + real(r8) :: factor + + res = 1._r8 + factor = x + + do i = 1, n + res = res * factor + factor = factor + 1._r8 + end do + +end function rising_factorial_integer + ! Calculate correction due to latent heat for evaporation/sublimation elemental function calc_ab(t, qv, xxl) result(ab) real(r8), intent(in) :: t ! Temperature @@ -329,6 +374,7 @@ elemental subroutine size_dist_param_liq(props, qcic, ncic, rho, pgam, lamc) props_loc = props ! Get pgam from fit to observations of martin et al. 1994 +#if ! defined(CLUBB_BFB_S2) && ! defined(CLUBB_BFB_ALL) pgam = 0.0005714_r8*(ncic/1.e6_r8*rho) + 0.2714_r8 pgam = 1._r8/(pgam**2) - 1._r8 pgam = max(pgam, 2._r8) @@ -337,6 +383,21 @@ elemental subroutine size_dist_param_liq(props, qcic, ncic, rho, pgam, lamc) ! Set coefficient for use in size_dist_param_basic. props_loc%shape_coef = pi * props_loc%rho / 6._r8 * & rising_factorial(pgam+1._r8, props_loc%eff_dim) +#else + pgam = 0.0005714_r8*1.e-6_r8*ncic*rho + 0.2714_r8 + pgam = 1._r8/(pgam**2) - 1._r8 + pgam = max(pgam, 2._r8) + + ! Set coefficient for use in size_dist_param_basic. + ! The 3D case is so common and optimizable that we specialize it: + if (props_loc%eff_dim == 3._r8) then + props_loc%shape_coef = pi / 6._r8 * props_loc%rho * & + rising_factorial(pgam+1._r8, 3) + else + props_loc%shape_coef = pi / 6._r8 * props_loc%rho * & + rising_factorial(pgam+1._r8, props_loc%eff_dim) + end if +#endif ! Limit to between 2 and 50 microns mean size. props_loc%lambda_bounds = (pgam+1._r8)*1._r8/[50.e-6_r8, 2.e-6_r8] @@ -351,17 +412,6 @@ elemental subroutine size_dist_param_liq(props, qcic, ncic, rho, pgam, lamc) lamc = 0._r8 end if -contains - - ! Use gamma function to implement rising factorial extended to the reals. - elemental function rising_factorial(x, n) - real(r8), intent(in) :: x, n - real(r8) :: rising_factorial - - rising_factorial = gamma(x+n)/gamma(x) - - end function rising_factorial - end subroutine size_dist_param_liq ! Basic routine for getting size distribution parameters. @@ -405,8 +455,9 @@ end subroutine size_dist_param_basic real(r8) elemental function avg_diameter(q, n, rho_air, rho_sub) ! Finds the average diameter of particles given their density, and ! mass/number concentrations in the air. + ! Assumes that diameter follows an exponential distribution. real(r8), intent(in) :: q ! mass mixing ratio - real(r8), intent(in) :: n ! number concentration + real(r8), intent(in) :: n ! number concentration (per volume) real(r8), intent(in) :: rho_air ! local density of the air real(r8), intent(in) :: rho_sub ! density of the particle substance @@ -414,15 +465,27 @@ real(r8) elemental function avg_diameter(q, n, rho_air, rho_sub) end function avg_diameter -real(r8) elemental function var_coef(relvar, a) +elemental function var_coef_r8(relvar, a) result(res) ! Finds a coefficient for process rates based on the relative variance ! of cloud water. real(r8), intent(in) :: relvar real(r8), intent(in) :: a + real(r8) :: res + + res = rising_factorial(relvar, a) / relvar**a + +end function var_coef_r8 + +elemental function var_coef_integer(relvar, a) result(res) + ! Finds a coefficient for process rates based on the relative variance + ! of cloud water. + real(r8), intent(in) :: relvar + integer, intent(in) :: a + real(r8) :: res - var_coef = gamma(relvar + a) / (gamma(relvar) * relvar**a) + res = rising_factorial(relvar, a) / relvar**a -end function var_coef +end function var_coef_integer !======================================================================== !MICROPHYSICAL PROCESS CALCULATIONS @@ -488,7 +551,7 @@ elemental subroutine ice_deposition_sublimation(t, qv, qi, ni, & if (t < tmelt .and. vap_dep>0._r8) then ice_sublim=0._r8 else - !hm, make ice_sublim negative for consistency with other evap/sub processes + ! make ice_sublim negative for consistency with other evap/sub processes ice_sublim=min(vap_dep,0._r8) vap_dep=0._r8 end if @@ -546,12 +609,12 @@ elemental subroutine kk2000_liq_autoconversion(microp_uniform, qcic, & ! assume exponential sub-grid distribution of qc, resulting in additional ! factor related to qcvar below - ! hm switch for sub-columns, don't include sub-grid qc + ! switch for sub-columns, don't include sub-grid qc prc = prc_coef * & - 1350._r8 * qcic**2.47_r8 * (ncic/1.e6_r8*rho)**(-1.79_r8) - nprc = prc/droplet_mass_25um - nprc1 = prc/(qcic/ncic) + 1350._r8 * qcic**2.47_r8 * (ncic*1.e-6_r8*rho)**(-1.79_r8) + nprc = prc * (1._r8/droplet_mass_25um) + nprc1 = prc*ncic/qcic else prc=0._r8 @@ -565,12 +628,13 @@ end subroutine kk2000_liq_autoconversion ! Autoconversion of cloud ice to snow ! similar to Ferrier (1994) -elemental subroutine ice_autoconversion(t, qiic, lami, n0i, prci, nprci) +elemental subroutine ice_autoconversion(t, qiic, lami, n0i, dcs, prci, nprci) real(r8), intent(in) :: t real(r8), intent(in) :: qiic real(r8), intent(in) :: lami real(r8), intent(in) :: n0i + real(r8), intent(in) :: dcs real(r8), intent(out) :: prci real(r8), intent(out) :: nprci @@ -578,17 +642,29 @@ elemental subroutine ice_autoconversion(t, qiic, lami, n0i, prci, nprci) ! Assume autoconversion timescale of 180 seconds. real(r8), parameter :: ac_time = 180._r8 + ! Average mass of an ice particle. + real(r8) :: m_ip + ! Ratio of autoconversion diameter to average diameter. + real(r8) :: d_rat + if (t <= tmelt .and. qiic >= qsmall) then - nprci = n0i/(lami*ac_time)*exp(-lami*dcs) + d_rat = lami*dcs + + ! Rate of ice particle conversion (number). + nprci = n0i/(lami*ac_time)*exp(-d_rat) + + m_ip = (rhoi*pi/6._r8) / lami**3 - prci = pi*rhoi*n0i/(6._r8*ac_time)* & - (dcs**3/lami+3._r8*dcs**2/lami**2+ & - 6._r8*dcs/lami**3+6._r8/lami**4)*exp(-lami*dcs) + ! Rate of mass conversion. + ! Note that this is: + ! m n (d^3 + 3 d^2 + 6 d + 6) + prci = m_ip * nprci * & + (((d_rat + 3._r8)*d_rat + 6._r8)*d_rat + 6._r8) else - prci=0._r8 - nprci=0._r8 + prci = 0._r8 + nprci = 0._r8 end if end subroutine ice_autoconversion @@ -597,7 +673,7 @@ end subroutine ice_autoconversion !=================================== elemental subroutine immersion_freezing(microp_uniform, t, pgam, lamc, & - cdist1, qcic, relvar, mnuccc, nnuccc) + qcic, ncic, relvar, mnuccc, nnuccc) logical, intent(in) :: microp_uniform @@ -607,10 +683,10 @@ elemental subroutine immersion_freezing(microp_uniform, t, pgam, lamc, & ! Cloud droplet size distribution parameters real(r8), intent(in) :: pgam real(r8), intent(in) :: lamc - real(r8), intent(in) :: cdist1 - ! MMR of in-cloud liquid water + ! MMR and number concentration of in-cloud liquid water real(r8), intent(in) :: qcic + real(r8), intent(in) :: ncic ! Relative variance of cloud water real(r8), intent(in) :: relvar @@ -620,27 +696,24 @@ elemental subroutine immersion_freezing(microp_uniform, t, pgam, lamc, & real(r8), intent(out) :: nnuccc ! Number ! Coefficients that will be omitted for sub-columns - real(r8) :: dum, dum1 + real(r8) :: dum if (.not. microp_uniform) then - dum = var_coef(relvar, 2._r8) - dum1 = var_coef(relvar, 1._r8) + dum = var_coef(relvar, 2) else dum = 1._r8 - dum1 = 1._r8 end if if (qcic >= qsmall .and. t < 269.15_r8) then - mnuccc = dum * & - pi*pi/36._r8*rhow* & - cdist1*gamma(7._r8+pgam)* & - bimm*(exp(aimm*(tmelt - t))-1._r8)/lamc**3/lamc**3 + nnuccc = & + pi/6._r8*ncic*rising_factorial(pgam+1._r8, 3)* & + bimm*(exp(aimm*(tmelt - t))-1._r8)/lamc**3 - nnuccc = dum1 * & - pi/6._r8*cdist1*gamma(pgam+4._r8) & - *bimm*(exp(aimm*(tmelt - t))-1._r8)/lamc**3 + mnuccc = dum * nnuccc * & + pi/6._r8*rhow* & + rising_factorial(pgam+4._r8, 3)/lamc**3 else mnuccc = 0._r8 @@ -654,7 +727,7 @@ end subroutine immersion_freezing ! dust size and number in multiple bins are read in from companion routine pure subroutine contact_freezing (microp_uniform, t, p, rndst, nacon, & - pgam, lamc, cdist1, qcic, relvar, mnucct, nnucct) + pgam, lamc, qcic, ncic, relvar, mnucct, nnucct) logical, intent(in) :: microp_uniform @@ -666,10 +739,10 @@ pure subroutine contact_freezing (microp_uniform, t, p, rndst, nacon, & ! Size distribution parameters for cloud droplets real(r8), intent(in) :: pgam(:) real(r8), intent(in) :: lamc(:) - real(r8), intent(in) :: cdist1(:) - ! MMR of in-cloud liquid water + ! MMR and number concentration of in-cloud liquid water real(r8), intent(in) :: qcic(:) + real(r8), intent(in) :: ncic(:) ! Relative cloud water variance real(r8), intent(in) :: relvar(:) @@ -689,6 +762,9 @@ pure subroutine contact_freezing (microp_uniform, t, p, rndst, nacon, & ! Coefficients not used for subcolumns real(r8) :: dum, dum1 + ! Common factor between mass and number. + real(r8) :: contact_factor + integer :: i do i = 1,size(t) @@ -713,13 +789,13 @@ pure subroutine contact_freezing (microp_uniform, t, p, rndst, nacon, & ndfaer = 1.381e-23_r8*t(i)*nslip/(6._r8*pi*viscosity*rndst(i,:)) ! aerosol diffusivity (m2/s) - mnucct(i) = dum * & - dot_product(ndfaer,nacon(i,:)*tcnt)*pi*pi/3._r8*rhow* & - cdist1(i)*gamma(pgam(i)+5._r8)/lamc(i)**4 + contact_factor = dot_product(ndfaer,nacon(i,:)*tcnt) * pi * & + ncic(i) * (pgam(i) + 1._r8) / lamc(i) + + mnucct(i) = dum * contact_factor * & + pi/3._r8*rhow*rising_factorial(pgam(i)+2._r8, 3)/lamc(i)**3 - nnucct(i) = dum1 * & - dot_product(ndfaer,nacon(i,:)*tcnt)*2._r8*pi* & - cdist1(i)*gamma(pgam(i)+2._r8)/lamc(i) + nnucct(i) = dum1 * 2._r8 * contact_factor else @@ -751,10 +827,8 @@ elemental subroutine snow_self_aggregation(t, rho, asn, rhosn, qsic, nsic, nsagg real(r8), intent(out) :: nsagg if (qsic >= qsmall .and. t <= tmelt) then - nsagg = -1108._r8*asn*eii* & - pi**((1._r8-bs)/3._r8)*rhosn**((-2._r8-bs)/3._r8)* & - rho**((2._r8+bs)/3._r8)*qsic**((2._r8+bs)/3._r8)* & - (nsic*rho)**((4._r8-bs)/3._r8) /(4._r8*720._r8*rho) + nsagg = -1108._r8*eii/(4._r8*720._r8*rhosn)*asn*qsic*nsic*rho*& + ((qsic/nsic)*(1._r8/(rhosn*pi)))**((bs-1._r8)/3._r8) else nsagg=0._r8 end if @@ -800,6 +874,9 @@ elemental subroutine accrete_cloud_water_snow(t, rho, asn, uns, mu, qcic, ncic, real(r8) :: dum real(r8) :: eci ! collection efficiency for riming of snow by droplets + ! Fraction of cloud droplets accreted per second + real(r8) :: accrete_rate + ! ignore collision of snow with droplets above freezing if (qsic >= qsmall .and. t <= tmelt .and. qcic >= qsmall) then @@ -810,7 +887,7 @@ elemental subroutine accrete_cloud_water_snow(t, rho, asn, uns, mu, qcic, ncic, ! collection efficiency is approximation based on stoke's law (Thompson et al. 2004) dc0 = (pgam+1._r8)/lamc - dum = dc0*dc0*uns*rhow/(9._r8*mu*(1._r8/lams)) + dum = dc0*dc0*uns*rhow*lams/(9._r8*mu) eci = dum*dum/((dum+0.4_r8)*(dum+0.4_r8)) eci = max(eci,0._r8) @@ -818,9 +895,9 @@ elemental subroutine accrete_cloud_water_snow(t, rho, asn, uns, mu, qcic, ncic, ! no impact of sub-grid distribution of qc since psacws ! is linear in qc - - psacws = pi/4._r8*asn*qcic*rho*n0s*eci*gamma_bs_plus3 / lams**(bs+3._r8) - npsacws = pi/4._r8*asn*ncic*rho*n0s*eci*gamma_bs_plus3 / lams**(bs+3._r8) + accrete_rate = pi/4._r8*asn*rho*n0s*eci*gamma_bs_plus3 / lams**(bs+3._r8) + psacws = accrete_rate*qcic + npsacws = accrete_rate*ncic else psacws = 0._r8 npsacws = 0._r8 @@ -844,16 +921,14 @@ elemental subroutine secondary_ice_production(t, psacws, msacwi, nsacwi) if((t < 270.16_r8) .and. (t >= 268.16_r8)) then nsacwi = 3.5e8_r8*(270.16_r8-t)/2.0_r8*psacws - msacwi = min(nsacwi*mi0, psacws) else if((t < 268.16_r8) .and. (t >= 265.16_r8)) then nsacwi = 3.5e8_r8*(t-265.16_r8)/3.0_r8*psacws - msacwi = min(nsacwi*mi0, psacws) else nsacwi = 0.0_r8 - msacwi = 0.0_r8 endif - psacws = max(0.0_r8,psacws - nsacwi*mi0) + msacwi = min(nsacwi*mi0, psacws) + psacws = psacws - msacwi end subroutine secondary_ice_production @@ -894,21 +969,24 @@ elemental subroutine accrete_rain_snow(t, rho, umr, ums, unr, uns, qric, qsic, & ! Collection efficiency for accretion of rain by snow real(r8), parameter :: ecr = 1.0_r8 + ! Ratio of average snow diameter to average rain diameter. + real(r8) :: d_rat + ! Common factor between mass and number expressions + real(r8) :: common_factor + if (qric >= icsmall .and. qsic >= icsmall .and. t <= tmelt) then - pracs = pi*pi*ecr*(((1.2_r8*umr-0.95_r8*ums)**2 + & - 0.08_r8*ums*umr)**0.5_r8 * & - rhow * rho * n0r * n0s * & - (5._r8/(lamr**6 * lams)+ & - 2._r8/(lamr**5 * lams**2)+ & - 0.5_r8/(lamr**4 * lams**3))) + common_factor = pi*ecr*rho*n0r*n0s/(lamr**3 * lams) + + d_rat = lamr/lams + + pracs = common_factor*pi*rhow* & + sqrt((1.2_r8*umr-0.95_r8*ums)**2 + 0.08_r8*ums*umr) / lamr**3 * & + ((0.5_r8*d_rat + 2._r8)*d_rat + 5._r8) - npracs = pi/2._r8*rho*ecr* (1.7_r8*(unr-uns)**2 + & - 0.3_r8*unr*uns)**0.5_r8 * & - n0r*n0s* & - (1._r8/(lamr**3 * lams)+ & - 1._r8/(lamr**2 * lams**2)+ & - 1._r8/(lamr * lams**3)) + npracs = common_factor*0.5_r8* & + sqrt(1.7_r8*(unr-uns)**2 + 0.3_r8*unr*uns) * & + ((d_rat + 1._r8)*d_rat + 1._r8) else pracs = 0._r8 @@ -936,14 +1014,11 @@ elemental subroutine heterogeneous_rain_freezing(t, qric, nric, lamr, mnuccr, nn if (t < 269.15_r8 .and. qric >= qsmall) then - ! Division by lamr**3 twice is old workaround to avoid overflow. - ! Probably no longer necessary - mnuccr = 20._r8*pi*pi*rhow*nric*bimm* & - (exp(aimm*(tmelt - t))-1._r8)/lamr**3 & - /lamr**3 - nnuccr = pi*nric*bimm* & (exp(aimm*(tmelt - t))-1._r8)/lamr**3 + + mnuccr = nnuccr * 20._r8*pi*rhow/lamr**3 + else mnuccr = 0._r8 nnuccr = 0._r8 @@ -989,7 +1064,7 @@ elemental subroutine accrete_cloud_water_rain(microp_uniform, qric, qcic, & ! include sub-grid distribution of cloud water pra = pra_coef * 67._r8*(qcic*qric)**1.15_r8 - npra = pra/(qcic/ncic) + npra = pra*ncic/qcic else pra = 0._r8 @@ -1047,13 +1122,17 @@ elemental subroutine accrete_cloud_ice_snow(t, rho, asn, qiic, niic, qsic, & real(r8), intent(out) :: prai ! MMR real(r8), intent(out) :: nprai ! Number + ! Fraction of cloud ice particles accreted per second + real(r8) :: accrete_rate + if (qsic >= qsmall .and. qiic >= qsmall .and. t <= tmelt) then - prai = pi/4._r8 * asn * qiic * rho * n0s * eii * gamma_bs_plus3/ & + accrete_rate = pi/4._r8 * eii * asn * rho * n0s * gamma_bs_plus3/ & lams**(bs+3._r8) - nprai = pi/4._r8 * asn * niic * rho * n0s * eii * gamma_bs_plus3/ & - lams**(bs+3._r8) + prai = accrete_rate * qiic + nprai = accrete_rate * niic + else prai = 0._r8 nprai = 0._r8 @@ -1068,7 +1147,7 @@ end subroutine accrete_cloud_ice_snow ! except for transfer of cloud water to snow through bergeron process elemental subroutine evaporate_sublimate_precip(t, rho, dv, mu, sc, q, qvl, qvi, & - lcldm, cldmax, arn, asn, qcic, qiic, qric, qsic, lamr, n0r, lams, n0s, & + lcldm, precip_frac, arn, asn, qcic, qiic, qric, qsic, lamr, n0r, lams, n0s, & pre, prds) real(r8), intent(in) :: t ! temperature @@ -1080,7 +1159,7 @@ elemental subroutine evaporate_sublimate_precip(t, rho, dv, mu, sc, q, qvl, qvi, real(r8), intent(in) :: qvl ! saturation humidity (water) real(r8), intent(in) :: qvi ! saturation humidity (ice) real(r8), intent(in) :: lcldm ! liquid cloud fraction - real(r8), intent(in) :: cldmax ! precipitation fraction (maximum overlap) + real(r8), intent(in) :: precip_frac ! precipitation fraction (maximum overlap) ! fallspeed parameters real(r8), intent(in) :: arn ! rain @@ -1121,7 +1200,7 @@ elemental subroutine evaporate_sublimate_precip(t, rho, dv, mu, sc, q, qvl, qvi, ! only calculate if there is some precip fraction > cloud fraction - if (cldmax > dum) then + if (precip_frac > dum) then ! calculate q for out-of-cloud region qclr=(q-dum*qvl)/(1._r8-dum) @@ -1139,9 +1218,9 @@ elemental subroutine evaporate_sublimate_precip(t, rho, dv, mu, sc, q, qvl, qvi, pre = eps*(qclr-qvl)/ab ! only evaporate in out-of-cloud region - ! and distribute across cldmax - pre=min(pre*(cldmax-dum),0._r8) - pre=pre/cldmax + ! and distribute across precip_frac + pre=min(pre*(precip_frac-dum),0._r8) + pre=pre/precip_frac else pre = 0._r8 end if @@ -1156,9 +1235,9 @@ elemental subroutine evaporate_sublimate_precip(t, rho, dv, mu, sc, q, qvl, qvi, (lams**(5._r8/2._r8+bs/2._r8))) prds = eps*(qclr-qvi)/ab - ! only sublimate in out-of-cloud region and distribute over cldmax - prds=min(prds*(cldmax-dum),0._r8) - prds=prds/cldmax + ! only sublimate in out-of-cloud region and distribute over precip_frac + prds=min(prds*(precip_frac-dum),0._r8) + prds=prds/precip_frac else prds = 0._r8 end if diff --git a/models/atm/cam/src/physics/cam/microp_aero.F90 b/models/atm/cam/src/physics/cam/microp_aero.F90 index 84177b859809..a5b180977c90 100644 --- a/models/atm/cam/src/physics/cam/microp_aero.F90 +++ b/models/atm/cam/src/physics/cam/microp_aero.F90 @@ -2,7 +2,7 @@ module microp_aero !--------------------------------------------------------------------------------- ! Purpose: -! CAM Interface for aerosol activation +! CAM driver layer for aerosol activation processes. ! ! ***N.B.*** This module is currently hardcoded to recognize only the aerosols/modes that ! affect the climate calculation. This is implemented by using list @@ -15,30 +15,36 @@ module microp_aero ! Gettelman et al., 2010 J. Geophys. Res. - Atmospheres (G2010) ! for questions contact Andrew Gettelman (andrew@ucar.edu) ! Modifications: A. Gettelman Nov 2010 - changed to support separation of -! microphysics and macrophysics and concentrate aerosol information here +! microphysics and macrophysics and concentrate aerosol information here +! B. Eaton, Sep 2014 - Refactored to move CAM interface code into the CAM +! interface modules and preserve just the driver layer functionality here. ! !--------------------------------------------------------------------------------- use shr_kind_mod, only: r8=>shr_kind_r8 use spmd_utils, only: masterproc use ppgrid, only: pcols, pver, pverp -use physconst, only: rair, tmelt -use constituents, only: cnst_get_ind, pcnst +use ref_pres, only: top_lev => trop_cloud_top_lev +use physconst, only: rair +use constituents, only: cnst_get_ind use physics_types, only: physics_state, physics_ptend, physics_ptend_init use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field -use phys_control, only: phys_getopts +use phys_control, only: phys_getopts, use_hetfrz_classnuc use rad_constituents, only: rad_cnst_get_info, rad_cnst_get_aer_mmr, rad_cnst_get_aer_props, & - rad_cnst_get_mode_num, rad_cnst_get_mode_props -use shr_spfn_mod, only: erf => shr_spfn_erf, & - erfc => shr_spfn_erfc -use wv_saturation, only: qsat_water -use nucleate_ice, only: nucleati + rad_cnst_get_mode_num + +use nucleate_ice_cam, only: use_preexisting_ice, nucleate_ice_cam_readnl, nucleate_ice_cam_register, & + nucleate_ice_cam_init, nucleate_ice_cam_calc + use ndrop, only: ndrop_init, dropmixnuc use ndrop_bam, only: ndrop_bam_init, ndrop_bam_run, ndrop_bam_ccn + +use hetfrz_classnuc_cam, only: hetfrz_classnuc_cam_readnl, hetfrz_classnuc_cam_register, hetfrz_classnuc_cam_init, & + hetfrz_classnuc_cam_save_cbaero, hetfrz_classnuc_cam_calc + use cam_history, only: addfld, phys_decomp, add_default, outfld use cam_logfile, only: iulog use cam_abortutils, only: endrun -use ref_pres, only: top_lev => trop_cloud_top_lev implicit none private @@ -48,7 +54,8 @@ module microp_aero ! Private module data -character(len=16) :: eddy_scheme ! eddy scheme +character(len=16) :: eddy_scheme +logical :: micro_do_icesupersat ! contact freezing due to dust ! dust number mean radius (m), Zender et al JGR 2003 assuming number mode radius of 0.6 micron, sigma=2 @@ -57,7 +64,7 @@ module microp_aero real(r8), parameter :: rn_dst3 = 1.576e-6_r8 real(r8), parameter :: rn_dst4 = 3.026e-6_r8 -real(r8), public :: bulk_scale ! prescribed aerosol bulk sulfur scale factor +real(r8) :: bulk_scale ! prescribed aerosol bulk sulfur scale factor ! smallest mixing ratio considered in microphysics real(r8), parameter :: qsmall = 1.e-18_r8 @@ -75,7 +82,6 @@ module microp_aero integer :: wp2_idx = -1 integer :: ast_idx = -1 integer :: cldo_idx = -1 -integer :: dgnum_idx = -1 integer :: dgnumwet_idx = -1 ! Bulk aerosols @@ -84,14 +90,11 @@ module microp_aero integer :: naer_all ! number of aerosols affecting climate integer :: idxsul = -1 ! index in aerosol list for sulfate -integer :: idxdst1 = -1 ! index in aerosol list for dust1 integer :: idxdst2 = -1 ! index in aerosol list for dust2 integer :: idxdst3 = -1 ! index in aerosol list for dust3 integer :: idxdst4 = -1 ! index in aerosol list for dust4 -integer :: idxbcphi = -1 ! index in aerosol list for Soot (BCPHIL) ! modal aerosols -logical :: prog_modal_aero logical :: clim_modal_aero integer :: mode_accum_idx = -1 ! index of accumulation mode @@ -102,14 +105,14 @@ module microp_aero integer :: coarse_dust_idx = -1 ! index of dust in coarse mode integer :: coarse_nacl_idx = -1 ! index of nacl in coarse mode -integer :: naai_idx, naai_hom_idx, npccn_idx, rndst_idx, nacon_idx +integer :: npccn_idx, rndst_idx, nacon_idx -real(r8) :: sigmag_aitken logical :: separate_dust = .false. -!=============================================================================== +!========================================================================================= contains -!=============================================================================== +!========================================================================================= + subroutine microp_aero_register !----------------------------------------------------------------------- ! @@ -122,15 +125,18 @@ subroutine microp_aero_register use ppgrid, only: pcols use physics_buffer, only: pbuf_add_field, dtype_r8 - call pbuf_add_field('NAAI', 'physpkg',dtype_r8,(/pcols,pver/), naai_idx) - call pbuf_add_field('NAAI_HOM', 'physpkg',dtype_r8,(/pcols,pver/), naai_hom_idx) call pbuf_add_field('NPCCN', 'physpkg',dtype_r8,(/pcols,pver/), npccn_idx) + call pbuf_add_field('RNDST', 'physpkg',dtype_r8,(/pcols,pver,4/), rndst_idx) call pbuf_add_field('NACON', 'physpkg',dtype_r8,(/pcols,pver,4/), nacon_idx) + call nucleate_ice_cam_register() + call hetfrz_classnuc_cam_register() end subroutine microp_aero_register +!========================================================================================= + subroutine microp_aero_init !----------------------------------------------------------------------- @@ -143,7 +149,7 @@ subroutine microp_aero_init !----------------------------------------------------------------------- ! local variables - integer :: iaer + integer :: iaer, ierr integer :: m, n, nmodes, nspec character(len=32) :: str32 @@ -152,8 +158,9 @@ subroutine microp_aero_init !----------------------------------------------------------------------- ! Query the PBL eddy scheme - call phys_getopts(eddy_scheme_out = eddy_scheme, & - history_amwg_out = history_amwg) + call phys_getopts(eddy_scheme_out = eddy_scheme, & + history_amwg_out = history_amwg, & + micro_do_icesupersat_out = micro_do_icesupersat) ! Access the physical properties of the aerosols that are affecting the climate ! by using routines from the rad_constituents module. @@ -166,16 +173,13 @@ subroutine microp_aero_init select case(trim(eddy_scheme)) case ('diag_TKE') - tke_idx = pbuf_get_index('tke') + tke_idx = pbuf_get_index('tke') case ('CLUBB_SGS') - wp2_idx = pbuf_get_index('WP2') + wp2_idx = pbuf_get_index('WP2_nadv') case default kvh_idx = pbuf_get_index('kvh') end select - ! prog_modal_aero determines whether prognostic modal aerosols are present in the run. - call phys_getopts(prog_modal_aero_out=prog_modal_aero) - ! clim_modal_aero determines whether modal aerosols are used in the climate calculation. ! The modal aerosols can be either prognostic or prescribed. call rad_cnst_get_info(0, nmodes=nmodes) @@ -186,7 +190,6 @@ subroutine microp_aero_init if (clim_modal_aero) then cldo_idx = pbuf_get_index('CLDO') - dgnum_idx = pbuf_get_index('DGNUM' ) dgnumwet_idx = pbuf_get_index('DGNUMWET') call ndrop_init() @@ -251,9 +254,6 @@ subroutine microp_aero_init call endrun(routine//': ERROR required mode-species type not found') end if - ! get specific mode properties - call rad_cnst_get_mode_props(0, mode_aitken_idx, sigmag=sigmag_aitken) - else ! Props needed for BAM number concentration calcs. @@ -270,11 +270,9 @@ subroutine microp_aero_init ! Look for sulfate, dust, and soot in this list (Bulk aerosol only) if (trim(aername(iaer)) == 'SULFATE') idxsul = iaer - if (trim(aername(iaer)) == 'DUST1') idxdst1 = iaer if (trim(aername(iaer)) == 'DUST2') idxdst2 = iaer if (trim(aername(iaer)) == 'DUST3') idxdst3 = iaer if (trim(aername(iaer)) == 'DUST4') idxdst4 = iaer - if (trim(aername(iaer)) == 'BCPHIL') idxbcphi = iaer end do call ndrop_bam_init() @@ -285,18 +283,17 @@ subroutine microp_aero_init call addfld('WSUB ', 'm/s ', pver, 'A', 'Diagnostic sub-grid vertical velocity' ,phys_decomp) call addfld('WSUBI ', 'm/s ', pver, 'A', 'Diagnostic sub-grid vertical velocity for ice' ,phys_decomp) - call addfld('NIHF', '1/m3', pver, 'A', 'Activated Ice Number Concentation due to homogenous freezing', phys_decomp) - call addfld('NIDEP', '1/m3', pver, 'A', 'Activated Ice Number Concentation due to deposition nucleation',phys_decomp) - call addfld('NIIMM', '1/m3', pver, 'A', 'Activated Ice Number Concentation due to immersion freezing', phys_decomp) - call addfld('NIMEY', '1/m3', pver, 'A', 'Activated Ice Number Concentation due to meyers deposition', phys_decomp) if (history_amwg) then call add_default ('WSUB ', 1, ' ') end if + call nucleate_ice_cam_init(mincld, bulk_scale) + call hetfrz_classnuc_cam_init(mincld) + end subroutine microp_aero_init -!=============================================================================== +!========================================================================================= subroutine microp_aero_readnl(nlfile) @@ -338,9 +335,12 @@ subroutine microp_aero_readnl(nlfile) ! set local variables bulk_scale = microp_aero_bulk_scale + call nucleate_ice_cam_readnl(nlfile) + call hetfrz_classnuc_cam_readnl(nlfile) + end subroutine microp_aero_readnl -!=============================================================================== +!========================================================================================= subroutine microp_aero_run ( & state, ptend, deltatin, pbuf) @@ -351,45 +351,20 @@ subroutine microp_aero_run ( & real(r8), intent(in) :: deltatin ! time step (s) type(physics_buffer_desc), pointer :: pbuf(:) - - - ! local workspace ! all units mks unless otherwise stated integer :: i, k, m integer :: itim_old - integer :: lchnk - integer :: ncol integer :: nmodes - integer :: nucboast real(r8), pointer :: ast(:,:) - real(r8) :: icecldf(pcols,pver) ! ice cloud fraction - real(r8) :: liqcldf(pcols,pver) ! liquid cloud fraction - - real(r8), pointer :: naai(:,:) ! number of activated aerosol for ice nucleation - real(r8), pointer :: naai_hom(:,:) ! number of activated aerosol for ice nucleation (homogeneous freezing only) real(r8), pointer :: npccn(:,:) ! number of CCN (liquid activated) + real(r8), pointer :: rndst(:,:,:) ! radius of 4 dust bins for contact freezing real(r8), pointer :: nacon(:,:,:) ! number in 4 dust bins for contact freezing - real(r8), pointer :: t(:,:) ! input temperature (K) - real(r8), pointer :: qn(:,:) ! input water vapor mixing ratio (kg/kg) - ! note: all input cloud variables are grid-averaged - real(r8), pointer :: qc(:,:) ! cloud water mixing ratio (kg/kg) - real(r8), pointer :: qi(:,:) ! cloud ice mixing ratio (kg/kg) - real(r8), pointer :: nc(:,:) ! cloud water number conc (1/kg) - real(r8), pointer :: ni(:,:) ! cloud ice number conc (1/kg) - real(r8), pointer :: pmid(:,:) ! pressure at layer midpoints (pa) - real(r8), pointer :: pdel(:,:) ! pressure difference across level (pa) - real(r8), pointer :: pint(:,:) ! air pressure layer interfaces (pa) - real(r8), pointer :: rpdel(:,:) ! inverse pressure difference across level (pa) - real(r8), pointer :: zm(:,:) ! geopotential height of model levels (m) - real(r8), pointer :: omega(:,:) ! vertical velocity (Pa/s) - real(r8), pointer :: num_accum(:,:) ! number m.r. of accumulation mode - real(r8), pointer :: num_aitken(:,:) ! number m.r. of aitken mode real(r8), pointer :: num_coarse(:,:) ! number m.r. of coarse mode real(r8), pointer :: coarse_dust(:,:) ! mass m.r. of coarse dust real(r8), pointer :: coarse_nacl(:,:) ! mass m.r. of coarse nacl @@ -401,17 +376,14 @@ subroutine microp_aero_run ( & real(r8), pointer :: cldn(:,:) ! cloud fraction real(r8), pointer :: cldo(:,:) ! old cloud fraction - real(r8), pointer :: dgnum(:,:,:) ! aerosol mode dry diameter real(r8), pointer :: dgnumwet(:,:,:) ! aerosol mode diameter real(r8), pointer :: aer_mmr(:,:) ! aerosol mass mixing ratio real(r8) :: rho(pcols,pver) ! air density (kg m-3) - real(r8) :: relhum(pcols,pver) ! relative humidity - real(r8) :: icldm(pcols,pver) ! ice cloud fraction + real(r8) :: lcldm(pcols,pver) ! liq cloud fraction - real(r8) :: nfice(pcols,pver) ! fice variable - real(r8) :: dumfice ! dummy var in fice calc + real(r8) :: lcldn(pcols,pver) ! fractional coverage of new liquid cloud real(r8) :: lcldo(pcols,pver) ! fractional coverage of old liquid cloud real(r8) :: qcld ! total cloud water @@ -419,74 +391,63 @@ subroutine microp_aero_run ( & real(r8) :: dum, dum2 ! temporary dummy variable real(r8) :: dmc, ssmc ! variables for modal scheme. - real(r8) :: so4_num ! so4 aerosol number (#/cm^3) - real(r8) :: soot_num ! soot (hydrophilic) aerosol number (#/cm^3) - real(r8) :: dst1_num,dst2_num,dst3_num,dst4_num ! dust aerosol number (#/cm^3) - real(r8) :: dst_num ! total dust aerosol number (#/cm^3) - - real(r8) :: qs(pcols) ! liquid-ice weighted sat mixing rat (kg/kg) - real(r8) :: es(pcols) ! liquid-ice weighted sat vapor press (pa) - real(r8) :: gammas(pcols) ! parameter for cond/evap of cloud water - ! bulk aerosol variables real(r8), allocatable :: naer2(:,:,:) ! bulk aerosol number concentration (1/m3) real(r8), allocatable :: maerosol(:,:,:) ! bulk aerosol mass conc (kg/m3) real(r8) :: wsub(pcols,pver) ! diagnosed sub-grid vertical velocity st. dev. (m/s) real(r8) :: wsubi(pcols,pver) ! diagnosed sub-grid vertical velocity ice (m/s) - - ! history output for ice nucleation - real(r8) :: nihf(pcols,pver) !output number conc of ice nuclei due to heterogenous freezing (1/m3) - real(r8) :: niimm(pcols,pver) !output number conc of ice nuclei due to immersion freezing (hetero nuc) (1/m3) - real(r8) :: nidep(pcols,pver) !output number conc of ice nuclei due to deoposion nucleation (hetero nuc) (1/m3) - real(r8) :: nimey(pcols,pver) !output number conc of ice nuclei due to meyers deposition (1/m3) + real(r8) :: nucboast real(r8) :: wght + real(r8), allocatable :: factnum(:,:,:) ! activation fraction for aerosol number !------------------------------------------------------------------------------- - lchnk = state%lchnk - ncol = state%ncol - t => state%t - qn => state%q(:,:,1) - qc => state%q(:,:,cldliq_idx) - qi => state%q(:,:,cldice_idx) - nc => state%q(:,:,numliq_idx) - ni => state%q(:,:,numice_idx) - pmid => state%pmid - pdel => state%pdel - pint => state%pint - rpdel => state%rpdel - zm => state%zm - omega => state%omega + associate( & + lchnk => state%lchnk, & + ncol => state%ncol, & + t => state%t, & + qc => state%q(:,:,cldliq_idx), & + qi => state%q(:,:,cldice_idx), & + nc => state%q(:,:,numliq_idx), & + pmid => state%pmid ) itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, ast_idx, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - - liqcldf(:ncol,:pver) = ast(:ncol,:pver) - icecldf(:ncol,:pver) = ast(:ncol,:pver) + if (micro_do_icesupersat) then + call pbuf_get_field(pbuf, cldo_idx, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + else + call pbuf_get_field(pbuf, ast_idx, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + endif - call pbuf_get_field(pbuf, naai_idx, naai) - call pbuf_get_field(pbuf, naai_hom_idx, naai_hom) call pbuf_get_field(pbuf, npccn_idx, npccn) + call pbuf_get_field(pbuf, nacon_idx, nacon) call pbuf_get_field(pbuf, rndst_idx, rndst) if (clim_modal_aero) then itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, ast_idx, cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + + if (micro_do_icesupersat) then + call pbuf_get_field(pbuf, cldo_idx, cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + else + call pbuf_get_field(pbuf, ast_idx, cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + endif + call pbuf_get_field(pbuf, cldo_idx, cldo, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call rad_cnst_get_info(0, nmodes=nmodes) - call pbuf_get_field(pbuf, dgnum_idx, dgnum, start=(/1,1,1/), kount=(/pcols,pver,nmodes/) ) call pbuf_get_field(pbuf, dgnumwet_idx, dgnumwet, start=(/1,1,1/), kount=(/pcols,pver,nmodes/) ) + + allocate(factnum(pcols,pver,nmodes)) + end if ! initialize output - naai(1:ncol,1:pver) = 0._r8 - naai_hom(1:ncol,1:pver) = 0._r8 npccn(1:ncol,1:pver) = 0._r8 + nacon(1:ncol,1:pver,:) = 0._r8 ! set default or fixed dust bins for contact freezing @@ -495,11 +456,10 @@ subroutine microp_aero_run ( & rndst(1:ncol,1:pver,3) = rn_dst3 rndst(1:ncol,1:pver,4) = rn_dst4 - ! initialize history output fields for ice nucleation - nihf(1:ncol,1:pver) = 0._r8 - niimm(1:ncol,1:pver) = 0._r8 - nidep(1:ncol,1:pver) = 0._r8 - nimey(1:ncol,1:pver) = 0._r8 + ! save copy of cloud borne aerosols for use in heterogeneous freezing + if (use_hetfrz_classnuc) then + call hetfrz_classnuc_cam_save_cbaero(state, pbuf) + end if ! initialize time-varying parameters do k = top_lev, pver @@ -510,8 +470,6 @@ subroutine microp_aero_run ( & if (clim_modal_aero) then ! mode number mixing ratios - call rad_cnst_get_mode_num(0, mode_accum_idx, 'a', state, pbuf, num_accum) - call rad_cnst_get_mode_num(0, mode_aitken_idx, 'a', state, pbuf, num_aitken) call rad_cnst_get_mode_num(0, mode_coarse_dst_idx, 'a', state, pbuf, num_coarse) ! mode specie mass m.r. @@ -527,7 +485,7 @@ subroutine microp_aero_run ( & do m = 1, naer_all call rad_cnst_get_aer_mmr(0, m, state, pbuf, aer_mmr) maerosol(:ncol,:,m) = aer_mmr(:ncol,:)*rho(:ncol,:) - + if (m .eq. idxsul) then naer2(:ncol,:,m) = maerosol(:ncol,:,m)*num_to_mass_aer(m)*bulk_scale else @@ -548,6 +506,7 @@ subroutine microp_aero_run ( & call pbuf_get_field(pbuf, wp2_idx, wp2, start=(/1,1,itim_old/),kount=(/pcols,pverp,1/)) allocate(tke(pcols,pverp)) tke(:ncol,:) = (3._r8/2._r8)*wp2(:ncol,:) + case default call pbuf_get_field(pbuf, kvh_idx, kvh) end select @@ -561,174 +520,59 @@ subroutine microp_aero_run ( & select case (trim(eddy_scheme)) case ('diag_TKE', 'CLUBB_SGS') - wsub(i,k) = sqrt(0.5_r8*(tke(i,k) + tke(i,k+1))*(2._r8/3._r8)) - wsub(i,k) = min(wsub(i,k),10._r8) + wsub(i,k) = sqrt(0.5_r8*(tke(i,k) + tke(i,k+1))*(2._r8/3._r8)) + wsub(i,k) = min(wsub(i,k),10._r8) case default ! get sub-grid vertical velocity from diff coef. ! following morrison et al. 2005, JAS ! assume mixing length of 30 m - dum = (kvh(i,k) + kvh(i,k+1))/2._r8/30._r8 + dum = (kvh(i,k) + kvh(i,k+1))/2._r8/30._r8 ! use maximum sub-grid vertical vel of 10 m/s - dum = min(dum, 10._r8) + dum = min(dum, 10._r8) ! set wsub to value at current vertical level - wsub(i,k) = dum - end select - - wsubi(i,k) = max(0.001_r8, wsub(i,k)) - wsubi(i,k) = min(wsubi(i,k), 0.2_r8) - -#ifdef CLUBB_SGS - if (wsubi(i,k) .le. 0.04_r8) then - nucboast=100._r8 - wsubi(i,k)=nucboast*wsubi(i,k) ! boost ice SGS vertical velocity in CAM-CLUBB - ! to force nucleation in upper-level stratiform - ! clouds. Temporary fix until cloud-top radiative - ! cooling parameterization is added to CLUBB similar - ! to the one of appendix C of Bretherton and Park (2009). - endif -#endif - - wsub(i,k) = max(0.20_r8, wsub(i,k)) - end do - end do - call outfld( 'WSUB' , wsub, pcols, lchnk ) - call outfld( 'WSUBI' , wsubi, pcols, lchnk ) - - if (trim(eddy_scheme) == 'CLUBB_SGS') deallocate(tke) - - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - !Get humidity and saturation vapor pressures - - ! find wet bulk temperature and saturation value for provisional t and q without - ! condensation - - do k = top_lev, pver - - call qsat_water(t(:ncol,k), pmid(:ncol,k), & - es(:ncol), qs(:ncol), gam=gammas(:ncol)) - - do i = 1, ncol + wsub(i,k) = dum + end select - relhum(i,k) = qn(i,k)/qs(i) + if (eddy_scheme == 'CLUBB_SGS') then + wsubi(i,k) = max(0.2_r8, wsub(i,k)) + wsubi(i,k) = min(wsubi(i,k), 10.0_r8) + else + wsubi(i,k) = max(0.001_r8, wsub(i,k)) + if (.not. use_preexisting_ice) then + wsubi(i,k) = min(wsubi(i,k), 0.2_r8) + endif + endif - ! get cloud fraction, check for minimum - icldm(i,k) = max(icecldf(i,k), mincld) - lcldm(i,k) = max(liqcldf(i,k), mincld) + wsub(i,k) = max(0.20_r8, wsub(i,k)) - ! calculate nfice based on liquid and ice mmr (no rain and snow mmr available yet) - nfice(i,k) = 0._r8 - dumfice = qc(i,k) + qi(i,k) - if (dumfice > qsmall .and. qi(i,k) > qsmall) then - nfice(i,k) = qi(i,k)/dumfice - end if end do end do - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - !ICE Nucleation - - do k = top_lev, pver - do i = 1, ncol - - if (t(i,k).lt.tmelt - 5._r8) then - - - ! compute aerosol number for so4, soot, and dust with units #/cm^3 - so4_num = 0._r8 - soot_num = 0._r8 - dst1_num = 0._r8 - dst2_num = 0._r8 - dst3_num = 0._r8 - dst4_num = 0._r8 - dst_num = 0._r8 - - if (clim_modal_aero) then - !For modal aerosols, assume for the upper troposphere: - ! soot = accumulation mode - ! sulfate = aiken mode - ! dust = coarse mode - ! since modal has internal mixtures. - soot_num = num_accum(i,k)*rho(i,k)*1.0e-6_r8 - dmc = coarse_dust(i,k)*rho(i,k) - ssmc = coarse_nacl(i,k)*rho(i,k) - - if ( separate_dust ) then - ! 7-mode -- has separate dust and seasalt mode types and no need for weighting - wght = 1._r8 - else - ! 3-mode -- needs weighting for dust since dust and seasalt are combined in the "coarse" mode type - wght = dmc/(ssmc + dmc) - endif - - if (dmc > 0._r8) then - dst_num = wght * num_coarse(i,k)*rho(i,k)*1.0e-6_r8 - else - dst_num = 0.0_r8 - end if - - if (dgnum(i,k,mode_aitken_idx) > 0._r8) then - ! only allow so4 with D>0.1 um in ice nucleation - so4_num = num_aitken(i,k)*rho(i,k)*1.0e-6_r8 & - * (0.5_r8 - 0.5_r8*erf(log(0.1e-6_r8/dgnum(i,k,mode_aitken_idx))/ & - (2._r8**0.5_r8*log(sigmag_aitken)))) - else - so4_num = 0.0_r8 - end if - so4_num = max(0.0_r8, so4_num) - - else - - if (idxsul > 0) then - so4_num = naer2(i,k,idxsul)/25._r8 *1.0e-6_r8 - end if - if (idxbcphi > 0) then - soot_num = naer2(i,k,idxbcphi)/25._r8 *1.0e-6_r8 - end if - if (idxdst1 > 0) then - dst1_num = naer2(i,k,idxdst1)/25._r8 *1.0e-6_r8 - end if - if (idxdst2 > 0) then - dst2_num = naer2(i,k,idxdst2)/25._r8 *1.0e-6_r8 - end if - if (idxdst3 > 0) then - dst3_num = naer2(i,k,idxdst3)/25._r8 *1.0e-6_r8 - end if - if (idxdst4 > 0) then - dst4_num = naer2(i,k,idxdst4)/25._r8 *1.0e-6_r8 - end if - dst_num = dst1_num + dst2_num + dst3_num + dst4_num + call outfld('WSUB', wsub, pcols, lchnk) + call outfld('WSUBI', wsubi, pcols, lchnk) - end if + if (trim(eddy_scheme) == 'CLUBB_SGS') deallocate(tke) - ! *** Turn off soot nucleation *** - soot_num = 0.0_r8 + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + !ICE Nucleation - call nucleati( & - wsubi(i,k), t(i,k), relhum(i,k), icldm(i,k), qc(i,k), & - nfice(i,k), rho(i,k), so4_num, dst_num, soot_num, & - naai(i,k), nihf(i,k), niimm(i,k), nidep(i,k), nimey(i,k)) + call nucleate_ice_cam_calc(state, wsubi, pbuf) - naai_hom(i,k) = nihf(i,k) + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! get liquid cloud fraction, check for minimum - ! output activated ice (convert from #/kg -> #/m3) - nihf(i,k) = nihf(i,k) *rho(i,k) - niimm(i,k) = niimm(i,k)*rho(i,k) - nidep(i,k) = nidep(i,k)*rho(i,k) - nimey(i,k) = nimey(i,k)*rho(i,k) - end if + do k = top_lev, pver + do i = 1, ncol + lcldm(i,k) = max(ast(i,k), mincld) end do end do - call outfld('NIHF', nihf, pcols, lchnk) - call outfld('NIIMM', niimm, pcols, lchnk) - call outfld('NIDEP', nidep, pcols, lchnk) - call outfld('NIMEY', nimey, pcols, lchnk) - + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! Droplet Activation if (clim_modal_aero) then - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - !droplet activation for modal aerosol + ! for modal aerosol ! partition cloud fraction into liquid water part lcldn = 0._r8 @@ -747,14 +591,13 @@ subroutine microp_aero_run ( & call dropmixnuc( & state, ptend, deltatin, pbuf, wsub, & - lcldn, lcldo, nctend_mixnuc) + lcldn, lcldo, nctend_mixnuc, factnum) npccn(:ncol,:) = nctend_mixnuc(:ncol,:) else - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - !droplet activation for bulk aerosol + ! for bulk aerosol ! no tendencies returned from ndrop_bam_run, so just init ptend here call physics_ptend_init(ptend, state%psetcols, 'none') @@ -775,11 +618,7 @@ subroutine microp_aero_run ( & dum = 0._r8 end if - ! note: deltatin/2. accounts for sub step in microphysics - ! ***** This assumes two sub-steps in microphysics. It's dangerous to - ! ***** make that assumption here. Should move all coding related to - ! ***** microphysics substepping into the microphysics. - npccn(i,k) = (dum - nc(i,k)/lcldm(i,k))/(deltatin/2._r8)*lcldm(i,k) + npccn(i,k) = (dum*lcldm(i,k) - nc(i,k))/deltatin end do end do @@ -858,12 +697,21 @@ subroutine microp_aero_run ( & end if -end subroutine microp_aero_run + ! heterogeneous freezing + if (use_hetfrz_classnuc) then -!=============================================================================== + call hetfrz_classnuc_cam_calc(state, deltatin, factnum, pbuf) + end if -!=============================================================================== + if (clim_modal_aero) then + deallocate(factnum) + end if -end module microp_aero + end associate + +end subroutine microp_aero_run + +!========================================================================================= +end module microp_aero diff --git a/models/atm/cam/src/physics/cam/microp_driver.F90 b/models/atm/cam/src/physics/cam/microp_driver.F90 index 85ef68764f13..68a8865ed125 100644 --- a/models/atm/cam/src/physics/cam/microp_driver.F90 +++ b/models/atm/cam/src/physics/cam/microp_driver.F90 @@ -6,20 +6,19 @@ module microp_driver ! !------------------------------------------------------------------------------------------------------- -use shr_kind_mod, only: r8 => shr_kind_r8 -use ppgrid, only: pver -use physics_types, only: physics_state, physics_ptend, physics_tend, & - physics_ptend_copy, physics_ptend_sum -use physics_buffer,only: pbuf_get_index, pbuf_get_field, physics_buffer_desc -use phys_control, only: phys_getopts - -use cldwat2m_macro,only: ini_macro -use micro_mg_cam, only: micro_mg_cam_readnl, micro_mg_cam_register, & - micro_mg_cam_implements_cnst, micro_mg_cam_init_cnst, & - micro_mg_cam_init, micro_mg_cam_tend -use cam_logfile, only: iulog -use cam_abortutils, only: endrun -use perf_mod, only: t_startf, t_stopf +use shr_kind_mod, only: r8 => shr_kind_r8 +use ppgrid, only: pver +use physics_types, only: physics_state, physics_ptend, physics_tend, & + physics_ptend_copy, physics_ptend_sum +use physics_buffer, only: pbuf_get_index, pbuf_get_field, physics_buffer_desc +use phys_control, only: phys_getopts + +use micro_mg_cam, only: micro_mg_cam_readnl, micro_mg_cam_register, & + micro_mg_cam_implements_cnst, micro_mg_cam_init_cnst, & + micro_mg_cam_init, micro_mg_cam_tend +use cam_logfile, only: iulog +use cam_abortutils, only: endrun +use perf_mod, only: t_startf, t_stopf implicit none private @@ -139,8 +138,6 @@ subroutine microp_driver_init(pbuf2d) ! Initialize the microphysics parameterizations !----------------------------------------------------------------------- - call ini_macro() - select case (microp_scheme) case ('MG') call micro_mg_cam_init(pbuf2d) diff --git a/models/atm/cam/src/physics/cam/ndrop.F90 b/models/atm/cam/src/physics/cam/ndrop.F90 index 4e2f12f3086e..a30c97685856 100644 --- a/models/atm/cam/src/physics/cam/ndrop.F90 +++ b/models/atm/cam/src/physics/cam/ndrop.F90 @@ -26,14 +26,14 @@ module ndrop rad_cnst_get_aer_props, rad_cnst_get_mode_props, & rad_cnst_get_mam_mmr_idx, rad_cnst_get_mode_num_idx use cam_history, only: addfld, add_default, phys_decomp, fieldname_len, outfld -use cam_abortutils, only: endrun +use cam_abortutils, only: endrun use cam_logfile, only: iulog implicit none private save -public ndrop_init, dropmixnuc +public ndrop_init, dropmixnuc, activate_modal real(r8), allocatable :: alogsig(:) ! natl log of geometric standard dev of aerosol real(r8), allocatable :: exp45logsig(:) @@ -289,7 +289,7 @@ end subroutine ndrop_init subroutine dropmixnuc( & state, ptend, dtmicro, pbuf, wsub, & - cldn, cldo, tendnd) + cldn, cldo, tendnd, factnum) ! vertical diffusion and nucleation of cloud droplets ! assume cloud presence controlled by cloud fraction @@ -309,7 +309,7 @@ subroutine dropmixnuc( & ! output arguments real(r8), intent(out) :: tendnd(pcols,pver) ! change in droplet number concentration (#/kg/s) - + real(r8), intent(out) :: factnum(:,:,:) ! activation fraction for aerosol number !--------------------Local storage------------------------------------- integer :: lchnk ! chunk identifier @@ -479,7 +479,8 @@ subroutine dropmixnuc( & end do end do - wtke = 0._r8 + factnum = 0._r8 + wtke = 0._r8 if (prog_modal_aero) then ! aerosol tendencies @@ -630,6 +631,8 @@ subroutine dropmixnuc( & vaerosol, hygro, fn, fm, fluxn, & fluxm,flux_fullact(k)) + factnum(i,k,:) = fn + dumc = (cldn_tmp - cldo_tmp) do m = 1, ntot_amode mm = mam_idx(m,0) @@ -714,6 +717,8 @@ subroutine dropmixnuc( & vaerosol, hygro, fn, fm, fluxn, & fluxm, flux_fullact(k)) + factnum(i,k,:) = fn + if (k < pver) then dumc = cldn(i,k) - cldn(i,kp1) else @@ -1157,7 +1162,7 @@ end subroutine explmix subroutine activate_modal(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & na, nmode, volume, hygro, & - fn, fm, fluxn, fluxm, flux_fullact ) + fn, fm, fluxn, fluxm, flux_fullact, smax_prescribed) ! calculates number, surface, and mass fraction of aerosols activated as CCN ! calculates flux of cloud droplets, surface area, and aerosol mass into cloud @@ -1172,29 +1177,32 @@ subroutine activate_modal(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & ! input - real(r8) :: wbar ! grid cell mean vertical velocity (m/s) - real(r8) :: sigw ! subgrid standard deviation of vertical vel (m/s) - real(r8) :: wdiab ! diabatic vertical velocity (0 if adiabatic) - real(r8) :: wminf ! minimum updraft velocity for integration (m/s) - real(r8) :: wmaxf ! maximum updraft velocity for integration (m/s) - real(r8) :: tair ! air temperature (K) - real(r8) :: rhoair ! air density (kg/m3) - real(r8) :: na(:) ! aerosol number concentration (/m3) - integer :: nmode ! number of aerosol modes - real(r8) :: volume(:) ! aerosol volume concentration (m3/m3) - real(r8) :: hygro(:) ! hygroscopicity of aerosol mode + real(r8), intent(in) :: wbar ! grid cell mean vertical velocity (m/s) + real(r8), intent(in) :: sigw ! subgrid standard deviation of vertical vel (m/s) + real(r8), intent(in) :: wdiab ! diabatic vertical velocity (0 if adiabatic) + real(r8), intent(in) :: wminf ! minimum updraft velocity for integration (m/s) + real(r8), intent(in) :: wmaxf ! maximum updraft velocity for integration (m/s) + real(r8), intent(in) :: tair ! air temperature (K) + real(r8), intent(in) :: rhoair ! air density (kg/m3) + real(r8), intent(in) :: na(:) ! aerosol number concentration (/m3) + integer, intent(in) :: nmode ! number of aerosol modes + real(r8), intent(in) :: volume(:) ! aerosol volume concentration (m3/m3) + real(r8), intent(in) :: hygro(:) ! hygroscopicity of aerosol mode ! output - real(r8) :: fn(:) ! number fraction of aerosols activated - real(r8) :: fm(:) ! mass fraction of aerosols activated - real(r8) :: fluxn(:) ! flux of activated aerosol number fraction into cloud (cm/s) - real(r8) :: fluxm(:) ! flux of activated aerosol mass fraction into cloud (cm/s) - real(r8) :: flux_fullact ! flux of activated aerosol fraction assuming 100% activation (cm/s) + real(r8), intent(out) :: fn(:) ! number fraction of aerosols activated + real(r8), intent(out) :: fm(:) ! mass fraction of aerosols activated + real(r8), intent(out) :: fluxn(:) ! flux of activated aerosol number fraction into cloud (cm/s) + real(r8), intent(out) :: fluxm(:) ! flux of activated aerosol mass fraction into cloud (cm/s) + real(r8), intent(out) :: flux_fullact ! flux of activated aerosol fraction assuming 100% activation (cm/s) ! rce-comment ! used for consistency check -- this should match (ekd(k)*zs(k)) ! also, fluxm/flux_fullact gives fraction of aerosol mass flux ! that is activated + + ! optional + real(r8), optional, intent(in) :: smax_prescribed ! prescribed max. supersaturation for secondary activation ! local @@ -1265,6 +1273,10 @@ subroutine activate_modal(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & if(sigw.le.1.e-5_r8.and.wbar.le.0._r8)return + if ( present( smax_prescribed ) ) then + if (smax_prescribed <= 0.0_r8) return + end if + pres=rair*rhoair*tair diff0=0.211e-4_r8*(p0/pres)*(tair/t0)**1.94_r8 conduct0=(5.69_r8+0.017_r8*(tair-t0))*4.186e2_r8*1.e-5_r8 ! convert to J/m/s/deg @@ -1354,7 +1366,11 @@ subroutine activate_modal(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & zeta(m)=twothird*sqrtalw*aten/sqrtg(m) enddo - call maxsat(zeta,eta,nmode,smc,smax) + if ( present( smax_prescribed ) ) then + smax = smax_prescribed + else + call maxsat(zeta,eta,nmode,smc,smax) + endif ! write(iulog,*)'w,smax=',w,smax lnsmax=log(smax) @@ -1508,7 +1524,11 @@ subroutine activate_modal(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & zeta(m)=twothird*sqrtalw*aten/sqrtg(m) enddo - call maxsat(zeta,eta,nmode,smc,smax) + if ( present( smax_prescribed ) ) then + smax = smax_prescribed + else + call maxsat(zeta,eta,nmode,smc,smax) + endif lnsmax=log(smax) xmincoeff=alogaten-twothird*(lnsmax-alog2)-alog3 @@ -1542,11 +1562,11 @@ subroutine maxsat(zeta,eta,nmode,smc,smax) ! Abdul-Razzak and Ghan, A parameterization of aerosol activation. ! 2. Multiple aerosol types. J. Geophys. Res., 105, 6837-6844. - integer :: nmode ! number of modes - real(r8) :: smc(nmode) ! critical supersaturation for number mode radius - real(r8) :: zeta(nmode) - real(r8) :: eta(nmode) - real(r8) :: smax ! maximum supersaturation + integer, intent(in) :: nmode ! number of modes + real(r8), intent(in) :: smc(nmode) ! critical supersaturation for number mode radius + real(r8), intent(in) :: zeta(nmode) + real(r8), intent(in) :: eta(nmode) + real(r8), intent(out) :: smax ! maximum supersaturation integer :: m ! mode index real(r8) :: sum, g1, g2, g1sqrt, g2sqrt @@ -1570,7 +1590,9 @@ subroutine maxsat(zeta,eta,nmode,smc,smax) g1=zeta(m)/eta(m) g1sqrt=sqrt(g1) g1=g1sqrt*g1 - g1=g1sqrt*g1 +#if ! defined(CLUBB_BFB_S1) && ! defined(CLUBB_BFB_ALL) + g1=g1sqrt*g1 !Removed as a bugfix. Restored here if to be B4B with original model +#endif g2=smc(m)/sqrt(eta(m)+3._r8*zeta(m)) g2sqrt=sqrt(g2) g2=g2sqrt*g2 diff --git a/models/atm/cam/src/physics/cam/nucleate_ice.F90 b/models/atm/cam/src/physics/cam/nucleate_ice.F90 index 1403d1e2f218..85a0b3bf0955 100644 --- a/models/atm/cam/src/physics/cam/nucleate_ice.F90 +++ b/models/atm/cam/src/physics/cam/nucleate_ice.F90 @@ -1,49 +1,107 @@ module nucleate_ice -!--------------------------------------------------------------------------------- +!------------------------------------------------------------------------------- ! Purpose: -! Ice nucleation code. +! A parameterization of ice nucleation. ! -!--------------------------------------------------------------------------------- +! *** This module is intended to be a "portable" code layer. Ideally it should +! *** not contain any use association of modules that belong to the model framework. +! +! +! Method: +! The current method is based on Liu & Penner (2005) & Liu et al. (2007) +! It related the ice nucleation with the aerosol number, temperature and the +! updraft velocity. It includes homogeneous freezing of sulfate & immersion +! freezing on mineral dust (soot disabled) in cirrus clouds, and +! Meyers et al. (1992) deposition nucleation in mixed-phase clouds +! +! The effect of preexisting ice crystals on ice nucleation in cirrus clouds is included, +! and also consider the sub-grid variability of temperature in cirrus clouds, +! following X. Shi et al. ACP (2014). +! +! Ice nucleation in mixed-phase clouds now uses classical nucleation theory (CNT), +! follows Y. Wang et al. ACP (2014), Hoose et al. (2010). +! +! Authors: +! Xiaohong Liu, 01/2005, modifications by A. Gettelman 2009-2010 +! Xiangjun Shi & Xiaohong Liu, 01/2014. +! +! With help from C. C. Chen and B. Eaton (2014) +!------------------------------------------------------------------------------- -use shr_kind_mod, only: r8=>shr_kind_r8 use wv_saturation, only: svp_water, svp_ice -use cam_logfile, only: iulog implicit none private save -public :: nucleati +integer, parameter :: r8 = selected_real_kind(12) + +public :: nucleati_init, nucleati + +logical :: use_preexisting_ice +logical :: use_hetfrz_classnuc +integer :: iulog +real(r8) :: pi +real(r8) :: mincld + +! Subgrid scale factor on relative humidity (dimensionless) +real(r8) :: subgrid + +real(r8), parameter :: Shet = 1.3_r8 ! het freezing threshold +real(r8), parameter :: rhoice = 0.5e3_r8 ! kg/m3, Wpice is not sensitive to rhoice +real(r8), parameter :: minweff= 0.001_r8 ! m/s +real(r8), parameter :: gamma1=1.0_r8 +real(r8), parameter :: gamma2=1.0_r8 +real(r8), parameter :: gamma3=2.0_r8 +real(r8), parameter :: gamma4=6.0_r8 + +real(r8) :: ci !=============================================================================== contains !=============================================================================== +subroutine nucleati_init( & + use_preexisting_ice_in, use_hetfrz_classnuc_in, iulog_in, pi_in, & + mincld_in, subgrid_in) + + logical, intent(in) :: use_preexisting_ice_in + logical, intent(in) :: use_hetfrz_classnuc_in + integer, intent(in) :: iulog_in + real(r8), intent(in) :: pi_in + real(r8), intent(in) :: mincld_in + real(r8), intent(in) :: subgrid_in + + use_preexisting_ice = use_preexisting_ice_in + use_hetfrz_classnuc = use_hetfrz_classnuc_in + iulog = iulog_in + pi = pi_in + mincld = mincld_in + subgrid = subgrid_in + + ci = rhoice*pi/6._r8 + +end subroutine nucleati_init + +!=============================================================================== + subroutine nucleati( & - wbar, tair, relhum, cldn, qc, & - nfice, rhoair, so4_num, dst_num, soot_num, & - nuci, onihf, oniimm, onidep, onimey) - - !--------------------------------------------------------------- - ! Purpose: - ! The parameterization of ice nucleation. - ! - ! Method: The current method is based on Liu & Penner (2005) - ! It related the ice nucleation with the aerosol number, temperature and the - ! updraft velocity. It includes homogeneous freezing of sulfate, immersion - ! freezing of soot, and Meyers et al. (1992) deposition nucleation - ! - ! Authors: Xiaohong Liu, 01/2005, modifications by A. Gettelman 2009-2010 - !---------------------------------------------------------------- + wbar, tair, pmid, relhum, cldn, & + qc, qi, ni_in, rhoair, & + so4_num, dst_num, soot_num, & + nuci, onihf, oniimm, onidep, onimey, & + wpice, weff, fhom) ! Input Arguments real(r8), intent(in) :: wbar ! grid cell mean vertical velocity (m/s) real(r8), intent(in) :: tair ! temperature (K) + real(r8), intent(in) :: pmid ! pressure at layer midpoints (pa) real(r8), intent(in) :: relhum ! relative humidity with respective to liquid real(r8), intent(in) :: cldn ! new value of cloud fraction (fraction) real(r8), intent(in) :: qc ! liquid water mixing ratio (kg/kg) - real(r8), intent(in) :: nfice ! ice mass fraction + real(r8), intent(in) :: qi ! grid-mean preexisting cloud ice mass mixing ratio (kg/kg) + real(r8), intent(in) :: ni_in ! grid-mean preexisting cloud ice number conc (#/kg) real(r8), intent(in) :: rhoair ! air density (kg/m3) real(r8), intent(in) :: so4_num ! so4 aerosol number (#/cm^3) real(r8), intent(in) :: dst_num ! total dust aerosol number (#/cm^3) @@ -55,6 +113,9 @@ subroutine nucleati( & real(r8), intent(out) :: oniimm ! nucleated number from immersion freezing real(r8), intent(out) :: onidep ! nucleated number from deposition nucleation real(r8), intent(out) :: onimey ! nucleated number from deposition nucleation (meyers: mixed phase) + real(r8), intent(out) :: wpice ! diagnosed Vertical velocity Reduction caused by preexisting ice (m/s), at Shom + real(r8), intent(out) :: weff ! effective Vertical velocity for ice nucleation (m/s); weff=wbar-wpice + real(r8), intent(out) :: fhom ! how much fraction of cloud can reach Shom ! Local workspace real(r8) :: nihf ! nucleated number from homogeneous freezing of so4 @@ -62,11 +123,55 @@ subroutine nucleati( & real(r8) :: nidep ! nucleated number from deposition nucleation real(r8) :: nimey ! nucleated number from deposition nucleation (meyers) real(r8) :: n1, ni ! nucleated number - real(r8) :: tc, A, B, C, regm, RHw ! work variable + real(r8) :: tc, A, B, regm ! work variable real(r8) :: esl, esi, deles ! work variable - real(r8) :: subgrid + real(r8) :: wbar1, wbar2 + + ! used in SUBROUTINE Vpreice + real(r8) :: Ni_preice ! cloud ice number conc (1/m3) + real(r8) :: lami,Ri_preice ! mean cloud ice radius (m) + real(r8) :: Shom ! initial ice saturation ratio; if <1, use hom threshold Si + real(r8) :: detaT,RHimean ! temperature standard deviation, mean cloudy RHi + real(r8) :: wpicehet ! diagnosed Vertical velocity Reduction caused by preexisting ice (m/s), at shet + + real(r8) :: weffhet ! effective Vertical velocity for ice nucleation (m/s) weff=wbar-wpicehet !------------------------------------------------------------------------------- + ! temp variables that depend on use_preexisting_ice + wbar1 = wbar + wbar2 = wbar + + if (use_preexisting_ice) then + + Ni_preice = ni_in*rhoair ! (convert from #/kg -> #/m3) + Ni_preice = Ni_preice / max(mincld,cldn) ! in-cloud ice number density + + if (Ni_preice > 10.0_r8) then ! > 0.01/L = 10/m3 + Shom = -1.5_r8 ! if Shom<1 , Shom will be recalculated in SUBROUTINE Vpreice, according to Ren & McKenzie, 2005 + lami = (gamma4*ci*ni_in/qi)**(1._r8/3._r8) + Ri_preice = 0.5_r8/lami ! radius + Ri_preice = max(Ri_preice, 1e-8_r8) ! >0.01micron + call Vpreice(pmid, tair, Ri_preice, Ni_preice, Shom, wpice) + call Vpreice(pmid, tair, Ri_preice, Ni_preice, Shet, wpicehet) + else + wpice = 0.0_r8 + wpicehet = 0.0_r8 + endif + + weff = max(wbar-wpice, minweff) + wpice = min(wpice, wbar) + weffhet = max(wbar-wpicehet,minweff) + wpicehet = min(wpicehet, wbar) + + wbar1 = weff + wbar2 = weffhet + + detaT = wbar/0.23_r8 + RHimean = 1.0_r8 + call frachom(tair, RHimean, detaT, fhom) + + end if + ni = 0._r8 tc = tair - 273.15_r8 @@ -74,65 +179,136 @@ subroutine nucleati( & niimm = 0._r8 nidep = 0._r8 nihf = 0._r8 + deles = 0._r8 + esi = 0._r8 - if(so4_num.ge.1.0e-10_r8 .and. (soot_num+dst_num).ge.1.0e-10_r8 .and. cldn.gt.0._r8) then + if(so4_num >= 1.0e-10_r8 .and. (soot_num+dst_num) >= 1.0e-10_r8 .and. cldn > 0._r8) then - !----------------------------- - ! RHw parameterization for heterogeneous immersion nucleation - A = 0.0073_r8 - B = 1.477_r8 - C = 131.74_r8 - RHw=(A*tc*tc+B*tc+C)*0.01_r8 ! RHi ~ 120-130% +#ifdef USE_XLIU_MOD +!++ Mod from Xiaohong is the following two line conditional. +! It changes answers so needs climate validation. + if ((relhum*svp_water(tair)/svp_ice(tair)*subgrid).ge.1.2_r8) then + if ( ((tc.le.0.0_r8).and.(tc.ge.-37.0_r8).and.(qc.lt.1.e-12_r8)).or.(tc.le.-37.0_r8)) then +#else + if((tc.le.-35.0_r8) .and. ((relhum*svp_water(tair)/svp_ice(tair)*subgrid).ge.1.2_r8)) then ! use higher RHi threshold +#endif - subgrid = 1.2_r8 + A = -1.4938_r8 * log(soot_num+dst_num) + 12.884_r8 + B = -10.41_r8 * log(soot_num+dst_num) - 67.69_r8 + regm = A * log(wbar1) + B - if((tc.le.-35.0_r8) .and. ((relhum*svp_water(tair)/svp_ice(tair)*subgrid).ge.1.2_r8)) then ! use higher RHi threshold + ! heterogeneous nucleation only + if (tc .gt. regm) then - A = -1.4938_r8 * log(soot_num+dst_num) + 12.884_r8 - B = -10.41_r8 * log(soot_num+dst_num) - 67.69_r8 - regm = A * log(wbar) + B + if(tc.lt.-40._r8 .and. wbar1.gt.1._r8) then ! exclude T<-40 & W>1m/s from hetero. nucleation - if(tc.gt.regm) then ! heterogeneous nucleation only - if(tc.lt.-40._r8 .and. wbar.gt.1._r8) then ! exclude T<-40 & W>1m/s from hetero. nucleation - call hf(tc,wbar,relhum,subgrid,so4_num,nihf) - niimm=0._r8 - nidep=0._r8 - n1=nihf - else - call hetero(tc,wbar,soot_num+dst_num,niimm,nidep) - nihf=0._r8 - n1=niimm+nidep - endif - elseif (tc.lt.regm-5._r8) then ! homogeneous nucleation only - call hf(tc,wbar,relhum,subgrid,so4_num,nihf) - niimm=0._r8 - nidep=0._r8 - n1=nihf - else ! transition between homogeneous and heterogeneous: interpolate in-between - if(tc.lt.-40._r8 .and. wbar.gt.1._r8) then ! exclude T<-40 & W>1m/s from hetero. nucleation - call hf(tc,wbar,relhum,subgrid,so4_num,nihf) + call hf(tc,wbar1,relhum,so4_num,nihf) + niimm=0._r8 + nidep=0._r8 + + if (use_preexisting_ice) then + if (nihf.gt.1e-3_r8) then ! hom occur, add preexisting ice + niimm=min(dst_num,Ni_preice*1e-6_r8) ! assuming dst_num freeze firstly + nihf=nihf + Ni_preice*1e-6_r8 - niimm + endif + nihf=nihf*fhom + n1=nihf+niimm + else + n1=nihf + end if + + else + + call hetero(tc,wbar2,soot_num+dst_num,niimm,nidep) + + if (use_preexisting_ice) then + if (niimm .gt. 1e-6_r8) then ! het freezing occur, add preexisting ice + niimm = niimm + Ni_preice*1e-6_r8 + niimm = min(dst_num, niimm) ! niimm < dst_num + end if + end if + nihf=0._r8 + n1=niimm+nidep + + endif + + ! homogeneous nucleation only + else if (tc.lt.regm-5._r8) then + + call hf(tc,wbar1,relhum,so4_num,nihf) niimm=0._r8 nidep=0._r8 - n1=nihf + + if (use_preexisting_ice) then + if (nihf.gt.1e-3_r8) then ! hom occur, add preexisting ice + niimm=min(dst_num,Ni_preice*1e-6_r8) ! assuming dst_num freeze firstly + nihf=nihf + Ni_preice*1e-6_r8 - niimm + endif + nihf=nihf*fhom + n1=nihf+niimm + else + n1=nihf + end if + + ! transition between homogeneous and heterogeneous: interpolate in-between else - call hf(regm-5._r8,wbar,relhum,subgrid,so4_num,nihf) - call hetero(regm,wbar,soot_num+dst_num,niimm,nidep) + if (tc.lt.-40._r8 .and. wbar1.gt.1._r8) then ! exclude T<-40 & W>1m/s from hetero. nucleation - if(nihf.le.(niimm+nidep)) then - n1=nihf - else - n1=(niimm+nidep)*((niimm+nidep)/nihf)**((tc-regm)/5._r8) - endif - endif - endif + call hf(tc, wbar1, relhum, so4_num, nihf) + niimm = 0._r8 + nidep = 0._r8 - ni=n1 + if (use_preexisting_ice) then + if (nihf .gt. 1e-3_r8) then ! hom occur, add preexisting ice + niimm = min(dst_num, Ni_preice*1e-6_r8) ! assuming dst_num freeze firstly + nihf = nihf + Ni_preice*1e-6_r8 - niimm + endif + nihf = nihf*fhom + n1 = nihf + niimm + else + n1 = nihf + end if - endif - endif + else - ! deposition/condensation nucleation in mixed clouds (-401 + ENDIF + + R = R_in*1e2_r8 ! m => cm + C = C_in*1e-6_r8 ! m-3 => cm-3 + T_1 = 1.0_r8/ T + PICE = WVP1c * EXP(-(WVP2c*T_1)) + ALP4 = 0.25_r8 * ALPHAc + FLUX = ALP4 * SQRT(FVTHc*T) + CISAT = THOUBKc * PICE * T_1 + A1 = ( FA1c * T_1 - FA2c ) * T_1 + A2 = 1.0_r8/ CISAT + A3 = FA3c * T_1 / P + B1 = FLUX * SVOLc * CISAT * ( S-1.0_r8 ) + B2 = FLUX * FDc * P * T_1**1.94_r8 + DLOSS = FPIVOLc * C * B1 * R**2 / ( 1.0_r8+ B2 * R ) + VICE = ( A2 + A3 * S ) * DLOSS / ( A1 * S ) ! 2006,(19) + V_out = VICE*1e-2_r8 ! cm/s => m/s + +END SUBROUTINE Vpreice + +subroutine frachom(Tmean,RHimean,detaT,fhom) + ! How much fraction of cirrus might reach Shom + ! base on "A cirrus cloud scheme for general circulation models", + ! B. Karcher and U. Burkhardt 2008 + + real(r8), intent(in) :: Tmean, RHimean, detaT + real(r8), intent(out) :: fhom + + real(r8), parameter :: seta = 6132.9_r8 ! K + integer, parameter :: Nbin=200 ! (Tmean - 3*detaT, Tmean + 3*detaT) + + real(r8) :: PDF_T(Nbin) ! temperature PDF; ! PDF_T=0 outside (Tmean-3*detaT, Tmean+3*detaT) + real(r8) :: Sbin(Nbin) ! the fluctuations of Si that are driven by the T variations + real(r8) :: Sihom, deta + integer :: i + + Sihom = 2.349_r8-Tmean/259.0_r8 ! homogeneous freezing threshold, according to Ren & McKenzie, 2005 + fhom = 0.0_r8 + + do i = Nbin, 1, -1 + + deta = (i - 0.5_r8 - Nbin/2)*6.0_r8/Nbin ! PDF_T=0 outside (Tmean-3*detaT, Tmean+3*detaT) + Sbin(i) = RHimean*exp(deta*detaT*seta/Tmean**2.0_r8) + PDF_T(i) = exp(-deta**2.0_r8/2.0_r8)*6.0_r8/(sqrt(2.0_r8*Pi)*Nbin) + + + if (Sbin(i).ge.Sihom) then + fhom = fhom + PDF_T(i) + else + exit + end if + end do + + fhom=fhom/0.997_r8 ! accounting for the finite limits (-3 , 3) + +end subroutine frachom + end module nucleate_ice diff --git a/models/atm/cam/src/physics/cam/nucleate_ice_cam.F90 b/models/atm/cam/src/physics/cam/nucleate_ice_cam.F90 new file mode 100644 index 000000000000..c456de01cf5e --- /dev/null +++ b/models/atm/cam/src/physics/cam/nucleate_ice_cam.F90 @@ -0,0 +1,641 @@ +module nucleate_ice_cam + +!--------------------------------------------------------------------------------- +! +! CAM Interfaces for nucleate_ice module. +! +! B. Eaton - Sept 2014 +!--------------------------------------------------------------------------------- + +use shr_kind_mod, only: r8=>shr_kind_r8 +use spmd_utils, only: masterproc +use ppgrid, only: pcols, pver +use physconst, only: pi, rair, tmelt +use constituents, only: cnst_get_ind +use physics_types, only: physics_state +use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field +use phys_control, only: use_hetfrz_classnuc +use rad_constituents, only: rad_cnst_get_info, rad_cnst_get_aer_mmr, rad_cnst_get_aer_props, & + rad_cnst_get_mode_num, rad_cnst_get_mode_props + +use physics_buffer, only: pbuf_add_field, dtype_r8, pbuf_old_tim_idx, & + pbuf_get_index, pbuf_get_field +use cam_history, only: addfld, phys_decomp, add_default, outfld + +use ref_pres, only: top_lev => trop_cloud_top_lev +use wv_saturation, only: qsat_water +use shr_spfn_mod, only: erf => shr_spfn_erf + +use cam_logfile, only: iulog +use cam_abortutils, only: endrun + +use nucleate_ice, only: nucleati_init, nucleati + + +implicit none +private +save + +public :: & + nucleate_ice_cam_readnl, & + nucleate_ice_cam_register, & + nucleate_ice_cam_init, & + nucleate_ice_cam_calc + + +! Namelist variables +logical, public, protected :: use_preexisting_ice = .false. +logical :: hist_preexisting_ice = .false. +real(r8) :: nucleate_ice_subgrid + +! Vars set via init method. +real(r8) :: mincld ! minimum allowed cloud fraction +real(r8) :: bulk_scale ! prescribed aerosol bulk sulfur scale factor + +! constituent indices +integer :: & + cldliq_idx = -1, & + cldice_idx = -1, & + numice_idx = -1 + +integer :: & + naai_idx, & + naai_hom_idx + +integer :: & + ast_idx = -1, & + dgnum_idx = -1 + +! Bulk aerosols +character(len=20), allocatable :: aername(:) +real(r8), allocatable :: num_to_mass_aer(:) + +integer :: naer_all ! number of aerosols affecting climate +integer :: idxsul = -1 ! index in aerosol list for sulfate +integer :: idxdst1 = -1 ! index in aerosol list for dust1 +integer :: idxdst2 = -1 ! index in aerosol list for dust2 +integer :: idxdst3 = -1 ! index in aerosol list for dust3 +integer :: idxdst4 = -1 ! index in aerosol list for dust4 +integer :: idxbcphi = -1 ! index in aerosol list for Soot (BCPHIL) + +! modal aerosols +logical :: clim_modal_aero + +integer :: nmodes = -1 +integer :: mode_accum_idx = -1 ! index of accumulation mode +integer :: mode_aitken_idx = -1 ! index of aitken mode +integer :: mode_coarse_idx = -1 ! index of coarse mode +integer :: mode_coarse_dst_idx = -1 ! index of coarse dust mode +integer :: mode_coarse_slt_idx = -1 ! index of coarse sea salt mode +integer :: coarse_dust_idx = -1 ! index of dust in coarse mode +integer :: coarse_nacl_idx = -1 ! index of nacl in coarse mode + +logical :: separate_dust = .false. +real(r8) :: sigmag_aitken + +!=============================================================================== +contains +!=============================================================================== + +subroutine nucleate_ice_cam_readnl(nlfile) + + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use mpishorthand + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: subname = 'nucleate_ice_cam_readnl' + + namelist /nucleate_ice_nl/ use_preexisting_ice, hist_preexisting_ice, & + nucleate_ice_subgrid + + !----------------------------------------------------------------------------- + + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'nucleate_ice_nl', status=ierr) + if (ierr == 0) then + read(unitn, nucleate_ice_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(subname // ':: ERROR reading namelist') + end if + end if + close(unitn) + call freeunit(unitn) + + end if + +#ifdef SPMD + ! Broadcast namelist variables + call mpibcast(use_preexisting_ice, 1, mpilog, 0, mpicom) + call mpibcast(hist_preexisting_ice, 1, mpilog, 0, mpicom) + call mpibcast(nucleate_ice_subgrid, 1, mpir8, 0, mpicom) +#endif + +end subroutine nucleate_ice_cam_readnl + +!================================================================================================ + +subroutine nucleate_ice_cam_register() + + call pbuf_add_field('NAAI', 'physpkg', dtype_r8, (/pcols,pver/), naai_idx) + call pbuf_add_field('NAAI_HOM', 'physpkg', dtype_r8, (/pcols,pver/), naai_hom_idx) + +end subroutine nucleate_ice_cam_register + +!================================================================================================ + +subroutine nucleate_ice_cam_init(mincld_in, bulk_scale_in) + + real(r8), intent(in) :: mincld_in + real(r8), intent(in) :: bulk_scale_in + + ! local variables + integer :: iaer + integer :: m, n, nspec + + character(len=32) :: str32 + character(len=*), parameter :: routine = 'nucleate_ice_cam_init' + !-------------------------------------------------------------------------------------------- + + mincld = mincld_in + bulk_scale = bulk_scale_in + + call cnst_get_ind('CLDLIQ', cldliq_idx) + call cnst_get_ind('CLDICE', cldice_idx) + call cnst_get_ind('NUMICE', numice_idx) + + call addfld('NIHF', '1/m3', pver, 'A', 'Activated Ice Number Concentation due to homogenous freezing', phys_decomp) + call addfld('NIDEP', '1/m3', pver, 'A', 'Activated Ice Number Concentation due to deposition nucleation',phys_decomp) + call addfld('NIIMM', '1/m3', pver, 'A', 'Activated Ice Number Concentation due to immersion freezing', phys_decomp) + call addfld('NIMEY', '1/m3', pver, 'A', 'Activated Ice Number Concentation due to meyers deposition', phys_decomp) + + if (use_preexisting_ice) then + call addfld('fhom ', 'fraction', pver, 'A', 'Fraction of cirrus where homogeneous freezing occur' ,phys_decomp) + call addfld ('WICE ', 'm/s ', pver, 'A','Vertical velocity Reduction caused by preexisting ice' ,phys_decomp) + call addfld ('WEFF ', 'm/s ', pver, 'A','Effective Vertical velocity for ice nucleation' ,phys_decomp) + call addfld ('INnso4 ','1/m3 ', pver, 'A','Number Concentation so4 used for ice_nucleation',phys_decomp) + call addfld ('INnbc ','1/m3 ', pver, 'A','Number Concentation bc used for ice_nucleation',phys_decomp) + call addfld ('INndust ','1/m3 ', pver, 'A','Number Concentation dustused for ice_nucleation',phys_decomp) + call addfld ('INhet ','1/m3 ', pver, 'A', & + 'contribution for in-cloud ice number density increase by het nucleation in ice cloud',phys_decomp) + call addfld ('INhom ','1/m3 ', pver, 'A', & + 'contribution for in-cloud ice number density increase by hom nucleation in ice cloud',phys_decomp) + call addfld ('INFrehom ','frequency',pver,'A','hom IN frequency ice cloud',phys_decomp) + call addfld ('INFreIN ','frequency',pver,'A','frequency of ice nucleation occur',phys_decomp) + + if (hist_preexisting_ice) then + call add_default ('WSUBI ', 1, ' ') ! addfld/outfld calls are in microp_aero + + call add_default ('fhom ', 1, ' ') + call add_default ('WICE ', 1, ' ') + call add_default ('WEFF ', 1, ' ') + call add_default ('INnso4 ', 1, ' ') + call add_default ('INnbc ', 1, ' ') + call add_default ('INndust ', 1, ' ') + call add_default ('INhet ', 1, ' ') + call add_default ('INhom ', 1, ' ') + call add_default ('INFrehom', 1, ' ') + call add_default ('INFreIN ', 1, ' ') + end if + end if + + ! clim_modal_aero determines whether modal aerosols are used in the climate calculation. + ! The modal aerosols can be either prognostic or prescribed. + call rad_cnst_get_info(0, nmodes=nmodes) + clim_modal_aero = (nmodes > 0) + + if (clim_modal_aero) then + + dgnum_idx = pbuf_get_index('DGNUM' ) + + ! Init indices for specific modes/species + + ! mode index for specified mode types + do m = 1, nmodes + call rad_cnst_get_info(0, m, mode_type=str32) + select case (trim(str32)) + case ('accum') + mode_accum_idx = m + case ('aitken') + mode_aitken_idx = m + case ('coarse') + mode_coarse_idx = m + case ('coarse_dust') + mode_coarse_dst_idx = m + case ('coarse_seasalt') + mode_coarse_slt_idx = m + end select + end do + + ! check if coarse dust is in separate mode + separate_dust = mode_coarse_dst_idx > 0 + + ! for 3-mode + if (mode_coarse_dst_idx < 0) mode_coarse_dst_idx = mode_coarse_idx + if (mode_coarse_slt_idx < 0) mode_coarse_slt_idx = mode_coarse_idx + + ! Check that required mode types were found + if (mode_accum_idx == -1 .or. mode_aitken_idx == -1 .or. & + mode_coarse_dst_idx == -1.or. mode_coarse_slt_idx == -1) then + write(iulog,*) routine//': ERROR required mode type not found - mode idx:', & + mode_accum_idx, mode_aitken_idx, mode_coarse_dst_idx, mode_coarse_slt_idx + call endrun(routine//': ERROR required mode type not found') + end if + + ! species indices for specified types + ! find indices for the dust and seasalt species in the coarse mode + call rad_cnst_get_info(0, mode_coarse_dst_idx, nspec=nspec) + do n = 1, nspec + call rad_cnst_get_info(0, mode_coarse_dst_idx, n, spec_type=str32) + select case (trim(str32)) + case ('dust') + coarse_dust_idx = n + end select + end do + call rad_cnst_get_info(0, mode_coarse_slt_idx, nspec=nspec) + do n = 1, nspec + call rad_cnst_get_info(0, mode_coarse_slt_idx, n, spec_type=str32) + select case (trim(str32)) + case ('seasalt') + coarse_nacl_idx = n + end select + end do + + ! Check that required mode specie types were found + if ( coarse_dust_idx == -1 .or. coarse_nacl_idx == -1) then + write(iulog,*) routine//': ERROR required mode-species type not found - indicies:', & + coarse_dust_idx, coarse_nacl_idx + call endrun(routine//': ERROR required mode-species type not found') + end if + + ! get specific mode properties + call rad_cnst_get_mode_props(0, mode_aitken_idx, sigmag=sigmag_aitken) + + else + + ! Props needed for BAM number concentration calcs. + + call rad_cnst_get_info(0, naero=naer_all) + allocate( & + aername(naer_all), & + num_to_mass_aer(naer_all) ) + + do iaer = 1, naer_all + call rad_cnst_get_aer_props(0, iaer, & + aername = aername(iaer), & + num_to_mass_aer = num_to_mass_aer(iaer) ) + + ! Look for sulfate, dust, and soot in this list (Bulk aerosol only) + if (trim(aername(iaer)) == 'SULFATE') idxsul = iaer + if (trim(aername(iaer)) == 'DUST1') idxdst1 = iaer + if (trim(aername(iaer)) == 'DUST2') idxdst2 = iaer + if (trim(aername(iaer)) == 'DUST3') idxdst3 = iaer + if (trim(aername(iaer)) == 'DUST4') idxdst4 = iaer + if (trim(aername(iaer)) == 'BCPHIL') idxbcphi = iaer + end do + end if + + + call nucleati_init(use_preexisting_ice, use_hetfrz_classnuc, iulog, pi, & + mincld, nucleate_ice_subgrid) + + ! get indices for fields in the physics buffer + ast_idx = pbuf_get_index('AST') + +end subroutine nucleate_ice_cam_init + +!================================================================================================ + +subroutine nucleate_ice_cam_calc( & + state, wsubi, pbuf) + + ! arguments + type(physics_state), target, intent(in) :: state + real(r8), intent(in) :: wsubi(:,:) + type(physics_buffer_desc), pointer :: pbuf(:) + + ! local workspace + + ! naai and naai_hom are the outputs shared with the microphysics + real(r8), pointer :: naai(:,:) ! number of activated aerosol for ice nucleation + real(r8), pointer :: naai_hom(:,:) ! number of activated aerosol for ice nucleation (homogeneous freezing only) + + integer :: lchnk, ncol + integer :: itim_old + integer :: i, k, m + + real(r8), pointer :: t(:,:) ! input temperature (K) + real(r8), pointer :: qn(:,:) ! input water vapor mixing ratio (kg/kg) + real(r8), pointer :: qc(:,:) ! cloud water mixing ratio (kg/kg) + real(r8), pointer :: qi(:,:) ! cloud ice mixing ratio (kg/kg) + real(r8), pointer :: ni(:,:) ! cloud ice number conc (1/kg) + real(r8), pointer :: pmid(:,:) ! pressure at layer midpoints (pa) + + real(r8), pointer :: num_accum(:,:) ! number m.r. of accumulation mode + real(r8), pointer :: num_aitken(:,:) ! number m.r. of aitken mode + real(r8), pointer :: num_coarse(:,:) ! number m.r. of coarse mode + real(r8), pointer :: coarse_dust(:,:) ! mass m.r. of coarse dust + real(r8), pointer :: coarse_nacl(:,:) ! mass m.r. of coarse nacl + real(r8), pointer :: aer_mmr(:,:) ! aerosol mass mixing ratio + real(r8), pointer :: dgnum(:,:,:) ! mode dry radius + + real(r8), pointer :: ast(:,:) + real(r8) :: icecldf(pcols,pver) ! ice cloud fraction + + real(r8) :: rho(pcols,pver) ! air density (kg m-3) + + real(r8), allocatable :: naer2(:,:,:) ! bulk aerosol number concentration (1/m3) + real(r8), allocatable :: maerosol(:,:,:) ! bulk aerosol mass conc (kg/m3) + + real(r8) :: qs(pcols) ! liquid-ice weighted sat mixing rat (kg/kg) + real(r8) :: es(pcols) ! liquid-ice weighted sat vapor press (pa) + real(r8) :: gammas(pcols) ! parameter for cond/evap of cloud water + + real(r8) :: relhum(pcols,pver) ! relative humidity + real(r8) :: icldm(pcols,pver) ! ice cloud fraction + + real(r8) :: so4_num ! so4 aerosol number (#/cm^3) + real(r8) :: soot_num ! soot (hydrophilic) aerosol number (#/cm^3) + real(r8) :: dst1_num,dst2_num,dst3_num,dst4_num ! dust aerosol number (#/cm^3) + real(r8) :: dst_num ! total dust aerosol number (#/cm^3) + real(r8) :: wght + real(r8) :: dmc + real(r8) :: ssmc + + ! For pre-existing ice + real(r8) :: fhom(pcols,pver) ! how much fraction of cloud can reach Shom + real(r8) :: wice(pcols,pver) ! diagnosed Vertical velocity Reduction caused by preexisting ice (m/s), at Shom + real(r8) :: weff(pcols,pver) ! effective Vertical velocity for ice nucleation (m/s); weff=wsubi-wice + real(r8) :: INnso4(pcols,pver) ! #/m3, so4 aerosol number used for ice nucleation + real(r8) :: INnbc(pcols,pver) ! #/m3, bc aerosol number used for ice nucleation + real(r8) :: INndust(pcols,pver) ! #/m3, dust aerosol number used for ice nucleation + real(r8) :: INhet(pcols,pver) ! #/m3, ice number from het freezing + real(r8) :: INhom(pcols,pver) ! #/m3, ice number from hom freezing + real(r8) :: INFrehom(pcols,pver) ! hom freezing occurence frequency. 1 occur, 0 not occur. + real(r8) :: INFreIN(pcols,pver) ! ice nucleation occerence frequency. 1 occur, 0 not occur. + + ! history output for ice nucleation + real(r8) :: nihf(pcols,pver) !output number conc of ice nuclei due to heterogenous freezing (1/m3) + real(r8) :: niimm(pcols,pver) !output number conc of ice nuclei due to immersion freezing (hetero nuc) (1/m3) + real(r8) :: nidep(pcols,pver) !output number conc of ice nuclei due to deoposion nucleation (hetero nuc) (1/m3) + real(r8) :: nimey(pcols,pver) !output number conc of ice nuclei due to meyers deposition (1/m3) + + + !------------------------------------------------------------------------------- + + lchnk = state%lchnk + ncol = state%ncol + t => state%t + qn => state%q(:,:,1) + qc => state%q(:,:,cldliq_idx) + qi => state%q(:,:,cldice_idx) + ni => state%q(:,:,numice_idx) + pmid => state%pmid + + do k = top_lev, pver + do i = 1, ncol + rho(i,k) = pmid(i,k)/(rair*t(i,k)) + end do + end do + + if (clim_modal_aero) then + ! mode number mixing ratios + call rad_cnst_get_mode_num(0, mode_accum_idx, 'a', state, pbuf, num_accum) + call rad_cnst_get_mode_num(0, mode_aitken_idx, 'a', state, pbuf, num_aitken) + call rad_cnst_get_mode_num(0, mode_coarse_dst_idx, 'a', state, pbuf, num_coarse) + + ! mode specie mass m.r. + call rad_cnst_get_aer_mmr(0, mode_coarse_dst_idx, coarse_dust_idx, 'a', state, pbuf, coarse_dust) + call rad_cnst_get_aer_mmr(0, mode_coarse_slt_idx, coarse_nacl_idx, 'a', state, pbuf, coarse_nacl) + + else + ! init number/mass arrays for bulk aerosols + allocate( & + naer2(pcols,pver,naer_all), & + maerosol(pcols,pver,naer_all)) + + do m = 1, naer_all + call rad_cnst_get_aer_mmr(0, m, state, pbuf, aer_mmr) + maerosol(:ncol,:,m) = aer_mmr(:ncol,:)*rho(:ncol,:) + + if (m .eq. idxsul) then + naer2(:ncol,:,m) = maerosol(:ncol,:,m)*num_to_mass_aer(m)*bulk_scale + else + naer2(:ncol,:,m) = maerosol(:ncol,:,m)*num_to_mass_aer(m) + end if + end do + end if + + itim_old = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, ast_idx, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + + icecldf(:ncol,:pver) = ast(:ncol,:pver) + + if (clim_modal_aero) then + call pbuf_get_field(pbuf, dgnum_idx, dgnum) + end if + + ! naai and naai_hom are the outputs from this parameterization + call pbuf_get_field(pbuf, naai_idx, naai) + call pbuf_get_field(pbuf, naai_hom_idx, naai_hom) + naai(1:ncol,1:pver) = 0._r8 + naai_hom(1:ncol,1:pver) = 0._r8 + + ! initialize history output fields for ice nucleation + nihf(1:ncol,1:pver) = 0._r8 + niimm(1:ncol,1:pver) = 0._r8 + nidep(1:ncol,1:pver) = 0._r8 + nimey(1:ncol,1:pver) = 0._r8 + + if (use_preexisting_ice) then + fhom(:,:) = 0.0_r8 + wice(:,:) = 0.0_r8 + weff(:,:) = 0.0_r8 + INnso4(:,:) = 0.0_r8 + INnbc(:,:) = 0.0_r8 + INndust(:,:) = 0.0_r8 + INhet(:,:) = 0.0_r8 + INhom(:,:) = 0.0_r8 + INFrehom(:,:) = 0.0_r8 + INFreIN(:,:) = 0.0_r8 + endif + + do k = top_lev, pver + + ! Get humidity and saturation vapor pressures + call qsat_water(t(:ncol,k), pmid(:ncol,k), & + es(:ncol), qs(:ncol), gam=gammas(:ncol)) + + do i = 1, ncol + + relhum(i,k) = qn(i,k)/qs(i) + + ! get cloud fraction, check for minimum + icldm(i,k) = max(icecldf(i,k), mincld) + + end do + end do + + + do k = top_lev, pver + do i = 1, ncol + + if (t(i,k) < tmelt - 5._r8) then + + ! compute aerosol number for so4, soot, and dust with units #/cm^3 + so4_num = 0._r8 + soot_num = 0._r8 + dst1_num = 0._r8 + dst2_num = 0._r8 + dst3_num = 0._r8 + dst4_num = 0._r8 + dst_num = 0._r8 + + if (clim_modal_aero) then + !For modal aerosols, assume for the upper troposphere: + ! soot = accumulation mode + ! sulfate = aiken mode + ! dust = coarse mode + ! since modal has internal mixtures. + soot_num = num_accum(i,k)*rho(i,k)*1.0e-6_r8 + dmc = coarse_dust(i,k)*rho(i,k) + ssmc = coarse_nacl(i,k)*rho(i,k) + + if (dmc > 0._r8) then + if ( separate_dust ) then + ! 7-mode -- has separate dust and seasalt mode types and + ! no need for weighting + wght = 1._r8 + else + ! 3-mode -- needs weighting for dust since dust and seasalt + ! are combined in the "coarse" mode type + wght = dmc/(ssmc + dmc) + endif + dst_num = wght * num_coarse(i,k)*rho(i,k)*1.0e-6_r8 + else + dst_num = 0.0_r8 + end if + + if (dgnum(i,k,mode_aitken_idx) > 0._r8) then + if (.not. use_preexisting_ice) then + ! only allow so4 with D>0.1 um in ice nucleation + so4_num = num_aitken(i,k)*rho(i,k)*1.0e-6_r8 & + * (0.5_r8 - 0.5_r8*erf(log(0.1e-6_r8/dgnum(i,k,mode_aitken_idx))/ & + (2._r8**0.5_r8*log(sigmag_aitken)))) + else + ! all so4 from aitken + so4_num = num_aitken(i,k)*rho(i,k)*1.0e-6_r8 + end if + else + so4_num = 0.0_r8 + end if + so4_num = max(0.0_r8, so4_num) + + else + + if (idxsul > 0) then + so4_num = naer2(i,k,idxsul)/25._r8 *1.0e-6_r8 + end if + if (idxbcphi > 0) then + soot_num = naer2(i,k,idxbcphi)/25._r8 *1.0e-6_r8 + end if + if (idxdst1 > 0) then + dst1_num = naer2(i,k,idxdst1)/25._r8 *1.0e-6_r8 + end if + if (idxdst2 > 0) then + dst2_num = naer2(i,k,idxdst2)/25._r8 *1.0e-6_r8 + end if + if (idxdst3 > 0) then + dst3_num = naer2(i,k,idxdst3)/25._r8 *1.0e-6_r8 + end if + if (idxdst4 > 0) then + dst4_num = naer2(i,k,idxdst4)/25._r8 *1.0e-6_r8 + end if + dst_num = dst1_num + dst2_num + dst3_num + dst4_num + + end if + + ! *** Turn off soot nucleation *** + soot_num = 0.0_r8 + + call nucleati( & + wsubi(i,k), t(i,k), pmid(i,k), relhum(i,k), icldm(i,k), & + qc(i,k), qi(i,k), ni(i,k), rho(i,k), & + so4_num, dst_num, soot_num, & + naai(i,k), nihf(i,k), niimm(i,k), nidep(i,k), nimey(i,k), & + wice(i,k), weff(i,k), fhom(i,k)) + + naai_hom(i,k) = nihf(i,k) + + ! output activated ice (convert from #/kg -> #/m3) + nihf(i,k) = nihf(i,k) *rho(i,k) + niimm(i,k) = niimm(i,k)*rho(i,k) + nidep(i,k) = nidep(i,k)*rho(i,k) + nimey(i,k) = nimey(i,k)*rho(i,k) + + if (use_preexisting_ice) then + INnso4(i,k) =so4_num*1e6_r8 ! (convert from #/cm3 -> #/m3) + INnbc(i,k) =soot_num*1e6_r8 + INndust(i,k)=dst_num*1e6_r8 + INFreIN(i,k)=1.0_r8 ! 1,ice nucleation occur + INhet(i,k) = niimm(i,k) + nidep(i,k) ! #/m3, nimey not in cirrus + INhom(i,k) = nihf(i,k) ! #/m3 + if (INhom(i,k).gt.1e3_r8) then ! > 1/L + INFrehom(i,k)=1.0_r8 ! 1, hom freezing occur + endif + + ! exclude no ice nucleaton + if ((INFrehom(i,k) < 0.5_r8) .and. (INhet(i,k) < 1.0_r8)) then + INnso4(i,k) =0.0_r8 + INnbc(i,k) =0.0_r8 + INndust(i,k)=0.0_r8 + INFreIN(i,k)=0.0_r8 + INhet(i,k) = 0.0_r8 + INhom(i,k) = 0.0_r8 + INFrehom(i,k)=0.0_r8 + wice(i,k) = 0.0_r8 + weff(i,k) = 0.0_r8 + fhom(i,k) = 0.0_r8 + endif + end if + + end if + end do + end do + + if (.not. clim_modal_aero) then + + deallocate( & + naer2, & + maerosol) + + end if + + call outfld('NIHF', nihf, pcols, lchnk) + call outfld('NIIMM', niimm, pcols, lchnk) + call outfld('NIDEP', nidep, pcols, lchnk) + call outfld('NIMEY', nimey, pcols, lchnk) + + if (use_preexisting_ice) then + call outfld( 'fhom' , fhom, pcols, lchnk) + call outfld( 'WICE' , wice, pcols, lchnk) + call outfld( 'WEFF' , weff, pcols, lchnk) + call outfld('INnso4 ',INnso4 , pcols,lchnk) + call outfld('INnbc ',INnbc , pcols,lchnk) + call outfld('INndust ',INndust, pcols,lchnk) + call outfld('INhet ',INhet , pcols,lchnk) + call outfld('INhom ',INhom , pcols,lchnk) + call outfld('INFrehom',INFrehom,pcols,lchnk) + call outfld('INFreIN ',INFreIN, pcols,lchnk) + end if + +end subroutine nucleate_ice_cam_calc + +!================================================================================================ + +end module nucleate_ice_cam diff --git a/models/atm/cam/src/physics/cam/nudging.F90 b/models/atm/cam/src/physics/cam/nudging.F90 new file mode 100644 index 000000000000..96a1937c88b0 --- /dev/null +++ b/models/atm/cam/src/physics/cam/nudging.F90 @@ -0,0 +1,1971 @@ +module nudging +!===================================================================== +! +! Purpose: Implement Nudging of the model state of U,V,T,Q, and/or PS +! toward specified values from analyses. +! +! Author: Patrick Callaghan +! +! Description: +! This module assumes that the user has {U,V,T,Q,PS} analyses which +! have been preprocessed onto the current model grid and are stored +! in individual files which are indexed with respect to year, month, +! day, and second of the day. When the model is inbetween the given +! begining and ending times, forcing is added to nudge the model toward +! the appropriate analyses values. After the model passes the ending +! analyses time, the forcing discontinues. +! +! Revisions: +! 01/14/13 - Modified to manage 'GAPS' in analyses data. For now the +! approach is to coast through the gaps... If a given +! analyses file is missing, nudging is turned off for +! that interval of time. Once an analyses file is found, +! the Nudging is switched back on. +! 02/22/13 - Modified to add functionality for FV and EUL dynamical +! cores. +! 03/03/13 - For ne120 runs, the automatic arrays used for reading in +! U,V,T,Q,PS values were putting too much of a burden on the +! stack memory. Until Parallel I/O is implemented, the impact +! on the stack was reduced by using only one automatic array +! to read in and scatter the data. +! 04/01/13 - Added Heaviside window function for localized nudging +! 04/10/13 - Modified call to physics_ptend_init() to accomodate the +! new interface (in CESM1_2_BETA05). +! 05/06/13 - 'WRAP_NF' was modified from a generic interface so that +! now it can only read in 1D arrays from netCDF files. +! To eliminate errors from future meddling of this sort, all +! refenences to the 'wrap_nf' module were removed and replaced +! with direct nf90 calls. +! +! Input/Output Values: +! Forcing contributions are available for history file output by +! the names: {'Nudge_U','Nudge_V','Nudge_T',and 'Nudge_Q'} +! +! The nudging of the model toward the analyses data is controlled by +! the 'nudging_nl' namelist in 'user_nl_cam'; whose variables control the +! time interval over which nudging is applied, the strength of the nudging +! tendencies, and its spatial distribution. The strength of the nudging is +! specified as a fractional coeffcient between [0,1]. The spatial distribution +! is specified with a profile index: +! +! (U,V,T,Q) Profiles: 0 == OFF (No Nudging of this variable) +! ------------------- 1 == CONSTANT (Spatially Uniform Nudging) +! 2 == HEAVISIDE WINDOW FUNCTION +! +! (PS) Profiles: 0 == OFF (Not Implemented) +! ------------------- 1 == N/A (Not Implemented) +! +! The Heaviside window function is the product of separate horizonal and vertical +! windows that are controled via 14 parameters: +! Nudge_Hwin_lat0: Provide the horizontal center of the window in degrees. +! Nudge_Hwin_lon0: The longitude must be in the range [0,360] and the +! latitude should be [-90,+90]. +! +! Nudge_Hwin_latWidth: Specify the lat and lon widths of the window as positive +! Nudge_Hwin_lonWidth: values in degrees.Setting a width to a large value (e.g. 999) +! renders the window a constant in that direction. +! +! Nudge_Hwin_latDelta: Controls the sharpness of the window transition with a +! Nudge_Hwin_lonDelta: length in degrees. Small non-zero values yeild a step +! function while a large value leads to a smoother transition. +! +! Nudge_Vwin_Lindex: In the vertical, the window is specified in terms of model +! Nudge_Vwin_Ldelta: level indcies. The High and Low transition levels should +! Nudge_Vwin_Hindex: range from [0,(NCOL+1)]. The transition lengths are also +! Nudge_Vwin_Hdelta: specified in terms of model indices. For a window function +! constant in the vertical, the Low index should be set to 0, +! the High index should be set to (NCOL+1), and the transition +! lengths should be set to 0.1 +! +! Nudge_Hwin_lo: For a given set of spatial parameters, the raw window +! Nudge_Hwin_hi: function may not span the range [0,1], so those values are +! Nudge_Vwin_lo: mapped to the range of values specified in by the user. +! Nudge_Vwin_hi: The 'hi' values are mapped to the maximum of the raw window +! function and 'lo' values are mapped to its minimum. +! Typically the 'hi' values will be set equal to 1, and the +! 'lo' values set equal 0 or the desired window minimum. +! Specifying the 'lo' value as 1 and the 'hi' value as 0 acts +! to invert the window function. For a properly specified +! window its maximum should be equal to 1: MAX('lo','hi')==1 +! +! EXAMPLE: For a channel window function centered at the equator and independent +! of the vertical (30 levels): +! Nudge_Hwin_lo = 0. Nudge_Vwin_lo = 0. +! Nudge_Hwin_hi = 1. Nudge_Vwin_hi = 1. +! Nudge_Hwin_lat0 = 0. Nudge_Vwin_Lindex = 0. +! Nudge_Hwin_latWidth = 30. Nudge_Vwin_Ldelta = 0.1 +! Nudge_Hwin_latDelta = 5.0 Nudge_Vwin_Hindex = 31. +! Nudge_Hwin_lon0 = 180. Nudge_Vwin_Hdelta = 0.1 +! Nudge_Hwin_lonWidth = 999. +! Nudge_Hwin_lonDelta = 1.0 +! +! If on the other hand one desired to apply nudging at the poles and +! not at the equator, the settings would be similar but with: +! Nudge_Hwin_lo = 1. +! Nudge_Hwin_hi = 0. +! +! &nudging_nl +! Nudge_Model - LOGICAL toggle to activate nudging. +! Nudge_Path - CHAR path to the analyses files. +! Nudge_File_Template - CHAR Analyses filename with year, month, day, and second +! values replaced by %y, %m, %d, and %s respectively. +! Nudge_Times_Per_Day - INT Number of analyses files available per day. +! Model_Times_Per_Day - INT Number of times to update the model state (used for nudging) +! each day. The value is restricted to be longer than the +! current model timestep and shorter than the analyses +! timestep. As this number is increased, the nudging +! force has the form of newtonian cooling. +! Nudge_Uprof - INT index of profile structure to use for U. [0,1,2] +! Nudge_Vprof - INT index of profile structure to use for V. [0,1,2] +! Nudge_Tprof - INT index of profile structure to use for T. [0,1,2] +! Nudge_Qprof - INT index of profile structure to use for Q. [0,1,2] +! Nudge_PSprof - INT index of profile structure to use for PS. [0,N/A] +! Nudge_Ucoef - REAL fractional nudging coeffcient for U. +! Utau=(Nudge_Ucoef/analyses_timestep) +! Nudge_Vcoef - REAL fractional nudging coeffcient for V. +! Vtau=(Nudge_Vcoef/analyses_timestep) +! Nudge_Tcoef - REAL fractional nudging coeffcient for T. +! Ttau=(Nudge_Tcoef/analyses_timestep) +! Nudge_Qcoef - REAL fractional nudging coeffcient for Q. +! Qtau=(Nudge_Qcoef/analyses_timestep) +! Nudge_PScoef - REAL fractional nudging coeffcient for PS. +! PStau=(Nudge_PScoef/analyses_timestep) +! Nudge_Beg_Year - INT nudging begining year. +! Nudge_Beg_Month - INT nudging begining month. +! Nudge_Beg_Day - INT nudging begining day. +! Nudge_End_Year - INT nudging ending year. +! Nudge_End_Month - INT nudging ending month. +! Nudge_End_Day - INT nudging ending day. +! Nudge_Hwin_lo - REAL value mapped to RAW horizontal window minimum. [0] +! Nudge_Hwin_hi - REAL value mapped to RAW horizontal window maximum. [1] +! Nudge_Vwin_lo - REAL value mapped to RAW vertical window minimum. [0] +! Nudge_Vwin_hi - REAL value mapped to RAW vertical window maximum. [1] +! Nudge_Hwin_lat0 - REAL latitudinal center of window in degrees. +! Nudge_Hwin_lon0 - REAL longitudinal center of window in degrees. +! Nudge_Hwin_latWidth - REAL latitudinal width of window in degrees. +! Nudge_Hwin_lonWidth - REAL longitudinal width of window in degrees. +! Nudge_Hwin_latDelta - REAL latitudinal transition length of window in degrees. +! Nudge_Hwin_lonDelta - REAL longitudinal transition length of window in degrees. +! Nudge_Vwin_Lindex - REAL LO model index of transition +! Nudge_Vwin_Hindex - REAL HI model index of transition +! Nudge_Vwin_Ldelta - REAL LO transition length +! Nudge_Vwin_Hdelta - REAL HI transition length +! / +! +!================ +! DIAG NOTE: +!================ +! The interface for reading and using analyses data is not complete for the FV +! dynamical core. Wind values stored in the available data set are the values +! on the staggered grid US,VS rather than U,V. To test the implementation of +! the nudging for this case, the US,VS values were read in a loaded as if they +! were U,V. The implementation of this hack is tagged with 'DIAG' where code +! changed are needed to undo and fix what I have done. +!================ +! +! TO DO: +! ----------- +! ** Currently the surface pressure is read in, but there is no forcing +! meachnism implemented. +! ** Analyses data is read in and then distributed to processing elements +! via 'scatted_field_to_chunk' calls. The SE's want this to be changed +! to parallel I/O calls. +! ** Possibly implement time variation to nudging coeffcients, so that +! rather than just bashing the model with a sledge hammer, the user has the +! option to ramp up the nudging coefs over a startup time frame via a +! heavyside step function. +! +!===================================================================== + ! Useful modules + !------------------ + use shr_kind_mod,only:r8=>SHR_KIND_R8,cs=>SHR_KIND_CS,cl=>SHR_KIND_CL + use time_manager,only:timemgr_time_ge,timemgr_time_inc,get_curr_date,dtime + use phys_grid ,only:scatter_field_to_chunk + use cam_abortutils ,only:endrun + use spmd_utils ,only:masterproc + use cam_logfile ,only:iulog +#ifdef SPMD + use mpishorthand +#endif + + ! Set all Global values and routines to private by default + ! and then explicitly set their exposure. + !---------------------------------------------------------- + implicit none + private + + public:: Nudge_Model,Nudge_ON + public:: nudging_readnl + public:: nudging_init + public:: nudging_timestep_init + public:: nudging_timestep_tend + private::nudging_update_analyses_se + private::nudging_update_analyses_eul + private::nudging_update_analyses_fv + private::nudging_set_PSprofile + private::nudging_set_profile + + ! Nudging Parameters + !-------------------- + logical:: Nudge_Model =.false. + logical:: Nudge_ON =.false. + logical:: Nudge_File_Present=.false. + logical:: Nudge_Initialized =.false. + character(len=cl) Nudge_Path + character(len=cs) Nudge_File,Nudge_File_Template + integer Nudge_Times_Per_Day + integer Model_Times_Per_Day + real(r8) Nudge_Ucoef,Nudge_Vcoef + integer Nudge_Uprof,Nudge_Vprof + real(r8) Nudge_Qcoef,Nudge_Tcoef + integer Nudge_Qprof,Nudge_Tprof + real(r8) Nudge_PScoef + integer Nudge_PSprof + integer Nudge_Beg_Year ,Nudge_Beg_Month + integer Nudge_Beg_Day ,Nudge_Beg_Sec + integer Nudge_End_Year ,Nudge_End_Month + integer Nudge_End_Day ,Nudge_End_Sec + integer Nudge_Curr_Year,Nudge_Curr_Month + integer Nudge_Curr_Day ,Nudge_Curr_Sec + integer Nudge_Next_Year,Nudge_Next_Month + integer Nudge_Next_Day ,Nudge_Next_Sec + integer Nudge_Step + integer Model_Curr_Year,Model_Curr_Month + integer Model_Curr_Day ,Model_Curr_Sec + integer Model_Next_Year,Model_Next_Month + integer Model_Next_Day ,Model_Next_Sec + integer Model_Step + real(r8) Nudge_Hwin_lo + real(r8) Nudge_Hwin_hi + real(r8) Nudge_Hwin_lat0 + real(r8) Nudge_Hwin_latWidth + real(r8) Nudge_Hwin_latDelta + real(r8) Nudge_Hwin_lon0 + real(r8) Nudge_Hwin_lonWidth + real(r8) Nudge_Hwin_lonDelta + real(r8) Nudge_Vwin_lo + real(r8) Nudge_Vwin_hi + real(r8) Nudge_Vwin_Hindex + real(r8) Nudge_Vwin_Hdelta + real(r8) Nudge_Vwin_Lindex + real(r8) Nudge_Vwin_Ldelta + real(r8) Nudge_Hwin_latWidthH + real(r8) Nudge_Hwin_lonWidthH + real(r8) Nudge_Hwin_max + real(r8) Nudge_Hwin_min + + ! Nudging State Arrays + !----------------------- + integer Nudge_nlon,Nudge_nlat,Nudge_ncol,Nudge_nlev +!DIAG + integer Nudge_slat +!DIAG + real(r8),allocatable::Target_U(:,:,:) !(pcols,pver,begchunk:endchunk) + real(r8),allocatable::Target_V(:,:,:) !(pcols,pver,begchunk:endchunk) + real(r8),allocatable::Target_T(:,:,:) !(pcols,pver,begchunk:endchunk) + real(r8),allocatable::Target_Q(:,:,:) !(pcols,pver,begchunk:endchunk) + real(r8),allocatable::Target_PS(:,:) !(pcols,begchunk:endchunk) + real(r8),allocatable::Model_U(:,:,:) !(pcols,pver,begchunk:endchunk) + real(r8),allocatable::Model_V(:,:,:) !(pcols,pver,begchunk:endchunk) + real(r8),allocatable::Model_T(:,:,:) !(pcols,pver,begchunk:endchunk) + real(r8),allocatable::Model_Q(:,:,:) !(pcols,pver,begchunk:endchunk) + real(r8),allocatable::Model_PS(:,:) !(pcols,begchunk:endchunk) + real(r8),allocatable::Nudge_Utau(:,:,:) !(pcols,pver,begchunk:endchunk) + real(r8),allocatable::Nudge_Vtau(:,:,:) !(pcols,pver,begchunk:endchunk) + real(r8),allocatable::Nudge_Ttau(:,:,:) !(pcols,pver,begchunk:endchunk) + real(r8),allocatable::Nudge_Qtau(:,:,:) !(pcols,pver,begchunk:endchunk) + real(r8),allocatable::Nudge_PStau(:,:) !(pcols,begchunk:endchunk) + real(r8),allocatable::Nudge_Ustep(:,:,:) !(pcols,pver,begchunk:endchunk) + real(r8),allocatable::Nudge_Vstep(:,:,:) !(pcols,pver,begchunk:endchunk) + real(r8),allocatable::Nudge_Tstep(:,:,:) !(pcols,pver,begchunk:endchunk) + real(r8),allocatable::Nudge_Qstep(:,:,:) !(pcols,pver,begchunk:endchunk) + real(r8),allocatable::Nudge_PSstep(:,:) !(pcols,begchunk:endchunk) + +contains + !================================================================ + subroutine nudging_readnl(nlfile) + ! + ! NUDGING_READNL: Initialize default values controlling the Nudging + ! process. Then read namelist values to override + ! them. + !=============================================================== + use ppgrid ,only: pver + use namelist_utils,only:find_group_name + use units ,only:getunit,freeunit + ! + ! Arguments + !------------- + character(len=*),intent(in)::nlfile + ! + ! Local Values + !--------------- + integer ierr,unitn + + namelist /nudging_nl/ Nudge_Model,Nudge_Path, & + Nudge_File_Template,Nudge_Times_Per_Day, & + Model_Times_Per_Day, & + Nudge_Ucoef ,Nudge_Uprof, & + Nudge_Vcoef ,Nudge_Vprof, & + Nudge_Qcoef ,Nudge_Qprof, & + Nudge_Tcoef ,Nudge_Tprof, & + Nudge_PScoef,Nudge_PSprof, & + Nudge_Beg_Year,Nudge_Beg_Month,Nudge_Beg_Day, & + Nudge_End_Year,Nudge_End_Month,Nudge_End_Day, & + Nudge_Hwin_lo,Nudge_Hwin_hi, & + Nudge_Vwin_lo,Nudge_Vwin_hi, & + Nudge_Hwin_lat0,Nudge_Hwin_lon0, & + Nudge_Hwin_latWidth,Nudge_Hwin_lonWidth, & + Nudge_Hwin_latDelta,Nudge_Hwin_lonDelta, & + Nudge_Vwin_Lindex,Nudge_Vwin_Hindex, & + Nudge_Vwin_Ldelta,Nudge_Vwin_Hdelta + + ! Nudging is NOT initialized yet, For now + ! Nudging will always begin/end at midnight. + !-------------------------------------------- + Nudge_Initialized =.false. + Nudge_ON =.false. + Nudge_File_Present=.false. + Nudge_Beg_Sec=0 + Nudge_End_Sec=0 + + ! Set Default Namelist values + !----------------------------- + Nudge_Model =.false. + Nudge_Path ='./Data/YOTC_ne30np4_001/' + Nudge_File_Template='YOTC_ne30np4_L30.cam2.i.%y-%m-%d-%s.nc' + Nudge_Times_Per_Day=4 + Model_Times_Per_Day=4 + Nudge_Ucoef =0._r8 + Nudge_Vcoef =0._r8 + Nudge_Qcoef =0._r8 + Nudge_Tcoef =0._r8 + Nudge_PScoef =0._r8 + Nudge_Uprof =0 + Nudge_Vprof =0 + Nudge_Qprof =0 + Nudge_Tprof =0 + Nudge_PSprof =0 + Nudge_Beg_Year =2008 + Nudge_Beg_Month=5 + Nudge_Beg_Day =1 + Nudge_End_Year =2008 + Nudge_End_Month=9 + Nudge_End_Day =1 + Nudge_Hwin_lo =0.0_r8 + Nudge_Hwin_hi =1.0_r8 + Nudge_Hwin_lat0 =0._r8 + Nudge_Hwin_latWidth=9999._r8 + Nudge_Hwin_latDelta=1.0_r8 + Nudge_Hwin_lon0 =180._r8 + Nudge_Hwin_lonWidth=9999._r8 + Nudge_Hwin_lonDelta=1.0_r8 + Nudge_Vwin_lo =0.0_r8 + Nudge_Vwin_hi =1.0_r8 + Nudge_Vwin_Hindex =float(pver+1) + Nudge_Vwin_Hdelta =0.1_r8 + Nudge_Vwin_Lindex =0.0_r8 + Nudge_Vwin_Ldelta =0.1_r8 + + ! Read in namelist values + !------------------------ + if(masterproc) then + unitn = getunit() + open(unitn,file=trim(nlfile),status='old') + call find_group_name(unitn,'nudging_nl',status=ierr) + if(ierr.eq.0) then + read(unitn,nudging_nl,iostat=ierr) + if(ierr.ne.0) then + call endrun('nudging_readnl:: ERROR reading namelist') + endif + endif + close(unitn) + call freeunit(unitn) + endif + + ! Check for valid namelist values + !---------------------------------- + if((max(Nudge_Hwin_lo,Nudge_Hwin_hi).ne.1.0).or. & + (max(Nudge_Vwin_lo,Nudge_Vwin_hi).ne.1.0) ) then + write(iulog,*) 'NUDGING: The window function must have a maximum value of 1' + write(iulog,*) 'NUDGING: Nudge_Hwin_lo=',Nudge_Hwin_lo + write(iulog,*) 'NUDGING: Nudge_Hwin_hi=',Nudge_Hwin_hi + write(iulog,*) 'NUDGING: Nudge_Vwin_lo=',Nudge_Vwin_lo + write(iulog,*) 'NUDGING: Nudge_Vwin_hi=',Nudge_Vwin_hi + call endrun('nudging_readnl:: ERROR in namelist') + endif + + if((Nudge_Hwin_lat0.lt.-90.).or.(Nudge_Hwin_lat0.gt.+90.)) then + write(iulog,*) 'NUDGING: Window lat0 must be in [-90,+90]' + write(iulog,*) 'NUDGING: Nudge_Hwin_lat0=',Nudge_Hwin_lat0 + call endrun('nudging_readnl:: ERROR in namelist') + endif + + if((Nudge_Hwin_lon0.lt.0.).or.(Nudge_Hwin_lon0.ge.360.)) then + write(iulog,*) 'NUDGING: Window lon0 must be in [0,+360)' + write(iulog,*) 'NUDGING: Nudge_Hwin_lon0=',Nudge_Hwin_lon0 + call endrun('nudging_readnl:: ERROR in namelist') + endif + + if((Nudge_Vwin_Lindex.gt.Nudge_Vwin_Hindex) .or. & + (Nudge_Vwin_Hindex.gt.float(pver+1)).or.(Nudge_Vwin_Hindex.lt.0.).or. & + (Nudge_Vwin_Lindex.gt.float(pver+1)).or.(Nudge_Vwin_Lindex.lt.0.) ) then + write(iulog,*) 'NUDGING: Window Lindex must be in [0,pver+1]' + write(iulog,*) 'NUDGING: Window Hindex must be in [0,pver+1]' + write(iulog,*) 'NUDGING: Lindex must be LE than Hindex' + write(iulog,*) 'NUDGING: Nudge_Vwin_Lindex=',Nudge_Vwin_Lindex + write(iulog,*) 'NUDGING: Nudge_Vwin_Hindex=',Nudge_Vwin_Hindex + call endrun('nudging_readnl:: ERROR in namelist') + endif + + if((Nudge_Hwin_latDelta.le.0.).or.(Nudge_Hwin_lonDelta.le.0.).or. & + (Nudge_Vwin_Hdelta .le.0.).or.(Nudge_Vwin_Ldelta .le.0.) ) then + write(iulog,*) 'NUDGING: Window Deltas must be positive' + write(iulog,*) 'NUDGING: Nudge_Hwin_latDelta=',Nudge_Hwin_latDelta + write(iulog,*) 'NUDGING: Nudge_Hwin_lonDelta=',Nudge_Hwin_lonDelta + write(iulog,*) 'NUDGING: Nudge_Vwin_Hdelta=',Nudge_Vwin_Hdelta + write(iulog,*) 'NUDGING: Nudge_Vwin_Ldelta=',Nudge_Vwin_Ldelta + call endrun('nudging_readnl:: ERROR in namelist') + + endif + + if((Nudge_Hwin_latWidth.le.0.).or.(Nudge_Hwin_lonWidth.le.0.)) then + write(iulog,*) 'NUDGING: Window widths must be positive' + write(iulog,*) 'NUDGING: Nudge_Hwin_latWidth=',Nudge_Hwin_latWidth + write(iulog,*) 'NUDGING: Nudge_Hwin_lonWidth=',Nudge_Hwin_lonWidth + call endrun('nudging_readnl:: ERROR in namelist') + endif + + ! Broadcast namelist variables + !------------------------------ +#ifdef SPMD + call mpibcast(Nudge_Path ,len(Nudge_Path) ,mpichar,0,mpicom) + call mpibcast(Nudge_File_Template,len(Nudge_File_Template),mpichar,0,mpicom) + call mpibcast(Nudge_Model , 1, mpilog, 0, mpicom) + call mpibcast(Nudge_Initialized , 1, mpilog, 0, mpicom) + call mpibcast(Nudge_ON , 1, mpilog, 0, mpicom) + call mpibcast(Nudge_File_Present , 1, mpilog, 0, mpicom) + call mpibcast(Nudge_Times_Per_Day, 1, mpiint, 0, mpicom) + call mpibcast(Model_Times_Per_Day, 1, mpiint, 0, mpicom) + call mpibcast(Nudge_Ucoef , 1, mpir8 , 0, mpicom) + call mpibcast(Nudge_Vcoef , 1, mpir8 , 0, mpicom) + call mpibcast(Nudge_Tcoef , 1, mpir8 , 0, mpicom) + call mpibcast(Nudge_Qcoef , 1, mpir8 , 0, mpicom) + call mpibcast(Nudge_PScoef , 1, mpir8 , 0, mpicom) + call mpibcast(Nudge_Uprof , 1, mpiint, 0, mpicom) + call mpibcast(Nudge_Vprof , 1, mpiint, 0, mpicom) + call mpibcast(Nudge_Tprof , 1, mpiint, 0, mpicom) + call mpibcast(Nudge_Qprof , 1, mpiint, 0, mpicom) + call mpibcast(Nudge_PSprof , 1, mpiint, 0, mpicom) + call mpibcast(Nudge_Beg_Year , 1, mpiint, 0, mpicom) + call mpibcast(Nudge_Beg_Month, 1, mpiint, 0, mpicom) + call mpibcast(Nudge_Beg_Day , 1, mpiint, 0, mpicom) + call mpibcast(Nudge_Beg_Sec , 1, mpiint, 0, mpicom) + call mpibcast(Nudge_End_Year , 1, mpiint, 0, mpicom) + call mpibcast(Nudge_End_Month, 1, mpiint, 0, mpicom) + call mpibcast(Nudge_End_Day , 1, mpiint, 0, mpicom) + call mpibcast(Nudge_End_Sec , 1, mpiint, 0, mpicom) + call mpibcast(Nudge_Hwin_lo , 1, mpir8 , 0, mpicom) + call mpibcast(Nudge_Hwin_hi , 1, mpir8 , 0, mpicom) + call mpibcast(Nudge_Hwin_lat0 , 1, mpir8 , 0, mpicom) + call mpibcast(Nudge_Hwin_latWidth, 1, mpir8 , 0, mpicom) + call mpibcast(Nudge_Hwin_latDelta, 1, mpir8 , 0, mpicom) + call mpibcast(Nudge_Hwin_lon0 , 1, mpir8 , 0, mpicom) + call mpibcast(Nudge_Hwin_lonWidth, 1, mpir8 , 0, mpicom) + call mpibcast(Nudge_Hwin_lonDelta, 1, mpir8 , 0, mpicom) + call mpibcast(Nudge_Vwin_lo , 1, mpir8 , 0, mpicom) + call mpibcast(Nudge_Vwin_hi , 1, mpir8 , 0, mpicom) + call mpibcast(Nudge_Vwin_Hindex , 1, mpir8 , 0, mpicom) + call mpibcast(Nudge_Vwin_Hdelta , 1, mpir8 , 0, mpicom) + call mpibcast(Nudge_Vwin_Lindex , 1, mpir8 , 0, mpicom) + call mpibcast(Nudge_Vwin_Ldelta , 1, mpir8 , 0, mpicom) +#endif + + ! End Routine + !------------ + return + end subroutine ! nudging_readnl + !================================================================ + + + !================================================================ + subroutine nudging_init + ! + ! NUDGING_INIT: Allocate space and initialize Nudging values + !=============================================================== + use ppgrid ,only: pver,pcols,begchunk,endchunk + use error_messages,only: alloc_err + use dycore ,only: dycore_is + use dyn_grid ,only: get_horiz_grid_dim_d + use phys_grid ,only: get_rlat_p,get_rlon_p,get_ncols_p + use cam_history ,only: addfld,phys_decomp + use shr_const_mod ,only: SHR_CONST_PI + + ! Local values + !---------------- + integer Year,Month,Day,Sec + integer YMD1,YMD + logical After_Beg,Before_End + integer istat,lchnk,ncol,icol,ilev + integer hdim1_d,hdim2_d + real(r8) rlat,rlon + real(r8) Wprof(pver) + real(r8) lonp,lon0,lonn,latp,lat0,latn + real(r8) Val1_p,Val2_p,Val3_p,Val4_p + real(r8) Val1_0,Val2_0,Val3_0,Val4_0 + real(r8) Val1_n,Val2_n,Val3_n,Val4_n + + ! Allocate Space for Nudging data arrays + !----------------------------------------- + allocate(Target_U(pcols,pver,begchunk:endchunk),stat=istat) + call alloc_err(istat,'nudging_init','Target_U',pcols*pver*((endchunk-begchunk)+1)) + allocate(Target_V(pcols,pver,begchunk:endchunk),stat=istat) + call alloc_err(istat,'nudging_init','Target_V',pcols*pver*((endchunk-begchunk)+1)) + allocate(Target_T(pcols,pver,begchunk:endchunk),stat=istat) + call alloc_err(istat,'nudging_init','Target_T',pcols*pver*((endchunk-begchunk)+1)) + allocate(Target_Q(pcols,pver,begchunk:endchunk),stat=istat) + call alloc_err(istat,'nudging_init','Target_Q',pcols*pver*((endchunk-begchunk)+1)) + allocate(Target_PS(pcols,begchunk:endchunk),stat=istat) + call alloc_err(istat,'nudging_init','Target_PS',pcols*((endchunk-begchunk)+1)) + + allocate(Model_U(pcols,pver,begchunk:endchunk),stat=istat) + call alloc_err(istat,'nudging_init','Model_U',pcols*pver*((endchunk-begchunk)+1)) + allocate(Model_V(pcols,pver,begchunk:endchunk),stat=istat) + call alloc_err(istat,'nudging_init','Model_V',pcols*pver*((endchunk-begchunk)+1)) + allocate(Model_T(pcols,pver,begchunk:endchunk),stat=istat) + call alloc_err(istat,'nudging_init','Model_T',pcols*pver*((endchunk-begchunk)+1)) + allocate(Model_Q(pcols,pver,begchunk:endchunk),stat=istat) + call alloc_err(istat,'nudging_init','Model_Q',pcols*pver*((endchunk-begchunk)+1)) + allocate(Model_PS(pcols,begchunk:endchunk),stat=istat) + call alloc_err(istat,'nudging_init','Model_PS',pcols*((endchunk-begchunk)+1)) + + ! Allocate Space for spatial dependence of + ! Nudging Coefs and Nudging Forcing. + !------------------------------------------- + allocate(Nudge_Utau(pcols,pver,begchunk:endchunk),stat=istat) + call alloc_err(istat,'nudging_init','Nudge_Utau',pcols*pver*((endchunk-begchunk)+1)) + allocate(Nudge_Vtau(pcols,pver,begchunk:endchunk),stat=istat) + call alloc_err(istat,'nudging_init','Nudge_Vtau',pcols*pver*((endchunk-begchunk)+1)) + allocate(Nudge_Ttau(pcols,pver,begchunk:endchunk),stat=istat) + call alloc_err(istat,'nudging_init','Nudge_Ttau',pcols*pver*((endchunk-begchunk)+1)) + allocate(Nudge_Qtau(pcols,pver,begchunk:endchunk),stat=istat) + call alloc_err(istat,'nudging_init','Nudge_Qtau',pcols*pver*((endchunk-begchunk)+1)) + allocate(Nudge_PStau(pcols,begchunk:endchunk),stat=istat) + call alloc_err(istat,'nudging_init','Nudge_PStau',pcols*((endchunk-begchunk)+1)) + + allocate(Nudge_Ustep(pcols,pver,begchunk:endchunk),stat=istat) + call alloc_err(istat,'nudging_init','Nudge_Ustep',pcols*pver*((endchunk-begchunk)+1)) + allocate(Nudge_Vstep(pcols,pver,begchunk:endchunk),stat=istat) + call alloc_err(istat,'nudging_init','Nudge_Vstep',pcols*pver*((endchunk-begchunk)+1)) + allocate(Nudge_Tstep(pcols,pver,begchunk:endchunk),stat=istat) + call alloc_err(istat,'nudging_init','Nudge_Tstep',pcols*pver*((endchunk-begchunk)+1)) + allocate(Nudge_Qstep(pcols,pver,begchunk:endchunk),stat=istat) + call alloc_err(istat,'nudging_init','Nudge_Qstep',pcols*pver*((endchunk-begchunk)+1)) + allocate(Nudge_PSstep(pcols,begchunk:endchunk),stat=istat) + call alloc_err(istat,'nudging_init','Nudge_PSstep',pcols*((endchunk-begchunk)+1)) + + ! Register output fields with the cam history module + !----------------------------------------------------- + call addfld('Nudge_U','m/s/s' ,pver,'A','U Nudging Tendency',phys_decomp) + call addfld('Nudge_V','m/s/s' ,pver,'A','V Nudging Tendency',phys_decomp) + call addfld('Nudge_T','cp*K/s' ,pver,'A','T Nudging Tendency',phys_decomp) + call addfld('Nudge_Q','kg/kg/s',pver,'A','Q Nudging Tendency',phys_decomp) + + !----------------------------------------- + ! Values initialized only by masterproc + !----------------------------------------- + if(masterproc) then + + ! Set the Stepping intervals for Model and Nudging values + ! Ensure that the Model_Step is not smaller then one timestep + ! and not larger then the Nudge_Step. + !-------------------------------------------------------- + Model_Step=86400/Model_Times_Per_Day + Nudge_Step=86400/Nudge_Times_Per_Day + if(Model_Step.lt.dtime) then + write(iulog,*) ' ' + write(iulog,*) 'NUDGING: Model_Step cannot be less than a model timestep' + write(iulog,*) 'NUDGING: Setting Model_Step=dtime , dtime=',dtime + write(iulog,*) ' ' + Model_Step=dtime + endif + if(Model_Step.gt.Nudge_Step) then + write(iulog,*) ' ' + write(iulog,*) 'NUDGING: Model_Step cannot be more than Nudge_Step' + write(iulog,*) 'NUDGING: Setting Model_Step=Nudge_Step, Nudge_Step=',Nudge_Step + write(iulog,*) ' ' + Model_Step=Nudge_Step + endif + + ! Initialize column and level dimensions + !-------------------------------------------------------- + call get_horiz_grid_dim_d(hdim1_d,hdim2_d) + Nudge_nlon=hdim1_d + Nudge_nlat=hdim2_d + Nudge_ncol=hdim1_d*hdim2_d + Nudge_nlev=pver +!DIAG + Nudge_slat=Nudge_nlat-1 +!DIAG + + ! Check the time relative to the nudging window + !------------------------------------------------ + call get_curr_date(Year,Month,Day,Sec) + YMD=(Year*10000) + (Month*100) + Day + YMD1=(Nudge_Beg_Year*10000) + (Nudge_Beg_Month*100) + Nudge_Beg_Day + call timemgr_time_ge(YMD1,Nudge_Beg_Sec, & + YMD ,Sec ,After_Beg) + YMD1=(Nudge_End_Year*10000) + (Nudge_End_Month*100) + Nudge_End_Day + call timemgr_time_ge(YMD ,Sec , & + YMD1,Nudge_End_Sec,Before_End) + + if((After_Beg).and.(Before_End)) then + ! Set Time indicies so that the next call to + ! timestep_init will initialize the data arrays. + !-------------------------------------------- + Model_Next_Year =Year + Model_Next_Month=Month + Model_Next_Day =Day + Model_Next_Sec =(Sec/Model_Step)*Model_Step + Nudge_Next_Year =Year + Nudge_Next_Month=Month + Nudge_Next_Day =Day + Nudge_Next_Sec =(Sec/Nudge_Step)*Nudge_Step + elseif(.not.After_Beg) then + ! Set Time indicies to Nudging start, + ! timestep_init will initialize the data arrays. + !-------------------------------------------- + Model_Next_Year =Nudge_Beg_Year + Model_Next_Month=Nudge_Beg_Month + Model_Next_Day =Nudge_Beg_Day + Model_Next_Sec =Nudge_Beg_Sec + Nudge_Next_Year =Nudge_Beg_Year + Nudge_Next_Month=Nudge_Beg_Month + Nudge_Next_Day =Nudge_Beg_Day + Nudge_Next_Sec =Nudge_Beg_Sec + elseif(.not.Before_End) then + ! Nudging will never occur, so switch it off + !-------------------------------------------- + Nudge_Model=.false. + Nudge_ON =.false. + write(iulog,*) ' ' + write(iulog,*) 'NUDGING: WARNING - Nudging has been requested by it will' + write(iulog,*) 'NUDGING: never occur for the given time values' + write(iulog,*) ' ' + endif + + ! Initialize values for window function + !---------------------------------------- + lonp= 180. + lon0= 0. + lonn=-180. + latp= 90.-Nudge_Hwin_lat0 + lat0= 0. + latn= -90.-Nudge_Hwin_lat0 + + Nudge_Hwin_lonWidthH=Nudge_Hwin_lonWidth/2. + Nudge_Hwin_latWidthH=Nudge_Hwin_latWidth/2. + + Val1_p=(1.+tanh((Nudge_Hwin_lonWidthH+lonp)/Nudge_Hwin_lonDelta))/2. + Val2_p=(1.+tanh((Nudge_Hwin_lonWidthH-lonp)/Nudge_Hwin_lonDelta))/2. + Val3_p=(1.+tanh((Nudge_Hwin_latWidthH+latp)/Nudge_Hwin_latDelta))/2. + Val4_p=(1.+tanh((Nudge_Hwin_latWidthH-latp)/Nudge_Hwin_latDelta))/2. + + Val1_0=(1.+tanh((Nudge_Hwin_lonWidthH+lon0)/Nudge_Hwin_lonDelta))/2. + Val2_0=(1.+tanh((Nudge_Hwin_lonWidthH-lon0)/Nudge_Hwin_lonDelta))/2. + Val3_0=(1.+tanh((Nudge_Hwin_latWidthH+lat0)/Nudge_Hwin_latDelta))/2. + Val4_0=(1.+tanh((Nudge_Hwin_latWidthH-lat0)/Nudge_Hwin_latDelta))/2. + + Val1_n=(1.+tanh((Nudge_Hwin_lonWidthH+lonn)/Nudge_Hwin_lonDelta))/2. + Val2_n=(1.+tanh((Nudge_Hwin_lonWidthH-lonn)/Nudge_Hwin_lonDelta))/2. + Val3_n=(1.+tanh((Nudge_Hwin_latWidthH+latn)/Nudge_Hwin_latDelta))/2. + Val4_n=(1.+tanh((Nudge_Hwin_latWidthH-latn)/Nudge_Hwin_latDelta))/2. + + Nudge_Hwin_max= Val1_0*Val2_0*Val3_0*Val4_0 + Nudge_Hwin_min=min((Val1_p*Val2_p*Val3_n*Val4_n), & + (Val1_p*Val2_p*Val3_p*Val4_p), & + (Val1_n*Val2_n*Val3_n*Val4_n), & + (Val1_n*Val2_n*Val3_p*Val4_p)) + + ! Initialization is done, + !-------------------------- + Nudge_Initialized=.true. + + ! Check that this is a valid DYCORE model + !------------------------------------------ + if((.not.dycore_is('UNSTRUCTURED')).and. & + (.not.dycore_is('EUL') ).and. & + (.not.dycore_is('LR') ) ) then + call endrun('NUDGING IS CURRENTLY ONLY CONFIGURED FOR CAM-SE, FV, or EUL') + endif + + ! Informational Output + !--------------------------- + write(iulog,*) ' ' + write(iulog,*) '---------------------------------------------------------' + write(iulog,*) ' MODEL NUDGING INITIALIZED WITH THE FOLLOWING SETTINGS: ' + write(iulog,*) '---------------------------------------------------------' + write(iulog,*) 'NUDGING: Nudge_Model=',Nudge_Model + write(iulog,*) 'NUDGING: Nudge_Path=',Nudge_Path + write(iulog,*) 'NUDGING: Nudge_File_Template=',Nudge_File_Template + write(iulog,*) 'NUDGING: Nudge_Times_Per_Day=',Nudge_Times_Per_Day + write(iulog,*) 'NUDGING: Model_Times_Per_Day=',Model_Times_Per_Day + write(iulog,*) 'NUDGING: Nudge_Step=',Nudge_Step + write(iulog,*) 'NUDGING: Model_Step=',Model_Step + write(iulog,*) 'NUDGING: Nudge_Ucoef =',Nudge_Ucoef + write(iulog,*) 'NUDGING: Nudge_Vcoef =',Nudge_Vcoef + write(iulog,*) 'NUDGING: Nudge_Qcoef =',Nudge_Qcoef + write(iulog,*) 'NUDGING: Nudge_Tcoef =',Nudge_Tcoef + write(iulog,*) 'NUDGING: Nudge_PScoef =',Nudge_PScoef + write(iulog,*) 'NUDGING: Nudge_Uprof =',Nudge_Uprof + write(iulog,*) 'NUDGING: Nudge_Vprof =',Nudge_Vprof + write(iulog,*) 'NUDGING: Nudge_Qprof =',Nudge_Qprof + write(iulog,*) 'NUDGING: Nudge_Tprof =',Nudge_Tprof + write(iulog,*) 'NUDGING: Nudge_PSprof =',Nudge_PSprof + write(iulog,*) 'NUDGING: Nudge_Beg_Year =',Nudge_Beg_Year + write(iulog,*) 'NUDGING: Nudge_Beg_Month=',Nudge_Beg_Month + write(iulog,*) 'NUDGING: Nudge_Beg_Day =',Nudge_Beg_Day + write(iulog,*) 'NUDGING: Nudge_End_Year =',Nudge_End_Year + write(iulog,*) 'NUDGING: Nudge_End_Month=',Nudge_End_Month + write(iulog,*) 'NUDGING: Nudge_End_Day =',Nudge_End_Day + write(iulog,*) 'NUDGING: Nudge_Hwin_lo =',Nudge_Hwin_lo + write(iulog,*) 'NUDGING: Nudge_Hwin_hi =',Nudge_Hwin_hi + write(iulog,*) 'NUDGING: Nudge_Hwin_lat0 =',Nudge_Hwin_lat0 + write(iulog,*) 'NUDGING: Nudge_Hwin_latWidth =',Nudge_Hwin_latWidth + write(iulog,*) 'NUDGING: Nudge_Hwin_latDelta =',Nudge_Hwin_latDelta + write(iulog,*) 'NUDGING: Nudge_Hwin_lon0 =',Nudge_Hwin_lon0 + write(iulog,*) 'NUDGING: Nudge_Hwin_lonWidth =',Nudge_Hwin_lonWidth + write(iulog,*) 'NUDGING: Nudge_Hwin_lonDelta =',Nudge_Hwin_lonDelta + write(iulog,*) 'NUDGING: Nudge_Vwin_lo =',Nudge_Vwin_lo + write(iulog,*) 'NUDGING: Nudge_Vwin_hi =',Nudge_Vwin_hi + write(iulog,*) 'NUDGING: Nudge_Vwin_Hindex =',Nudge_Vwin_Hindex + write(iulog,*) 'NUDGING: Nudge_Vwin_Hdelta =',Nudge_Vwin_Hdelta + write(iulog,*) 'NUDGING: Nudge_Vwin_Lindex =',Nudge_Vwin_Lindex + write(iulog,*) 'NUDGING: Nudge_Vwin_Ldelta =',Nudge_Vwin_Ldelta + write(iulog,*) 'NUDGING: Nudge_Hwin_latWidthH=',Nudge_Hwin_latWidthH + write(iulog,*) 'NUDGING: Nudge_Hwin_lonWidthH=',Nudge_Hwin_lonWidthH + write(iulog,*) 'NUDGING: Nudge_Hwin_max =',Nudge_Hwin_max + write(iulog,*) 'NUDGING: Nudge_Hwin_min =',Nudge_Hwin_min + write(iulog,*) 'NUDGING: Nudge_Initialized =',Nudge_Initialized + write(iulog,*) ' ' + write(iulog,*) ' ' + + endif ! (masterproc) then + + ! Broadcast other variables that have changed + !--------------------------------------------- +#ifdef SPMD + call mpibcast(Model_Step , 1, mpir8 , 0, mpicom) + call mpibcast(Nudge_Step , 1, mpir8 , 0, mpicom) + call mpibcast(Model_Next_Year , 1, mpiint, 0, mpicom) + call mpibcast(Model_Next_Month , 1, mpiint, 0, mpicom) + call mpibcast(Model_Next_Day , 1, mpiint, 0, mpicom) + call mpibcast(Model_Next_Sec , 1, mpiint, 0, mpicom) + call mpibcast(Nudge_Next_Year , 1, mpiint, 0, mpicom) + call mpibcast(Nudge_Next_Month , 1, mpiint, 0, mpicom) + call mpibcast(Nudge_Next_Day , 1, mpiint, 0, mpicom) + call mpibcast(Nudge_Next_Sec , 1, mpiint, 0, mpicom) + call mpibcast(Nudge_Model , 1, mpilog, 0, mpicom) + call mpibcast(Nudge_ON , 1, mpilog, 0, mpicom) + call mpibcast(Nudge_Initialized , 1, mpilog, 0, mpicom) + call mpibcast(Nudge_ncol , 1, mpiint, 0, mpicom) + call mpibcast(Nudge_nlev , 1, mpiint, 0, mpicom) + call mpibcast(Nudge_nlon , 1, mpiint, 0, mpicom) + call mpibcast(Nudge_nlat , 1, mpiint, 0, mpicom) + call mpibcast(Nudge_Hwin_max , 1, mpir8 , 0, mpicom) + call mpibcast(Nudge_Hwin_min , 1, mpir8 , 0, mpicom) + call mpibcast(Nudge_Hwin_lonWidthH, 1, mpir8 , 0, mpicom) + call mpibcast(Nudge_Hwin_latWidthH, 1, mpir8 , 0, mpicom) +!DIAG + call mpibcast(Nudge_slat , 1, mpiint, 0, mpicom) +!DIAG +#endif + + ! Initialize Nudging Coeffcient profiles in local arrays + ! Load zeros into nudging arrays + !------------------------------------------------------ + do lchnk=begchunk,endchunk + ncol=get_ncols_p(lchnk) + do icol=1,ncol + rlat=get_rlat_p(lchnk,icol)*180._r8/SHR_CONST_PI + rlon=get_rlon_p(lchnk,icol)*180._r8/SHR_CONST_PI + + call nudging_set_profile(rlat,rlon,Nudge_Uprof,Wprof,pver) + Nudge_Utau(icol,:,lchnk)=Wprof(:) + call nudging_set_profile(rlat,rlon,Nudge_Vprof,Wprof,pver) + Nudge_Vtau(icol,:,lchnk)=Wprof(:) + call nudging_set_profile(rlat,rlon,Nudge_Tprof,Wprof,pver) + Nudge_Ttau(icol,:,lchnk)=Wprof(:) + call nudging_set_profile(rlat,rlon,Nudge_Qprof,Wprof,pver) + Nudge_Qtau(icol,:,lchnk)=Wprof(:) + + Nudge_PStau(icol,lchnk)=nudging_set_PSprofile(rlat,rlon,Nudge_PSprof) + end do + Nudge_Utau(:ncol,:pver,lchnk) = & + Nudge_Utau(:ncol,:pver,lchnk) * Nudge_Ucoef/float(Nudge_Step) + Nudge_Vtau(:ncol,:pver,lchnk) = & + Nudge_Vtau(:ncol,:pver,lchnk) * Nudge_Vcoef/float(Nudge_Step) + Nudge_Ttau(:ncol,:pver,lchnk) = & + Nudge_Ttau(:ncol,:pver,lchnk) * Nudge_Tcoef/float(Nudge_Step) + Nudge_Qtau(:ncol,:pver,lchnk) = & + Nudge_Qtau(:ncol,:pver,lchnk) * Nudge_Qcoef/float(Nudge_Step) + Nudge_PStau(:ncol,lchnk)= & + Nudge_PStau(:ncol,lchnk)* Nudge_PScoef/float(Nudge_Step) + + Nudge_Ustep(:pcols,:pver,lchnk)=0._r8 + Nudge_Vstep(:pcols,:pver,lchnk)=0._r8 + Nudge_Tstep(:pcols,:pver,lchnk)=0._r8 + Nudge_Qstep(:pcols,:pver,lchnk)=0._r8 + Nudge_PSstep(:pcols,lchnk)=0._r8 + Target_U(:pcols,:pver,lchnk)=0._r8 + Target_V(:pcols,:pver,lchnk)=0._r8 + Target_T(:pcols,:pver,lchnk)=0._r8 + Target_Q(:pcols,:pver,lchnk)=0._r8 + Target_PS(:pcols,lchnk)=0._r8 + end do + + ! End Routine + !------------ + return + end subroutine ! nudging_init + !================================================================ + + + !================================================================ + subroutine nudging_timestep_init(phys_state) + ! + ! NUDGING_TIMESTEP_INIT: + ! Check the current time and update Model/Nudging + ! arrays when necessary. Toggle the Nudging flag + ! when the time is withing the nudging window. + !=============================================================== + use physics_types,only: physics_state + use constituents ,only: cnst_get_ind + use dycore ,only: dycore_is + use ppgrid ,only: pver,pcols,begchunk,endchunk + use filenames ,only: interpret_filename_spec + use physconst ,only: cpair + + ! Arguments + !----------- + type(physics_state),intent(in):: phys_state(begchunk:endchunk) + + ! Local values + !---------------- + integer Year,Month,Day,Sec + integer YMD1,YMD2,YMD + logical Update_Model,Update_Nudge,Sync_Error + logical After_Beg ,Before_End + integer lchnk,ncol,indw + + ! Check if Nudging is initialized + !--------------------------------- + if(.not.Nudge_Initialized) then + call endrun('nudging_timestep_init:: Nudging NOT Initialized') + endif + + ! Get Current time + !-------------------- + call get_curr_date(Year,Month,Day,Sec) + YMD=(Year*10000) + (Month*100) + Day + + !------------------------------------------------------- + ! Determine if the current time is AFTER the begining time + ! and if it is BEFORE the ending time. + !------------------------------------------------------- + YMD1=(Nudge_Beg_Year*10000) + (Nudge_Beg_Month*100) + Nudge_Beg_Day + call timemgr_time_ge(YMD1,Nudge_Beg_Sec, & + YMD ,Sec ,After_Beg) + + YMD1=(Nudge_End_Year*10000) + (Nudge_End_Month*100) + Nudge_End_Day + call timemgr_time_ge(YMD ,Sec, & + YMD1,Nudge_End_Sec,Before_End) + + !-------------------------------------------------------------- + ! When past the NEXT time, Update Model Arrays and time indices + !-------------------------------------------------------------- + YMD1=(Model_Next_Year*10000) + (Model_Next_Month*100) + Model_Next_Day + call timemgr_time_ge(YMD1,Model_Next_Sec, & + YMD ,Sec ,Update_Model) + + if((Before_End).and.(Update_Model)) then + ! Increment the Model times by the current interval + !--------------------------------------------------- + Model_Curr_Year =Model_Next_Year + Model_Curr_Month=Model_Next_Month + Model_Curr_Day =Model_Next_Day + Model_Curr_Sec =Model_Next_Sec + YMD1=(Model_Curr_Year*10000) + (Model_Curr_Month*100) + Model_Curr_Day + call timemgr_time_inc(YMD1,Model_Curr_Sec, & + YMD2,Model_Next_Sec,Model_Step,0,0) + + ! Check for Sync Error where NEXT model time after the update + ! is before the current time. If so, reset the next model + ! time to a Model_Step after the current time. + !-------------------------------------------------------------- + call timemgr_time_ge(YMD2,Model_Next_Sec, & + YMD ,Sec ,Sync_Error) + if(Sync_Error) then + Model_Curr_Year =Year + Model_Curr_Month=Month + Model_Curr_Day =Day + Model_Curr_Sec =Sec + call timemgr_time_inc(YMD ,Model_Curr_Sec, & + YMD2,Model_Next_Sec,Model_Step,0,0) + write(iulog,*) 'NUDGING: WARNING - Model_Time Sync ERROR... CORRECTED' + endif + Model_Next_Year =(YMD2/10000) + YMD2 = YMD2-(Model_Next_Year*10000) + Model_Next_Month=(YMD2/100) + Model_Next_Day = YMD2-(Model_Next_Month*100) + + ! Load values at Current into the Model arrays + !----------------------------------------------- + call cnst_get_ind('Q',indw) + do lchnk=begchunk,endchunk + ncol=phys_state(lchnk)%ncol + Model_U(:ncol,:pver,lchnk)=phys_state(lchnk)%u(:ncol,:pver) + Model_V(:ncol,:pver,lchnk)=phys_state(lchnk)%v(:ncol,:pver) + Model_T(:ncol,:pver,lchnk)=phys_state(lchnk)%t(:ncol,:pver) + Model_Q(:ncol,:pver,lchnk)=phys_state(lchnk)%q(:ncol,:pver,indw) + Model_PS(:ncol,lchnk)=phys_state(lchnk)%ps(:ncol) + end do + endif + + !---------------------------------------------------------------- + ! When past the NEXT time, Update Nudging Arrays and time indices + !---------------------------------------------------------------- + YMD1=(Nudge_Next_Year*10000) + (Nudge_Next_Month*100) + Nudge_Next_Day + call timemgr_time_ge(YMD1,Nudge_Next_Sec, & + YMD ,Sec ,Update_Nudge) + + if((Before_End).and.(Update_Nudge)) then + ! Increment the Nudge times by the current interval + !--------------------------------------------------- + Nudge_Curr_Year =Nudge_Next_Year + Nudge_Curr_Month=Nudge_Next_Month + Nudge_Curr_Day =Nudge_Next_Day + Nudge_Curr_Sec =Nudge_Next_Sec + YMD1=(Nudge_Curr_Year*10000) + (Nudge_Curr_Month*100) + Nudge_Curr_Day + call timemgr_time_inc(YMD1,Nudge_Curr_Sec, & + YMD2,Nudge_Next_Sec,Nudge_Step,0,0) + Nudge_Next_Year =(YMD2/10000) + YMD2 = YMD2-(Nudge_Next_Year*10000) + Nudge_Next_Month=(YMD2/100) + Nudge_Next_Day = YMD2-(Nudge_Next_Month*100) + + ! Update the Nudge arrays with analysis + ! data at the NEXT time + !----------------------------------------------- + Nudge_File=interpret_filename_spec(Nudge_File_Template , & + yr_spec=Nudge_Next_Year , & + mon_spec=Nudge_Next_Month, & + day_spec=Nudge_Next_Day , & + sec_spec=Nudge_Next_Sec ) + if(masterproc) then + write(iulog,*) 'NUDGING: Reading analyses:',trim(Nudge_Path)//trim(Nudge_File) + endif + + ! How to manage MISSING values when there are 'Gaps' in the analyses data? + ! Check for analyses file existence. If it is there, then read data. + ! If it is not, then issue a warning and switch off nudging to 'coast' + ! thru the gap. + !------------------------------------------------------------------------ + if(dycore_is('UNSTRUCTURED')) then + call nudging_update_analyses_se(trim(Nudge_Path)//trim(Nudge_File)) + elseif(dycore_is('EUL')) then + call nudging_update_analyses_eul(trim(Nudge_Path)//trim(Nudge_File)) + else !if(dycore_is('LR')) then + call nudging_update_analyses_fv(trim(Nudge_Path)//trim(Nudge_File)) + endif + endif + + !------------------------------------------------------- + ! Toggle Nudging flag when the time interval is between + ! beginning and ending times, and the analyses file exists. + !------------------------------------------------------- + if((After_Beg).and.(Before_End)) then + if(Nudge_File_Present) then + Nudge_ON=.true. + else + Nudge_ON=.false. + if(masterproc) then + write(iulog,*) 'NUDGING: WARNING - analyses file NOT FOUND. Switching ' + write(iulog,*) 'NUDGING: nudging OFF to coast thru the gap. ' + endif + endif + else + Nudge_ON=.false. + endif + + !------------------------------------------------------- + ! HERE Implement time dependence of Nudging Coefs HERE + !------------------------------------------------------- + + + + !--------------------------------------------------- + ! If Data arrays have changed update stepping arrays + !--------------------------------------------------- + if((Before_End).and.((Update_Nudge).or.(Update_Model))) then + do lchnk=begchunk,endchunk + ncol=phys_state(lchnk)%ncol + Nudge_Ustep(:ncol,:pver,lchnk)=( Target_U(:ncol,:pver,lchnk) & + -Model_U(:ncol,:pver,lchnk)) & + *Nudge_Utau(:ncol,:pver,lchnk) + Nudge_Vstep(:ncol,:pver,lchnk)=( Target_V(:ncol,:pver,lchnk) & + -Model_V(:ncol,:pver,lchnk)) & + *Nudge_Vtau(:ncol,:pver,lchnk) + Nudge_Tstep(:ncol,:pver,lchnk)=( Target_T(:ncol,:pver,lchnk) & + -Model_T(:ncol,:pver,lchnk)) & + *Nudge_Ttau(:ncol,:pver,lchnk)*cpair + Nudge_Qstep(:ncol,:pver,lchnk)=( Target_Q(:ncol,:pver,lchnk) & + -Model_Q(:ncol,:pver,lchnk)) & + *Nudge_Qtau(:ncol,:pver,lchnk) + Nudge_PSstep(:ncol, lchnk)=( Target_PS(:ncol,lchnk) & + -Model_PS(:ncol,lchnk)) & + *Nudge_PStau(:ncol,lchnk) + end do + + !****************** + ! DIAG + !****************** +! if(masterproc) then +! write(iulog,*) 'PFC: Target_T(1,:pver,begchunk)=',Target_T(1,:pver,begchunk) +! write(iulog,*) 'PFC: Model_T(1,:pver,begchunk)=',Model_T(1,:pver,begchunk) +! write(iulog,*) 'PFC: Nudge_Tstep(1,:pver,begchunk)=',Nudge_Tstep(1,:pver,begchunk) +! write(iulog,*) 'PFC: Nudge_Xstep arrays updated:' +! endif + endif + + ! End Routine + !------------ + return + end subroutine ! nudging_timestep_init + !================================================================ + + + !================================================================ + subroutine nudging_timestep_tend(phys_state,phys_tend) + ! + ! NUDGING_TIMESTEP_TEND: + ! If Nudging is ON, return the Nudging contributions + ! to forcing using the current contents of the Nudge + ! arrays. Send output to the cam history module as well. + !=============================================================== + use physics_types,only: physics_state,physics_ptend,physics_ptend_init + use constituents ,only: cnst_get_ind,pcnst + use ppgrid ,only: pver,pcols,begchunk,endchunk + use cam_history ,only: outfld + + ! Arguments + !------------- + type(physics_state), intent(in) :: phys_state + type(physics_ptend), intent(out):: phys_tend + + ! Local values + !-------------------- + integer indw,ncol,lchnk + logical lq(pcnst) + + call cnst_get_ind('Q',indw) + lq(:) =.false. + lq(indw)=.true. + call physics_ptend_init(phys_tend,phys_state%psetcols,'nudging',lu=.true.,lv=.true.,ls=.true.,lq=lq) + + if(Nudge_ON) then + lchnk=phys_state%lchnk + ncol =phys_state%ncol + phys_tend%u(:ncol,:pver) =Nudge_Ustep(:ncol,:pver,lchnk) + phys_tend%v(:ncol,:pver) =Nudge_Vstep(:ncol,:pver,lchnk) + phys_tend%s(:ncol,:pver) =Nudge_Tstep(:ncol,:pver,lchnk) + phys_tend%q(:ncol,:pver,indw)=Nudge_Qstep(:ncol,:pver,lchnk) + + call outfld('Nudge_U',phys_tend%u ,pcols,lchnk) + call outfld('Nudge_V',phys_tend%v ,pcols,lchnk) + call outfld('Nudge_T',phys_tend%s ,pcols,lchnk) + call outfld('Nudge_Q',phys_tend%q(1,1,indw),pcols,lchnk) + endif + + ! End Routine + !------------ + return + end subroutine ! nudging_timestep_tend + !================================================================ + + + !================================================================ + subroutine nudging_update_analyses_se(anal_file) + ! + ! NUDGING_UPDATE_ANALYSES_SE: + ! Open the given analyses data file, read in + ! U,V,T,Q, and PS values and then distribute + ! the values to all of the chunks. + !=============================================================== +! use wrap_nf + use ppgrid ,only: pver + use netcdf + + ! Arguments + !------------- + character(len=*),intent(in):: anal_file + + ! Local values + !------------- + integer lev + integer ncol,plev,istat + integer ncid,varid + real(r8) Xanal(Nudge_ncol,Nudge_nlev) + real(r8) PSanal(Nudge_ncol) + real(r8) Lat_anal(Nudge_ncol) + real(r8) Lon_anal(Nudge_ncol) + + ! Check the existence of the analyses file; broadcast the file status to + ! all the other MPI nodes. If the file is not there, then just return. + !------------------------------------------------------------------------ + if(masterproc) then + inquire(FILE=trim(anal_file),EXIST=Nudge_File_Present) + endif +#ifdef SPMD + call mpibcast(Nudge_File_Present, 1, mpilog, 0, mpicom) +#endif + if(.not.Nudge_File_Present) return + + ! masterporc does all of the work here + !----------------------------------------- + if(masterproc) then + + ! Open the given file + !----------------------- + istat=nf90_open(trim(anal_file),NF90_NOWRITE,ncid) + if(istat.ne.NF90_NOERR) then + write(iulog,*)'NF90_OPEN: failed for file ',trim(anal_file) + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_SE') + endif + + ! Read in Dimensions + !-------------------- +! call wrap_inq_dimid (ncid,'ncol',varid) +! call wrap_inq_dimlen(ncid,varid,ncol) + istat=nf90_inq_dimid(ncid,'ncol',varid) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_SE') + endif + istat=nf90_inquire_dimension(ncid,varid,len=ncol) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_SE') + endif + +! call wrap_inq_dimid (ncid,'lev',varid) +! call wrap_inq_dimlen(ncid,varid,plev) + istat=nf90_inq_dimid(ncid,'lev',varid) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_SE') + endif + istat=nf90_inquire_dimension(ncid,varid,len=plev) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_SE') + endif + +! call wrap_inq_varid(ncid,'lon',varid) +! call wrap_get_var_realx(ncid,varid,Lon_anal) + istat=nf90_inq_varid(ncid,'lon',varid) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_SE') + endif + istat=nf90_get_var(ncid,varid,Lon_anal) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_SE') + endif + +! call wrap_inq_varid(ncid,'lat',varid) +! call wrap_get_var_realx(ncid,varid,Lat_anal) + istat=nf90_inq_varid(ncid,'lat',varid) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_SE') + endif + istat=nf90_get_var(ncid,varid,Lat_anal) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_SE') + endif + + if((Nudge_ncol.ne.ncol).or.(plev.ne.pver)) then + write(iulog,*) 'ERROR: nudging_update_analyses_se: ncol=',ncol,' Nudge_ncol=',Nudge_ncol + write(iulog,*) 'ERROR: nudging_update_analyses_se: plev=',plev,' pver=',pver + call endrun('nudging_update_analyses_se: analyses dimension mismatch') + endif + + ! Read in and scatter data arrays + !---------------------------------- +! call wrap_inq_varid (ncid,'U',varid) +! call wrap_get_var_realx(ncid,varid,Xanal) + istat=nf90_inq_varid(ncid,'U',varid) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_SE') + endif + istat=nf90_get_var(ncid,varid,Xanal) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_SE') + endif + endif ! (masterproc) then + call scatter_field_to_chunk(1,Nudge_nlev,1,Nudge_ncol,Xanal ,Target_U) + + if(masterproc) then +! call wrap_inq_varid (ncid,'V',varid) +! call wrap_get_var_realx(ncid,varid,Xanal) + istat=nf90_inq_varid(ncid,'V',varid) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_SE') + endif + istat=nf90_get_var(ncid,varid,Xanal) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_SE') + endif + endif ! (masterproc) then + call scatter_field_to_chunk(1,Nudge_nlev,1,Nudge_ncol,Xanal ,Target_V) + + if(masterproc) then +! call wrap_inq_varid (ncid,'T',varid) +! call wrap_get_var_realx(ncid,varid,Xanal) + istat=nf90_inq_varid(ncid,'T',varid) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_SE') + endif + istat=nf90_get_var(ncid,varid,Xanal) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_SE') + endif + endif ! (masterproc) then + call scatter_field_to_chunk(1,Nudge_nlev,1,Nudge_ncol,Xanal ,Target_T) + + if(masterproc) then +! call wrap_inq_varid (ncid,'Q',varid) +! call wrap_get_var_realx(ncid,varid,Xanal) + istat=nf90_inq_varid(ncid,'Q',varid) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_SE') + endif + istat=nf90_get_var(ncid,varid,Xanal) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_SE') + endif + endif ! (masterproc) then + call scatter_field_to_chunk(1,Nudge_nlev,1,Nudge_ncol,Xanal ,Target_Q) + + if(masterproc) then +!! call wrap_inq_varid (ncid,'PS',varid) +!! call wrap_get_var_realx(ncid,varid,PSanal) +! istat=nf90_inq_varid(ncid,'PS',varid) +! if(istat.ne.NF90_NOERR) then +! write(iulog,*) nf90_strerror(istat) +! call endrun ('UPDATE_ANALYSES_SE') +! endif +! istat=nf90_get_var(ncid,varid,PSanal) +! if(istat.ne.NF90_NOERR) then +! write(iulog,*) nf90_strerror(istat) +! call endrun ('UPDATE_ANALYSES_SE') +! endif + + ! Close the analyses file + !----------------------- +! call wrap_close(ncid) + istat=nf90_close(ncid) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_SE') + endif + endif ! (masterproc) then +! call scatter_field_to_chunk(1, 1,1,Nudge_ncol,PSanal,Target_PS) + + ! End Routine + !------------ + return + end subroutine ! nudging_update_analyses_se + !================================================================ + + + !================================================================ + subroutine nudging_update_analyses_eul(anal_file) + ! + ! NUDGING_UPDATE_ANALYSES_EUL: + ! Open the given analyses data file, read in + ! U,V,T,Q, and PS values and then distribute + ! the values to all of the chunks. + !=============================================================== +! use wrap_nf + use ppgrid ,only: pver + use netcdf + + ! Arguments + !------------- + character(len=*),intent(in):: anal_file + + ! Local values + !------------- + integer lev + integer nlon,nlat,plev,istat + integer ncid,varid + integer ilat,ilon,ilev + real(r8) Xanal(Nudge_nlon,Nudge_nlat,Nudge_nlev) + real(r8) PSanal(Nudge_nlon,Nudge_nlat) + real(r8) Lat_anal(Nudge_nlat) + real(r8) Lon_anal(Nudge_nlon) + real(r8) Xtrans(Nudge_nlon,Nudge_nlev,Nudge_nlat) + + ! Check the existence of the analyses file; broadcast the file status to + ! all the other MPI nodes. If the file is not there, then just return. + !------------------------------------------------------------------------ + if(masterproc) then + inquire(FILE=trim(anal_file),EXIST=Nudge_File_Present) + endif +#ifdef SPMD + call mpibcast(Nudge_File_Present, 1, mpilog, 0, mpicom) +#endif + if(.not.Nudge_File_Present) return + + ! masterporc does all of the work here + !----------------------------------------- + if(masterproc) then + + ! Open the given file + !----------------------- + istat=nf90_open(trim(anal_file),NF90_NOWRITE,ncid) + if(istat.ne.NF90_NOERR) then + write(iulog,*)'NF90_OPEN: failed for file ',trim(anal_file) + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_EUL') + endif + + ! Read in Dimensions + !-------------------- +! call wrap_inq_dimid (ncid,'lon',varid) +! call wrap_inq_dimlen(ncid,varid,nlon) + istat=nf90_inq_dimid(ncid,'lon',varid) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_EUL') + endif + istat=nf90_inquire_dimension(ncid,varid,len=nlon) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_EUL') + endif + +! call wrap_inq_dimid (ncid,'lat',varid) +! call wrap_inq_dimlen(ncid,varid,nlat) + istat=nf90_inq_dimid(ncid,'lat',varid) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_EUL') + endif + istat=nf90_inquire_dimension(ncid,varid,len=nlat) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_EUL') + endif + +! call wrap_inq_dimid (ncid,'lev',varid) +! call wrap_inq_dimlen(ncid,varid,plev) + istat=nf90_inq_dimid(ncid,'lev',varid) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_EUL') + endif + istat=nf90_inquire_dimension(ncid,varid,len=plev) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_EUL') + endif + +! call wrap_inq_varid(ncid,'lon',varid) +! call wrap_get_var_realx(ncid,varid,Lon_anal) + istat=nf90_inq_varid(ncid,'lon',varid) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_EUL') + endif + istat=nf90_get_var(ncid,varid,Lon_anal) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_EUL') + endif + +! call wrap_inq_varid(ncid,'lat',varid) +! call wrap_get_var_realx(ncid,varid,Lat_anal) + istat=nf90_inq_varid(ncid,'lat',varid) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_EUL') + endif + istat=nf90_get_var(ncid,varid,Lat_anal) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_EUL') + endif + + if((Nudge_nlon.ne.nlon).or.(Nudge_nlat.ne.nlat).or.(plev.ne.pver)) then + write(iulog,*) 'ERROR: nudging_update_analyses_eul: nlon=',nlon,' Nudge_nlon=',Nudge_nlon + write(iulog,*) 'ERROR: nudging_update_analyses_eul: nlat=',nlat,' Nudge_nlat=',Nudge_nlat + write(iulog,*) 'ERROR: nudging_update_analyses_eul: plev=',plev,' pver=',pver + call endrun('nudging_update_analyses_eul: analyses dimension mismatch') + endif + + ! Read in, transpose lat/lev indices, + ! and scatter data arrays + !---------------------------------- +! call wrap_inq_varid (ncid,'U',varid) +! call wrap_get_var_realx(ncid,varid,Xanal) + istat=nf90_inq_varid(ncid,'U',varid) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_EUL') + endif + istat=nf90_get_var(ncid,varid,Xanal) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_EUL') + endif + do ilat=1,nlat + do ilev=1,plev + do ilon=1,nlon + Xtrans(ilon,ilev,ilat)=Xanal(ilon,ilat,ilev) + end do + end do + end do + endif ! (masterproc) then + call scatter_field_to_chunk(1,Nudge_nlev,1,Nudge_nlon,Xtrans ,Target_U) + + if(masterproc) then +! call wrap_inq_varid (ncid,'V',varid) +! call wrap_get_var_realx(ncid,varid,Xanal) + istat=nf90_inq_varid(ncid,'V',varid) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_EUL') + endif + istat=nf90_get_var(ncid,varid,Xanal) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_EUL') + endif + do ilat=1,nlat + do ilev=1,plev + do ilon=1,nlon + Xtrans(ilon,ilev,ilat)=Xanal(ilon,ilat,ilev) + end do + end do + end do + endif ! (masterproc) then + call scatter_field_to_chunk(1,Nudge_nlev,1,Nudge_nlon,Xtrans ,Target_V) + + if(masterproc) then +! call wrap_inq_varid (ncid,'T',varid) +! call wrap_get_var_realx(ncid,varid,Xanal) + istat=nf90_inq_varid(ncid,'T',varid) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_EUL') + endif + istat=nf90_get_var(ncid,varid,Xanal) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_EUL') + endif + do ilat=1,nlat + do ilev=1,plev + do ilon=1,nlon + Xtrans(ilon,ilev,ilat)=Xanal(ilon,ilat,ilev) + end do + end do + end do + endif ! (masterproc) then + call scatter_field_to_chunk(1,Nudge_nlev,1,Nudge_nlon,Xtrans ,Target_T) + + if(masterproc) then +! call wrap_inq_varid (ncid,'Q',varid) +! call wrap_get_var_realx(ncid,varid,Xanal) + istat=nf90_inq_varid(ncid,'Q',varid) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_EUL') + endif + istat=nf90_get_var(ncid,varid,Xanal) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_EUL') + endif + do ilat=1,nlat + do ilev=1,plev + do ilon=1,nlon + Xtrans(ilon,ilev,ilat)=Xanal(ilon,ilat,ilev) + end do + end do + end do + endif ! (masterproc) then + call scatter_field_to_chunk(1,Nudge_nlev,1,Nudge_nlon,Xtrans ,Target_Q) + + if(masterproc) then +!! call wrap_inq_varid (ncid,'PS',varid) +!! call wrap_get_var_realx(ncid,varid,PSanal) +! istat=nf90_inq_varid(ncid,'PS',varid) +! if(istat.ne.NF90_NOERR) then +! write(iulog,*) nf90_strerror(istat) +! call endrun ('UPDATE_ANALYSES_SE') +! endif +! istat=nf90_get_var(ncid,varid,PSanal) +! if(istat.ne.NF90_NOERR) then +! write(iulog,*) nf90_strerror(istat) +! call endrun ('UPDATE_ANALYSES_SE') +! endif + + ! Close the analyses file + !----------------------- +! call wrap_close(ncid) + istat=nf90_close(ncid) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_EUL') + endif + endif ! (masterproc) then +! call scatter_field_to_chunk(1, 1,1,Nudge_nlon,PSanal,Target_PS) + + ! End Routine + !------------ + return + end subroutine ! nudging_update_analyses_eul + !================================================================ + + + !================================================================ + subroutine nudging_update_analyses_fv(anal_file) + ! + ! NUDGING_UPDATE_ANALYSES_FV: + ! Open the given analyses data file, read in + ! U,V,T,Q, and PS values and then distribute + ! the values to all of the chunks. + !=============================================================== +! use wrap_nf + use ppgrid ,only: pver + use netcdf + + ! Arguments + !------------- + character(len=*),intent(in):: anal_file + + ! Local values + !------------- + integer lev + integer nlon,nlat,plev,istat + integer ncid,varid + integer ilat,ilon,ilev + real(r8) Xanal(Nudge_nlon,Nudge_nlat,Nudge_nlev) + real(r8) PSanal(Nudge_nlon,Nudge_nlat) + real(r8) Lat_anal(Nudge_nlat) + real(r8) Lon_anal(Nudge_nlon) + real(r8) Xtrans(Nudge_nlon,Nudge_nlev,Nudge_nlat) +!DIAG + real(r8) Uanal(Nudge_nlon,Nudge_slat,Nudge_nlev) +!DIAG + + ! Check the existence of the analyses file; broadcast the file status to + ! all the other MPI nodes. If the file is not there, then just return. + !------------------------------------------------------------------------ + if(masterproc) then + inquire(FILE=trim(anal_file),EXIST=Nudge_File_Present) + endif +#ifdef SPMD + call mpibcast(Nudge_File_Present, 1, mpilog, 0, mpicom) +#endif + if(.not.Nudge_File_Present) return + + ! masterporc does all of the work here + !----------------------------------------- + if(masterproc) then + + ! Open the given file + !----------------------- + istat=nf90_open(trim(anal_file),NF90_NOWRITE,ncid) + if(istat.ne.NF90_NOERR) then + write(iulog,*)'NF90_OPEN: failed for file ',trim(anal_file) + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_FV') + endif + + ! Read in Dimensions + !-------------------- +! call wrap_inq_dimid (ncid,'lon',varid) +! call wrap_inq_dimlen(ncid,varid,nlon) + istat=nf90_inq_dimid(ncid,'lon',varid) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_FV') + endif + istat=nf90_inquire_dimension(ncid,varid,len=nlon) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_FV') + endif + +! call wrap_inq_dimid (ncid,'lat',varid) +! call wrap_inq_dimlen(ncid,varid,nlat) + istat=nf90_inq_dimid(ncid,'lat',varid) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_FV') + endif + istat=nf90_inquire_dimension(ncid,varid,len=nlat) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_FV') + endif + +! call wrap_inq_dimid (ncid,'lev',varid) +! call wrap_inq_dimlen(ncid,varid,plev) + istat=nf90_inq_dimid(ncid,'lev',varid) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_FV') + endif + istat=nf90_inquire_dimension(ncid,varid,len=plev) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_FV') + endif + +! call wrap_inq_varid(ncid,'lon',varid) +! call wrap_get_var_realx(ncid,varid,Lon_anal) + istat=nf90_inq_varid(ncid,'lon',varid) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_FV') + endif + istat=nf90_get_var(ncid,varid,Lon_anal) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_FV') + endif + +! call wrap_inq_varid(ncid,'lat',varid) +! call wrap_get_var_realx(ncid,varid,Lat_anal) + istat=nf90_inq_varid(ncid,'lat',varid) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_FV') + endif + istat=nf90_get_var(ncid,varid,Lat_anal) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_FV') + endif + + if((Nudge_nlon.ne.nlon).or.(Nudge_nlat.ne.nlat).or.(plev.ne.pver)) then + write(iulog,*) 'ERROR: nudging_update_analyses_fv: nlon=',nlon,' Nudge_nlon=',Nudge_nlon + write(iulog,*) 'ERROR: nudging_update_analyses_fv: nlat=',nlat,' Nudge_nlat=',Nudge_nlat + write(iulog,*) 'ERROR: nudging_update_analyses_fv: plev=',plev,' pver=',pver + call endrun('nudging_update_analyses_fv: analyses dimension mismatch') + endif + + ! Read in, transpose lat/lev indices, + ! and scatter data arrays + !---------------------------------- +!DIAG: Dont have U, so jam US into U so tests can proceed: +!DIAG call wrap_inq_varid (ncid,'U',varid) +!DIAG call wrap_get_var_realx(ncid,varid,Xanal) +!DIAG do ilat=1,nlat +!DIAG do ilev=1,plev +!DIAG do ilon=1,nlon +!DIAG Xtrans(ilon,ilev,ilat)=Xanal(ilon,ilat,ilev) +!DIAG end do +!DIAG end do +!DIAG end do +! call wrap_inq_varid (ncid,'US',varid) +! call wrap_get_var_realx(ncid,varid,Uanal) + istat=nf90_inq_varid(ncid,'US',varid) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_FV') + endif + istat=nf90_get_var(ncid,varid,Uanal) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_FV') + endif + do ilat=1,(nlat-1) + do ilev=1,plev + do ilon=1,nlon + Xtrans(ilon,ilev,ilat)=Uanal(ilon,ilat,ilev) + end do + end do + end do + Xtrans(:,:,ilat)=Xtrans(:,:,ilat-1) + endif ! (masterproc) then + call scatter_field_to_chunk(1,Nudge_nlev,1,Nudge_nlon,Xtrans ,Target_U) + + if(masterproc) then +!DIAG: Dont have V, so jam VS into V so tests can proceed: +!DIAG call wrap_inq_varid (ncid,'V',varid) +!DIAG call wrap_get_var_realx(ncid,varid,Xanal) +!DIAG do ilat=1,nlat +!DIAG do ilev=1,plev +!DIAG do ilon=1,nlon +!DIAG Xtrans(ilon,ilev,ilat)=Xanal(ilon,ilat,ilev) +!DIAG end do +!DIAG end do +!DIAG end do +! call wrap_inq_varid (ncid,'VS',varid) +! call wrap_get_var_realx(ncid,varid,Xanal) + istat=nf90_inq_varid(ncid,'VS',varid) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_FV') + endif + istat=nf90_get_var(ncid,varid,Xanal) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_FV') + endif + do ilat=1,nlat + do ilev=1,plev + do ilon=1,nlon + Xtrans(ilon,ilev,ilat)=Xanal(ilon,ilat,ilev) + end do + end do + end do + endif ! (masterproc) then + call scatter_field_to_chunk(1,Nudge_nlev,1,Nudge_nlon,Xtrans ,Target_V) + + if(masterproc) then +! call wrap_inq_varid (ncid,'T',varid) +! call wrap_get_var_realx(ncid,varid,Xanal) + istat=nf90_inq_varid(ncid,'T',varid) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_FV') + endif + istat=nf90_get_var(ncid,varid,Xanal) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_FV') + endif + do ilat=1,nlat + do ilev=1,plev + do ilon=1,nlon + Xtrans(ilon,ilev,ilat)=Xanal(ilon,ilat,ilev) + end do + end do + end do + endif ! (masterproc) then + call scatter_field_to_chunk(1,Nudge_nlev,1,Nudge_nlon,Xtrans ,Target_T) + + if(masterproc) then +! call wrap_inq_varid (ncid,'Q',varid) +! call wrap_get_var_realx(ncid,varid,Xanal) + istat=nf90_inq_varid(ncid,'Q',varid) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_FV') + endif + istat=nf90_get_var(ncid,varid,Xanal) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_FV') + endif + do ilat=1,nlat + do ilev=1,plev + do ilon=1,nlon + Xtrans(ilon,ilev,ilat)=Xanal(ilon,ilat,ilev) + end do + end do + end do + endif ! (masterproc) then + call scatter_field_to_chunk(1,Nudge_nlev,1,Nudge_nlon,Xtrans ,Target_Q) + + if(masterproc) then +!! call wrap_inq_varid (ncid,'PS',varid) +!! call wrap_get_var_realx(ncid,varid,PSanal) +! istat=nf90_inq_varid(ncid,'PS',varid) +! if(istat.ne.NF90_NOERR) then +! write(iulog,*) nf90_strerror(istat) +! call endrun ('UPDATE_ANALYSES_SE') +! endif +! istat=nf90_get_var(ncid,varid,PSanal) +! if(istat.ne.NF90_NOERR) then +! write(iulog,*) nf90_strerror(istat) +! call endrun ('UPDATE_ANALYSES_SE') +! endif + + ! Close the analyses file + !----------------------- +! call wrap_close(ncid) + istat=nf90_close(ncid) + if(istat.ne.NF90_NOERR) then + write(iulog,*) nf90_strerror(istat) + call endrun ('UPDATE_ANALYSES_EUL') + endif + endif ! (masterproc) then +! call scatter_field_to_chunk(1, 1,1,Nudge_nlon,PSanal,Target_PS) + + ! End Routine + !------------ + return + end subroutine ! nudging_update_analyses_fv + !================================================================ + + + !================================================================ + subroutine nudging_set_profile(rlat,rlon,Nudge_prof,Wprof,nlev) + ! + ! NUDGING_SET_PROFILE: for the given lat,lon, and Nudging_prof, set + ! the verical profile of window coeffcients. + ! Values range from 0. to 1. to affect spatial + ! variations on nudging strength. + !=============================================================== + + ! Arguments + !-------------- + integer nlev,Nudge_prof + real(r8) rlat,rlon + real(r8) Wprof(nlev) + + ! Local values + !---------------- + integer ilev + real(r8) Hcoef,latx,lonx,Vmax,Vmin + real(r8) lon_lo,lon_hi,lat_lo,lat_hi,lev_lo,lev_hi + + !--------------- + ! set coeffcient + !--------------- + if(Nudge_prof.eq.0) then + ! No Nudging + !------------- + Wprof(:)=0.0 + elseif(Nudge_prof.eq.1) then + ! Uniform Nudging + !----------------- + Wprof(:)=1.0 + elseif(Nudge_prof.eq.2) then + ! Localized Nudging with specified Heaviside window function + !------------------------------------------------------------ + if(Nudge_Hwin_max.le.Nudge_Hwin_min) then + ! For a constant Horizontal window function, + ! just set Hcoef to the maximum of Hlo/Hhi. + !-------------------------------------------- + Hcoef=max(Nudge_Hwin_lo,Nudge_Hwin_hi) + else + ! get lat/lon relative to window center + !------------------------------------------ + latx=rlat-Nudge_Hwin_lat0 + lonx=rlon-Nudge_Hwin_lon0 + if(lonx.gt. 180.) lonx=lonx-360. + if(lonx.le.-180.) lonx=lonx+360. + + ! Calcualte RAW window value + !------------------------------- + lon_lo=(Nudge_Hwin_lonWidthH+lonx)/Nudge_Hwin_lonDelta + lon_hi=(Nudge_Hwin_lonWidthH-lonx)/Nudge_Hwin_lonDelta + lat_lo=(Nudge_Hwin_latWidthH+latx)/Nudge_Hwin_latDelta + lat_hi=(Nudge_Hwin_latWidthH-latx)/Nudge_Hwin_latDelta + Hcoef=((1.+tanh(lon_lo))/2.)*((1.+tanh(lon_hi))/2.) & + *((1.+tanh(lat_lo))/2.)*((1.+tanh(lat_hi))/2.) + + ! Scale the horizontal window coef for specfied range of values. + !-------------------------------------------------------- + Hcoef=(Hcoef-Nudge_Hwin_min)/(Nudge_Hwin_max-Nudge_Hwin_min) + Hcoef=(1.-Hcoef)*Nudge_Hwin_lo + Hcoef*Nudge_Hwin_hi + endif + + ! Load the RAW vertical window + !------------------------------ + do ilev=1,nlev + lev_lo=(float(ilev)-Nudge_Vwin_Lindex)/Nudge_Vwin_Ldelta + lev_hi=(Nudge_Vwin_Hindex-float(ilev))/Nudge_Vwin_Hdelta + Wprof(ilev)=((1.+tanh(lev_lo))/2.)*((1.+tanh(lev_hi))/2.) + end do + + ! Scale the Window function to span the values between Vlo and Vhi: + !----------------------------------------------------------------- + Vmax=maxval(Wprof) + Vmin=minval(Wprof) + if(Vmax.le.Vmin) then + ! For a constant Vertical window function, + ! load maximum of Vlo/Vhi into Wprof() + !-------------------------------------------- + Vmax=max(Nudge_Vwin_lo,Nudge_Vwin_hi) + Wprof(:)=Vmax + else + ! Scale the RAW vertical window for specfied range of values. + !-------------------------------------------------------- + Wprof(:)=(Wprof(:)-Vmin)/(Vmax-Vmin) + Wprof(:)=Nudge_Vwin_lo + Wprof(:)*(Nudge_Vwin_hi-Nudge_Vwin_lo) + endif + + ! The desired result is the product of the vertical profile + ! and the horizontal window coeffcient. + !---------------------------------------------------- + Wprof(:)=Hcoef*Wprof(:) + else + call endrun('nudging_set_profile:: Unknown Nudge_prof value') + endif + + ! End Routine + !------------ + return + end subroutine ! nudging_set_profile + !================================================================ + + !================================================================ + real(r8) function nudging_set_PSprofile(rlat,rlon,Nudge_PSprof) + ! + ! NUDGING_SET_PSPROFILE: for the given lat and lon set the surface + ! pressure profile value for the specified index. + ! Values range from 0. to 1. to affect spatial + ! variations on nudging strength. + !=============================================================== + + ! Arguments + !-------------- + real(r8) rlat,rlon + integer Nudge_PSprof + + ! Local values + !---------------- + + !--------------- + ! set coeffcient + !--------------- + if(Nudge_PSprof.eq.0) then + ! No Nudging + !------------- + nudging_set_PSprofile=0.0 + elseif(Nudge_PSprof.eq.1) then + ! Uniform Nudging + !----------------- + nudging_set_PSprofile=1.0 + else + call endrun('nudging_set_PSprofile:: Unknown Nudge_prof value') + endif + + ! End Routine + !------------ + return + end function ! nudging_set_PSprofile + !================================================================ + +end module nudging diff --git a/models/atm/cam/src/physics/cam/phys_control.F90 b/models/atm/cam/src/physics/cam/phys_control.F90 index 5cf12c1b6393..065e255d61bf 100644 --- a/models/atm/cam/src/physics/cam/phys_control.F90 +++ b/models/atm/cam/src/physics/cam/phys_control.F90 @@ -66,13 +66,20 @@ module phys_control ! liquid budgets. integer :: history_budget_histfile_num = 1 ! output history file number for budget fields logical :: history_waccm = .true. ! output variables of interest for WACCM runs +logical :: history_clubb = .true. ! output default CLUBB-related variables logical :: do_clubb_sgs logical :: do_tms +logical :: micro_do_icesupersat logical :: state_debug_checks = .false. ! Extra checks for validity of physics_state objects ! in physics_update. +! Macro/micro-physics co-substeps +integer :: cld_macmic_num_steps = 1 logical :: prog_modal_aero ! determines whether prognostic modal aerosols are present in the run. +! Option to use heterogeneous freezing +logical, public, protected :: use_hetfrz_classnuc = .false. + ! Which gravity wave sources are used? ! Orographic logical, public, protected :: use_gw_oro = .true. @@ -101,8 +108,9 @@ subroutine phys_ctl_readnl(nlfile) eddy_scheme, microp_scheme, macrop_scheme, radiation_scheme, srf_flux_avg, & use_subcol_microp, atm_dep_flux, history_amwg, history_vdiag, history_aerosol, history_aero_optics, & history_eddy, history_budget, history_budget_histfile_num, history_waccm, & - conv_water_in_rad, do_clubb_sgs, do_tms, state_debug_checks, & - use_gw_oro, use_gw_front, use_gw_convect + conv_water_in_rad, history_clubb, do_clubb_sgs, do_tms, state_debug_checks, & + use_hetfrz_classnuc, use_gw_oro, use_gw_front, use_gw_convect, & + cld_macmic_num_steps, micro_do_icesupersat !----------------------------------------------------------------------------- if (masterproc) then @@ -141,13 +149,17 @@ subroutine phys_ctl_readnl(nlfile) call mpibcast(history_budget, 1 , mpilog, 0, mpicom) call mpibcast(history_budget_histfile_num, 1 , mpiint, 0, mpicom) call mpibcast(history_waccm, 1 , mpilog, 0, mpicom) + call mpibcast(history_clubb, 1 , mpilog, 0, mpicom) call mpibcast(do_clubb_sgs, 1 , mpilog, 0, mpicom) call mpibcast(conv_water_in_rad, 1 , mpiint, 0, mpicom) call mpibcast(do_tms, 1 , mpilog, 0, mpicom) + call mpibcast(micro_do_icesupersat, 1 , mpilog, 0, mpicom) call mpibcast(state_debug_checks, 1 , mpilog, 0, mpicom) + call mpibcast(use_hetfrz_classnuc, 1 , mpilog, 0, mpicom) call mpibcast(use_gw_oro, 1 , mpilog, 0, mpicom) call mpibcast(use_gw_front, 1 , mpilog, 0, mpicom) call mpibcast(use_gw_convect, 1 , mpilog, 0, mpicom) + call mpibcast(cld_macmic_num_steps, 1 , mpiint, 0, mpicom) #endif ! Error checking: @@ -204,8 +216,14 @@ subroutine phys_ctl_readnl(nlfile) call endrun('CLUBB and eddy, macrop or shallow schemes incompatible') endif endif - + ! Macro/micro co-substepping support. + if (cld_macmic_num_steps > 1) then + if (microp_scheme /= "MG" .or. (macrop_scheme /= "park" .and. macrop_scheme /= "CLUBB_SGS")) then + call endrun ("Setting cld_macmic_num_steps > 1 is only & + &supported with Park or CLUBB macrophysics and MG microphysics.") + end if + end if ! prog_modal_aero determines whether prognostic modal aerosols are present in the run. prog_modal_aero = ( cam_chempkg_is('trop_mam3') & @@ -256,8 +274,9 @@ subroutine phys_getopts(deep_scheme_out, shallow_scheme_out, eddy_scheme_out, mi radiation_scheme_out, use_subcol_microp_out, atm_dep_flux_out, & history_amwg_out, history_vdiag_out, history_aerosol_out, history_aero_optics_out, history_eddy_out, & history_budget_out, history_budget_histfile_num_out, history_waccm_out, & - conv_water_in_rad_out, cam_chempkg_out, prog_modal_aero_out, macrop_scheme_out, & - do_clubb_sgs_out, do_tms_out, state_debug_checks_out ) + history_clubb_out, conv_water_in_rad_out, cam_chempkg_out, prog_modal_aero_out, macrop_scheme_out, & + do_clubb_sgs_out, do_tms_out, state_debug_checks_out, & + cld_macmic_num_steps_out, micro_do_icesupersat_out) !----------------------------------------------------------------------- ! Purpose: Return runtime settings ! deep_scheme_out : deep convection scheme @@ -283,12 +302,15 @@ subroutine phys_getopts(deep_scheme_out, shallow_scheme_out, eddy_scheme_out, mi logical, intent(out), optional :: history_budget_out integer, intent(out), optional :: history_budget_histfile_num_out logical, intent(out), optional :: history_waccm_out + logical, intent(out), optional :: history_clubb_out logical, intent(out), optional :: do_clubb_sgs_out + logical, intent(out), optional :: micro_do_icesupersat_out integer, intent(out), optional :: conv_water_in_rad_out character(len=32), intent(out), optional :: cam_chempkg_out logical, intent(out), optional :: prog_modal_aero_out logical, intent(out), optional :: do_tms_out logical, intent(out), optional :: state_debug_checks_out + integer, intent(out), optional :: cld_macmic_num_steps_out if ( present(deep_scheme_out ) ) deep_scheme_out = deep_scheme if ( present(shallow_scheme_out ) ) shallow_scheme_out = shallow_scheme @@ -307,12 +329,15 @@ subroutine phys_getopts(deep_scheme_out, shallow_scheme_out, eddy_scheme_out, mi if ( present(history_eddy_out ) ) history_eddy_out = history_eddy if ( present(history_budget_histfile_num_out ) ) history_budget_histfile_num_out = history_budget_histfile_num if ( present(history_waccm_out ) ) history_waccm_out = history_waccm + if ( present(history_clubb_out ) ) history_clubb_out = history_clubb if ( present(do_clubb_sgs_out ) ) do_clubb_sgs_out = do_clubb_sgs + if ( present(micro_do_icesupersat_out )) micro_do_icesupersat_out = micro_do_icesupersat if ( present(conv_water_in_rad_out ) ) conv_water_in_rad_out = conv_water_in_rad if ( present(cam_chempkg_out ) ) cam_chempkg_out = cam_chempkg if ( present(prog_modal_aero_out ) ) prog_modal_aero_out = prog_modal_aero if ( present(do_tms_out ) ) do_tms_out = do_tms if ( present(state_debug_checks_out ) ) state_debug_checks_out = state_debug_checks + if ( present(cld_macmic_num_steps_out) ) cld_macmic_num_steps_out = cld_macmic_num_steps end subroutine phys_getopts diff --git a/models/atm/cam/src/physics/cam/physics_types.F90 b/models/atm/cam/src/physics/cam/physics_types.F90 index 4d0eea0806fd..22dcfc50b6df 100644 --- a/models/atm/cam/src/physics/cam/physics_types.F90 +++ b/models/atm/cam/src/physics/cam/physics_types.F90 @@ -38,6 +38,7 @@ module physics_types public physics_state_copy ! copy a physics_state object public physics_ptend_copy ! copy a physics_ptend object public physics_ptend_sum ! accumulate physics_ptend objects + public physics_ptend_scale ! Multiply physics_ptend objects by a constant factor. public physics_tend_init ! initialize a physics_tend object public set_state_pdry ! calculate dry air masses in state variable @@ -224,6 +225,7 @@ subroutine physics_update(state, ptend, dt, tend) integer :: i,k,m ! column,level,constituent indices integer :: ixcldice, ixcldliq ! indices for CLDICE and CLDLIQ integer :: ixnumice, ixnumliq + integer :: ixnumsnow, ixnumrain integer :: ncol ! number of columns character*40 :: name ! param and tracer name for qneg3 @@ -325,6 +327,8 @@ subroutine physics_update(state, ptend, dt, tend) ! the indices will be set to -1) call cnst_get_ind('NUMICE', ixnumice, abort=.false.) call cnst_get_ind('NUMLIQ', ixnumliq, abort=.false.) + call cnst_get_ind('NUMRAI', ixnumrain, abort=.false.) + call cnst_get_ind('NUMSNO', ixnumsnow, abort=.false.) do m = 1, pcnst if(ptend%lq(m)) then @@ -334,7 +338,8 @@ subroutine physics_update(state, ptend, dt, tend) ! now test for mixing ratios which are too small ! don't call qneg3 for number concentration variables - if (m /= ixnumice .and. m /= ixnumliq) then + if (m /= ixnumice .and. m /= ixnumliq .and. & + m /= ixnumrain .and. m /= ixnumsnow ) then name = trim(ptend%name) // '/' // trim(cnst_name(m)) call qneg3(trim(name), state%lchnk, ncol, state%psetcols, pver, m, m, qmin(m), state%q(1,1,m)) else @@ -817,6 +822,69 @@ subroutine physics_ptend_sum(ptend, ptend_sum, ncol) end subroutine physics_ptend_sum +!=============================================================================== + + subroutine physics_ptend_scale(ptend, fac, ncol) +!----------------------------------------------------------------------- +! Scale ptend fields for ptend logical flags = .true. +! Where ptend logical flags = .false, don't change ptend. +! +! Assumes that input ptend is valid (e.g. that +! ptend%lu .eqv. allocated(ptend%u)), and therefore +! does not check allocation status of individual arrays. +!----------------------------------------------------------------------- + +!------------------------------Arguments-------------------------------- + type(physics_ptend), intent(inout) :: ptend ! Incoming ptend + real(r8), intent(in) :: fac ! Factor to multiply ptend by. + integer, intent(in) :: ncol ! number of columns + +!---------------------------Local storage------------------------------- + integer :: m ! constituent index + +!----------------------------------------------------------------------- + +! Update u,v fields + if (ptend%lu) & + call multiply_tendency(ptend%u, & + ptend%taux_srf, ptend%taux_top) + + if (ptend%lv) & + call multiply_tendency(ptend%v, & + ptend%tauy_srf, ptend%tauy_top) + +! Heat + if (ptend%ls) & + call multiply_tendency(ptend%s, & + ptend%hflux_srf, ptend%hflux_top) + +! Update constituents + do m = 1, pcnst + if (ptend%lq(m)) & + call multiply_tendency(ptend%q(:,:,m), & + ptend%cflx_srf(:,m), ptend%cflx_top(:,m)) + end do + + + contains + + subroutine multiply_tendency(tend_arr, flx_srf, flx_top) + real(r8), intent(inout) :: tend_arr(:,:) ! Tendency array (pcols, plev) + real(r8), intent(inout) :: flx_srf(:) ! Surface flux (or stress) + real(r8), intent(inout) :: flx_top(:) ! Top-of-model flux (or stress) + + integer :: k + + do k = ptend%top_level, ptend%bot_level + tend_arr(:ncol,k) = tend_arr(:ncol,k) * fac + end do + flx_srf(:ncol) = flx_srf(:ncol) * fac + flx_top(:ncol) = flx_top(:ncol) * fac + + end subroutine multiply_tendency + + end subroutine physics_ptend_scale + !=============================================================================== subroutine physics_ptend_copy(ptend, ptend_cp) @@ -1666,6 +1734,9 @@ subroutine physics_state_dealloc(state) deallocate(state%lonmapback, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lonmapback') + deallocate(state%cid, stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%cid') + end subroutine physics_state_dealloc !=============================================================================== diff --git a/models/atm/cam/src/physics/cam/physpkg.F90 b/models/atm/cam/src/physics/cam/physpkg.F90 index 728f0b558c97..dff74353705b 100644 --- a/models/atm/cam/src/physics/cam/physpkg.F90 +++ b/models/atm/cam/src/physics/cam/physpkg.F90 @@ -26,7 +26,8 @@ module physpkg use camsrfexch, only: cam_out_t, cam_in_t use cam_control_mod, only: ideal_phys, adiabatic - use phys_control, only: phys_do_flux_avg, waccmx_is + use phys_control, only: phys_do_flux_avg, phys_getopts, waccmx_is + use zm_conv, only: trigmem use scamMod, only: single_column, scm_crm_mode use flux_avg, only: flux_avg_init use infnan, only: posinf, assignment(=) @@ -73,8 +74,17 @@ module physpkg ! ! Private module data ! - logical :: clim_modal_aero ! climate controled by prognostic or prescribed modal aerosols - logical :: prog_modal_aero ! Prognostic modal aerosols present + ! Physics package options + character(len=16) :: shallow_scheme + character(len=16) :: macrop_scheme + character(len=16) :: microp_scheme + integer :: cld_macmic_num_steps ! Number of macro/micro substeps + logical :: do_clubb_sgs + logical :: use_subcol_microp ! if true, use subcolumns in microphysics + logical :: state_debug_checks ! Debug physics_state. + logical :: clim_modal_aero ! climate controled by prognostic or prescribed modal aerosols + logical :: prog_modal_aero ! Prognostic modal aerosols present + logical :: micro_do_icesupersat !======================================================================= contains @@ -96,7 +106,6 @@ subroutine phys_register use constituents, only: pcnst, cnst_add, cnst_chk_dim, cnst_name use cam_control_mod, only: moist_physics - use phys_control, only: phys_do_flux_avg, phys_getopts, waccmx_is use chemistry, only: chem_register use cloud_fraction, only: cldfrc_register use stratiform, only: stratiform_register @@ -134,21 +143,22 @@ subroutine phys_register use subcol, only: subcol_register use subcol_utils, only: is_subcol_on - - implicit none !---------------------------Local variables----------------------------- ! integer :: m ! loop index integer :: mm ! constituent index !----------------------------------------------------------------------- - character(len=16) :: microp_scheme - logical :: do_clubb_sgs - integer :: nmodes - call phys_getopts( microp_scheme_out = microp_scheme ) - call phys_getopts( do_clubb_sgs_out = do_clubb_sgs ) + call phys_getopts(shallow_scheme_out = shallow_scheme, & + macrop_scheme_out = macrop_scheme, & + microp_scheme_out = microp_scheme, & + cld_macmic_num_steps_out = cld_macmic_num_steps, & + do_clubb_sgs_out = do_clubb_sgs, & + use_subcol_microp_out = use_subcol_microp, & + state_debug_checks_out = state_debug_checks, & + micro_do_icesupersat_out = micro_do_icesupersat) ! Initialize dyn_time_lvls call pbuf_init_time() @@ -641,6 +651,7 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_out ) use aircraft_emit, only: aircraft_emit_init use prescribed_volcaero,only: prescribed_volcaero_init use cloud_fraction, only: cldfrc_init + use cldfrc2m, only: cldfrc2m_init use co2_cycle, only: co2_init, co2_transport use convect_deep, only: convect_deep_init use convect_shallow, only: convect_shallow_init @@ -652,7 +663,6 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_out ) use radiation, only: radiation_init use cloud_diagnostics, only: cloud_diagnostics_init use stratiform, only: stratiform_init - use phys_control, only: phys_getopts, waccmx_is use wv_saturation, only: wv_sat_init use microp_driver, only: microp_driver_init use microp_aero, only: microp_aero_init @@ -680,6 +690,7 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_out ) use tropopause, only: tropopause_init use solar_data, only: solar_data_init use rad_solar_var, only: rad_solar_var_init + use nudging, only: Nudge_Model,nudging_init ! Input/output arguments type(physics_state), pointer :: phys_state(:) @@ -691,15 +702,8 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_out ) ! local variables integer :: lchnk - character(len=16) :: microp_scheme - logical :: do_clubb_sgs - !----------------------------------------------------------------------- - ! Get microphysics option - call phys_getopts(microp_scheme_out = microp_scheme) - call phys_getopts(do_clubb_sgs_out = do_clubb_sgs ) - call physics_type_alloc(phys_state, phys_tend, begchunk, endchunk, pcols) do lchnk = begchunk, endchunk @@ -804,14 +808,15 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_out ) call convect_shallow_init(pref_edge) - call cldfrc_init + call cldfrc_init() + call cldfrc2m_init() call convect_deep_init(pref_edge) if( microp_scheme == 'RK' ) then call stratiform_init() elseif( microp_scheme == 'MG' ) then - if (.not. do_clubb_sgs) call macrop_driver_init() + if (.not. do_clubb_sgs) call macrop_driver_init(pbuf2d) call microp_aero_init() call microp_driver_init(pbuf2d) call conv_water_init @@ -852,6 +857,10 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_out ) end if + ! Initialize Nudging Parameters + !-------------------------------- + if(Nudge_Model) call nudging_init + end subroutine phys_init ! @@ -1249,7 +1258,6 @@ subroutine tphysac (ztodt, cam_in, & physics_dme_adjust, set_dry_to_wet, physics_state_check use majorsp_diffusion, only: mspd_intr ! WACCM-X major diffusion use ionosphere, only: ionos_intr ! WACCM-X ionosphere - use phys_control, only: phys_getopts use tracers, only: tracers_timestep_tend use aoa_tracers, only: aoa_tracers_timestep_tend use physconst, only: rhoh2o, latvap,latice @@ -1269,10 +1277,8 @@ subroutine tphysac (ztodt, cam_in, & use iondrag, only: iondrag_calc, do_waccm_ions use clubb_intr, only: clubb_surface use perf_mod - use phys_control, only: phys_do_flux_avg, waccmx_is use flux_avg, only: flux_avg_run - - implicit none + use nudging, only: Nudge_Model,Nudge_ON,nudging_timestep_tend ! ! Arguments @@ -1328,10 +1334,6 @@ subroutine tphysac (ztodt, cam_in, & real(r8), pointer, dimension(:,:) :: dtcore real(r8), pointer, dimension(:,:) :: ast ! relative humidity cloud fraction - logical :: do_clubb_sgs - - ! Debug physics_state. - logical :: state_debug_checks ! !----------------------------------------------------------------------- ! @@ -1340,9 +1342,6 @@ subroutine tphysac (ztodt, cam_in, & nstep = get_nstep() - call phys_getopts( do_clubb_sgs_out = do_clubb_sgs, & - state_debug_checks_out = state_debug_checks) - ! Adjust the surface fluxes to reduce instabilities in near sfc layer if (phys_do_flux_avg()) then call flux_avg_run(state, cam_in, pbuf, nstep, ztodt) @@ -1595,6 +1594,13 @@ subroutine tphysac (ztodt, cam_in, & endif endif + !=================================================== + ! Update Nudging values, if needed + !=================================================== + if((Nudge_Model).and.(Nudge_ON)) then + call nudging_timestep_tend(state,ptend) + call physics_update(state,ptend,ztodt,tend) + endif call diag_phys_tend_writeout (state, pbuf, tend, ztodt, tmp_q, tmp_cldliq, tmp_cldice, & tmp_t, qini, cldliqini, cldiceini) @@ -1639,12 +1645,11 @@ subroutine tphysbc (ztodt, & use shr_kind_mod, only: r8 => shr_kind_r8 use stratiform, only: stratiform_tend - use phys_control, only: phys_getopts use microp_driver, only: microp_driver_tend use microp_aero, only: microp_aero_run use macrop_driver, only: macrop_driver_tend use physics_types, only: physics_state, physics_tend, physics_ptend, physics_update, & - physics_ptend_init, physics_ptend_sum, physics_state_check + physics_ptend_init, physics_ptend_sum, physics_state_check, physics_ptend_scale use cam_diagnostics, only: diag_conv_tend_ini, diag_phys_writeout, diag_conv, diag_export, diag_state_b4_phys_write use cam_history, only: outfld use physconst, only: cpair, latvap @@ -1723,11 +1728,19 @@ subroutine tphysbc (ztodt, & integer i,k,m ! Longitude, level, constituent indices integer :: ixcldice, ixcldliq ! constituent indices for cloud liquid and ice water. + ! for macro/micro co-substepping + integer :: macmic_it ! iteration variables + real(r8) :: cld_macmic_ztodt ! modified timestep ! physics buffer fields to compute tendencies for stratiform package integer itim_old, ifld real(r8), pointer, dimension(:,:) :: cld ! cloud fraction +!songxl 2011-09-20---------------------------- ! physics buffer fields for total energy and mass adjustment real(r8), pointer, dimension(: ) :: teout @@ -1759,6 +1772,12 @@ subroutine tphysbc (ztodt, & real(r8),pointer :: prec_sed(:) ! total precip from cloud sedimentation real(r8),pointer :: snow_sed(:) ! snow from cloud ice sedimentation + ! Local copies for substepping + real(r8) :: prec_pcw_macmic(pcols) + real(r8) :: snow_pcw_macmic(pcols) + real(r8) :: prec_sed_macmic(pcols) + real(r8) :: snow_sed_macmic(pcols) + ! energy checking variables real(r8) :: zero(pcols) ! array of zeros real(r8) :: zero_sc(pcols*psubcols) ! array of zeros @@ -1772,20 +1791,7 @@ subroutine tphysbc (ztodt, & real(r8) :: zero_tracers(pcols,pcnst) logical :: lq(pcnst) - logical :: use_subcol_microp ! if true, use subcolumns in microphysics - - ! pass macro to micro - character(len=16) :: microp_scheme - character(len=16) :: macrop_scheme - - ! Debug physics_state. - logical :: state_debug_checks - call phys_getopts( microp_scheme_out = microp_scheme, & - macrop_scheme_out = macrop_scheme, & - use_subcol_microp_out = use_subcol_microp, & - state_debug_checks_out = state_debug_checks) - !----------------------------------------------------------------------- call t_startf('bc_init') @@ -1806,6 +1812,15 @@ subroutine tphysbc (ztodt, & ifld = pbuf_get_index('CLD') call pbuf_get_field(pbuf, ifld, cld, (/1,1,itim_old/),(/pcols,pver,1/)) +!songxl 2011-09-20--------------------------- + call pbuf_get_field(pbuf, teout_idx, teout, (/1,itim_old/), (/pcols,1/)) call pbuf_get_field(pbuf, tini_idx, tini) @@ -1944,6 +1959,8 @@ subroutine tphysbc (ztodt, & call pbuf_get_field(pbuf, snow_str_idx, snow_str) call pbuf_get_field(pbuf, prec_sed_idx, prec_sed) call pbuf_get_field(pbuf, snow_sed_idx, snow_sed) + call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw ) + call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw ) if (use_subcol_microp) then call pbuf_get_field(pbuf, prec_str_idx, prec_str_sc, col_type=col_type_subcol) @@ -2028,107 +2045,179 @@ subroutine tphysbc (ztodt, & call t_stopf('stratiform_tend') elseif( microp_scheme == 'MG' ) then - - !=================================================== - ! Calculate macrophysical tendency (sedimentation, detrain, cloud fraction) - !=================================================== - - call t_startf('macrop_tend') - - ! don't call Park macrophysics if CLUBB is called - if (macrop_scheme .ne. 'CLUBB_SGS') then - - call macrop_driver_tend(state, ptend, ztodt, & - cam_in%landfrac, cam_in%ocnfrac, & - cam_in%snowhland, & ! sediment - dlf, dlf2, & ! detrain - cmfmc, cmfmc2, & - cam_in%ts, cam_in%sst, zdu, pbuf, & - det_s, det_ice) - - ! Since we "added" the reserved liquid back in this routine, we need - ! to account for it in the energy checker - flx_cnd(:ncol) = -1._r8*rliq(:ncol) - flx_heat(:ncol) = det_s(:ncol) - - call physics_update(state, ptend, ztodt, tend) - call check_energy_chng(state, tend, "macrop_tend", nstep, ztodt, zero, flx_cnd, det_ice, flx_heat) + ! Start co-substepping of macrophysics and microphysics + cld_macmic_ztodt = ztodt/cld_macmic_num_steps + + ! Clear precip fields that should accumulate. + prec_sed_macmic = 0._r8 + snow_sed_macmic = 0._r8 + prec_pcw_macmic = 0._r8 + snow_pcw_macmic = 0._r8 + + do macmic_it = 1, cld_macmic_num_steps + + if (micro_do_icesupersat) then + + !=================================================== + ! Aerosol Activation + !=================================================== + call t_startf('microp_aero_run') + call microp_aero_run(state, ptend, cld_macmic_ztodt, pbuf) + call t_stopf('microp_aero_run') + + call physics_ptend_scale(ptend, 1._r8/cld_macmic_num_steps, ncol) + + call physics_update(state, ptend, ztodt, tend) + call check_energy_chng(state, tend, "mp_aero_tend", nstep, ztodt, zero, zero, zero, zero) + + endif + !=================================================== + ! Calculate macrophysical tendency (sedimentation, detrain, cloud fraction) + !=================================================== + + call t_startf('macrop_tend') + + ! don't call Park macrophysics if CLUBB is called + if (macrop_scheme .ne. 'CLUBB_SGS') then + + call macrop_driver_tend( & + state, ptend, cld_macmic_ztodt, & + cam_in%landfrac, cam_in%ocnfrac, cam_in%snowhland, & ! sediment + dlf, dlf2, & ! detrain + cmfmc, cmfmc2, & + cam_in%ts, cam_in%sst, zdu, & + pbuf, det_s, det_ice) + + ! Since we "added" the reserved liquid back in this routine, we need + ! to account for it in the energy checker + flx_cnd(:ncol) = -1._r8*rliq(:ncol) + flx_heat(:ncol) = det_s(:ncol) + + ! Unfortunately, physics_update does not know what time period + ! "tend" is supposed to cover, and therefore can't update it + ! with substeps correctly. For now, work around this by scaling + ! ptend down by the number of substeps, then applying it for + ! the full time (ztodt). + call physics_ptend_scale(ptend, 1._r8/cld_macmic_num_steps, ncol) + call physics_update(state, ptend, ztodt, tend) + call check_energy_chng(state, tend, "macrop_tend", nstep, ztodt, & + zero, flx_cnd/cld_macmic_num_steps, & + det_ice/cld_macmic_num_steps, flx_heat/cld_macmic_num_steps) - else ! Calculate CLUBB macrophysics + else ! Calculate CLUBB macrophysics - ! ===================================================== - ! CLUBB call (PBL, shallow convection, macrophysics) - ! ===================================================== + ! ===================================================== + ! CLUBB call (PBL, shallow convection, macrophysics) + ! ===================================================== - call clubb_tend_cam(state,ptend,pbuf,1.0_r8*ztodt,& - cmfmc, cmfmc2, cam_in, sgh30, dlf, det_s, det_ice) - - ! Since we "added" the reserved liquid back in this routine, we need - ! to account for it in the energy checker - flx_cnd(:ncol) = -1._r8*rliq(:ncol) - flx_heat(:ncol) = cam_in%shf(:ncol) + det_s(:ncol) - - ! Update physics tendencies and copy state to state_eq, because that is - ! input for microphysics - call physics_update(state, ptend, ztodt, tend) - call check_energy_chng(state, tend, "clubb_tend", nstep, ztodt, cam_in%lhf/latvap, flx_cnd, det_ice, flx_heat) + call clubb_tend_cam(state,ptend,pbuf,cld_macmic_ztodt,& + cmfmc, cam_in, sgh30, macmic_it, cld_macmic_num_steps, & + dlf, det_s, det_ice) + + ! Since we "added" the reserved liquid back in this routine, we need + ! to account for it in the energy checker + flx_cnd(:ncol) = -1._r8*rliq(:ncol) + flx_heat(:ncol) = cam_in%shf(:ncol) + det_s(:ncol) + + ! Unfortunately, physics_update does not know what time period + ! "tend" is supposed to cover, and therefore can't update it + ! with substeps correctly. For now, work around this by scaling + ! ptend down by the number of substeps, then applying it for + ! the full time (ztodt). + call physics_ptend_scale(ptend, 1._r8/cld_macmic_num_steps, ncol) + ! Update physics tendencies and copy state to state_eq, because that is + ! input for microphysics + call physics_update(state, ptend, ztodt, tend) + call check_energy_chng(state, tend, "clubb_tend", nstep, ztodt, & + cam_in%lhf/latvap/cld_macmic_num_steps, flx_cnd/cld_macmic_num_steps, & + det_ice/cld_macmic_num_steps, flx_heat/cld_macmic_num_steps) - endif + endif - call t_stopf('macrop_tend') + call t_stopf('macrop_tend') - !=================================================== - ! Calculate cloud microphysics - !=================================================== + !=================================================== + ! Calculate cloud microphysics + !=================================================== - if (is_subcol_on()) then - ! Allocate sub-column structures. - call physics_state_alloc(state_sc, lchnk, psubcols*pcols) - call physics_tend_alloc(tend_sc, psubcols*pcols) + if (is_subcol_on()) then + ! Allocate sub-column structures. + call physics_state_alloc(state_sc, lchnk, psubcols*pcols) + call physics_tend_alloc(tend_sc, psubcols*pcols) - ! Generate sub-columns using the requested scheme - call subcol_gen(state, tend, state_sc, tend_sc, pbuf) + ! Generate sub-columns using the requested scheme + call subcol_gen(state, tend, state_sc, tend_sc, pbuf) - !Initialize check energy for subcolumns - call check_energy_timestep_init(state_sc, tend_sc, pbuf, col_type_subcol) - end if + !Initialize check energy for subcolumns + call check_energy_timestep_init(state_sc, tend_sc, pbuf, col_type_subcol) + end if - call t_startf('microp_aero_run') - call microp_aero_run(state, ptend_aero, ztodt, pbuf) - call t_stopf('microp_aero_run') + if (.not. micro_do_icesupersat) then - call t_startf('microp_tend') + call t_startf('microp_aero_run') + call microp_aero_run(state, ptend_aero, cld_macmic_ztodt, pbuf) + call t_stopf('microp_aero_run') - if (use_subcol_microp) then + endif - call microp_driver_tend(state_sc, ptend_sc, ztodt, pbuf) + call t_startf('microp_tend') - ! Average the sub-column ptend for use in gridded update - will not contain ptend_aero - call subcol_ptend_avg(ptend_sc, state_sc%ngrdcol, lchnk, ptend) - - ! Copy ptend_aero field to one dimensioned by sub-columns before summing with ptend - call subcol_ptend_copy(ptend_aero, state_sc, ptend_aero_sc) - call physics_ptend_sum(ptend_aero_sc, ptend_sc, state_sc%ncol) + if (use_subcol_microp) then + call microp_driver_tend(state_sc, ptend_sc, cld_macmic_ztodt, pbuf) - call physics_update (state_sc, ptend_sc, ztodt, tend_sc) - call check_energy_chng(state_sc, tend_sc, "microp_tend_subcol", nstep, ztodt, zero_sc, prec_str_sc, snow_str_sc, zero_sc) + ! Average the sub-column ptend for use in gridded update - will not contain ptend_aero + call subcol_ptend_avg(ptend_sc, state_sc%ngrdcol, lchnk, ptend) - call physics_state_dealloc(state_sc) - call physics_tend_dealloc(tend_sc) - call physics_ptend_dealloc(ptend_sc) + ! Copy ptend_aero field to one dimensioned by sub-columns before summing with ptend + call subcol_ptend_copy(ptend_aero, state_sc, ptend_aero_sc) + call physics_ptend_sum(ptend_aero_sc, ptend_sc, state_sc%ncol) + call physics_ptend_dealloc(ptend_aero_sc) - else - call microp_driver_tend(state, ptend, ztodt, pbuf) - end if + ! Have to scale and apply for full timestep to get tend right + ! (see above note for macrophysics). + call physics_ptend_scale(ptend_sc, 1._r8/cld_macmic_num_steps, ncol) - ! combine aero and micro tendencies for the grid - call physics_ptend_sum(ptend_aero, ptend, ncol) - call physics_update(state, ptend, ztodt, tend) - call check_energy_chng(state, tend, "microp_tend", nstep, ztodt, zero, prec_str, snow_str, zero) + call physics_update (state_sc, ptend_sc, ztodt, tend_sc) + call check_energy_chng(state_sc, tend_sc, "microp_tend_subcol", & + nstep, ztodt, zero_sc, prec_str_sc/cld_macmic_num_steps, & + snow_str_sc/cld_macmic_num_steps, zero_sc) - call physics_ptend_dealloc(ptend_aero) - call t_stopf('microp_tend') + call physics_state_dealloc(state_sc) + call physics_tend_dealloc(tend_sc) + call physics_ptend_dealloc(ptend_sc) + else + call microp_driver_tend(state, ptend, cld_macmic_ztodt, pbuf) + end if + ! combine aero and micro tendencies for the grid + if (.not. micro_do_icesupersat) then + call physics_ptend_sum(ptend_aero, ptend, ncol) + call physics_ptend_dealloc(ptend_aero) + endif + + ! Have to scale and apply for full timestep to get tend right + ! (see above note for macrophysics). + call physics_ptend_scale(ptend, 1._r8/cld_macmic_num_steps, ncol) + + call physics_update (state, ptend, ztodt, tend) + call check_energy_chng(state, tend, "microp_tend", nstep, ztodt, & + zero, prec_str/cld_macmic_num_steps, & + snow_str/cld_macmic_num_steps, zero) + + call t_stopf('microp_tend') + prec_sed_macmic(:ncol) = prec_sed_macmic(:ncol) + prec_sed(:ncol) + snow_sed_macmic(:ncol) = snow_sed_macmic(:ncol) + snow_sed(:ncol) + prec_pcw_macmic(:ncol) = prec_pcw_macmic(:ncol) + prec_pcw(:ncol) + snow_pcw_macmic(:ncol) = snow_pcw_macmic(:ncol) + snow_pcw(:ncol) + + end do ! end substepping over macrophysics/microphysics + + prec_sed(:ncol) = prec_sed_macmic(:ncol)/cld_macmic_num_steps + snow_sed(:ncol) = snow_sed_macmic(:ncol)/cld_macmic_num_steps + prec_pcw(:ncol) = prec_pcw_macmic(:ncol)/cld_macmic_num_steps + snow_pcw(:ncol) = snow_pcw_macmic(:ncol)/cld_macmic_num_steps + prec_str(:ncol) = prec_pcw(:ncol) + prec_sed(:ncol) + snow_str(:ncol) = snow_pcw(:ncol) + snow_sed(:ncol) endif @@ -2183,6 +2272,15 @@ subroutine tphysbc (ztodt, & endif +!songxl 2011-09-20--------------------------------- + !=================================================== ! Moist physical parameteriztions complete: ! send dynamical variables, and derived variables to history file @@ -2276,6 +2374,7 @@ subroutine phys_timestep_init(phys_state, cam_out, pbuf2d) use aerodep_flx, only: aerodep_flx_adv use aircraft_emit, only: aircraft_emit_adv use prescribed_volcaero, only: prescribed_volcaero_adv + use nudging, only: Nudge_Model,nudging_timestep_init implicit none @@ -2341,6 +2440,10 @@ subroutine phys_timestep_init(phys_state, cam_out, pbuf2d) ! age of air tracers call aoa_tracers_timestep_init(phys_state) + ! Update Nudging values, if needed + !---------------------------------- + if(Nudge_Model) call nudging_timestep_init(phys_state) + end subroutine phys_timestep_init end module physpkg diff --git a/models/atm/cam/src/physics/cam/rad_constituents.F90 b/models/atm/cam/src/physics/cam/rad_constituents.F90 index 42ff792eaa02..ea35f1881b17 100644 --- a/models/atm/cam/src/physics/cam/rad_constituents.F90 +++ b/models/atm/cam/src/physics/cam/rad_constituents.F90 @@ -37,6 +37,8 @@ module rad_constituents rad_cnst_readnl, &! read namelist values and parse rad_cnst_init, &! find optics files and all constituents rad_cnst_get_info, &! return info about climate/diagnostic lists + rad_cnst_get_mode_idx, &! return mode index of specified mode type + rad_cnst_get_spec_idx, &! return specie index of specified specie type rad_cnst_get_gas, &! return pointer to mmr for gasses rad_cnst_get_aer_mmr, &! return pointer to mmr for aerosols rad_cnst_get_mam_mmr_idx, &! get constituent index of mam specie mmr (climate list only) @@ -759,6 +761,102 @@ end subroutine rad_cnst_get_info_by_spectype !================================================================================================ +function rad_cnst_get_mode_idx(list_idx, mode_type) result(mode_idx) + + ! Return mode index of the specified type in the specified climate/diagnostics list. + ! Return -1 if not found. + + ! Arguments + integer, intent(in) :: list_idx ! index of the climate or a diagnostic list + character(len=*), intent(in) :: mode_type ! mode type + + ! Return value + integer :: mode_idx ! mode index + + ! Local variables + type(modelist_t), pointer :: m_list + + integer :: i, nmodes, m_idx + + character(len=*), parameter :: subname = 'rad_cnst_get_mode_idx' + !----------------------------------------------------------------------------- + + ! if mode type not found return -1 + mode_idx = -1 + + ! specified mode list + m_list => ma_list(list_idx) + + ! number of modes in specified list + nmodes = m_list%nmodes + + ! loop through modes in specified climate/diagnostic list + do i = 1, nmodes + + ! get index of the mode in the definition object + m_idx = m_list%idx(i) + + ! look in mode definition object (modes) for the mode types + if (trim(modes%types(m_idx)) == trim(mode_type)) then + mode_idx = i + exit + end if + end do + +end function rad_cnst_get_mode_idx + +!================================================================================================ + +function rad_cnst_get_spec_idx(list_idx, mode_idx, spec_type) result(spec_idx) + + ! Return specie index of the specified type in the specified mode of the specified + ! climate/diagnostics list. Return -1 if not found. + + ! Arguments + integer, intent(in) :: list_idx ! index of the climate or a diagnostic list + integer, intent(in) :: mode_idx ! mode index + character(len=*), intent(in) :: spec_type ! specie type + + ! Return value + integer :: spec_idx ! specie index + + ! Local variables + type(modelist_t), pointer :: m_list + type(mode_component_t), pointer :: mode_comps + + integer :: i, m_idx, nspec + + character(len=*), parameter :: subname = 'rad_cnst_get_spec_idx' + !----------------------------------------------------------------------------- + + ! if specie type not found return -1 + spec_idx = -1 + + ! modes in specified list + m_list => ma_list(list_idx) + + ! get index of the specified mode in the definition object + m_idx = m_list%idx(mode_idx) + + ! object containing the components of the mode + mode_comps => modes%comps(m_idx) + + ! number of species in specified mode + nspec = mode_comps%nspec + + ! loop through species in specified mode + do i = 1, nspec + + ! look in mode definition object (modes) for the mode types + if (trim(mode_comps%type(i)) == trim(spec_type)) then + spec_idx = i + exit + end if + end do + +end function rad_cnst_get_spec_idx +!================================================================================================ + subroutine rad_cnst_get_call_list(call_list) ! Return info about which climate/diagnostic calculations are requested diff --git a/models/atm/cam/src/physics/cam/zm_conv.F90 b/models/atm/cam/src/physics/cam/zm_conv.F90 index 7bfd1ee34f2c..b91730edc3d8 100644 --- a/models/atm/cam/src/physics/cam/zm_conv.F90 +++ b/models/atm/cam/src/physics/cam/zm_conv.F90 @@ -35,6 +35,7 @@ module zm_conv public zm_conv_evap ! evaporation of precip from ZM schemea public convtran ! convective transport public momtran ! convective momentum transport + public trigmem ! true if convective memory ! ! Private data @@ -42,15 +43,20 @@ module zm_conv real(r8), parameter :: unset_r8 = huge(1.0_r8) real(r8) :: zmconv_c0_lnd = unset_r8 real(r8) :: zmconv_c0_ocn = unset_r8 - real(r8) :: zmconv_ke = unset_r8 - real(r8) :: zmconv_tau = unset_r8 + real(r8) :: zmconv_ke = unset_r8 + real(r8) :: zmconv_tau = unset_r8 + logical :: zmconv_trigmem= .false. real(r8) rl ! wg latent heat of vaporization. real(r8) cpres ! specific heat at constant pressure in j/kg-degk. real(r8), parameter :: capelmt = 70._r8 ! threshold value for cape for deep convection. +!songxl 2014-05-20------------------ real(r8) :: ke ! Tunable evaporation efficiency set from namelist input zmconv_ke real(r8) :: c0_lnd ! set from namelist input zmconv_c0_lnd real(r8) :: c0_ocn ! set from namelist input zmconv_c0_ocn + logical :: trigmem ! set from namelist input zmconv_trigmem real(r8) tau ! convective time scale real(r8),parameter :: c1 = 6.112_r8 real(r8),parameter :: c2 = 17.67_r8 @@ -87,11 +93,10 @@ subroutine zmconv_readnl(nlfile) integer :: unitn, ierr character(len=*), parameter :: subname = 'zmconv_readnl' - namelist /zmconv_nl/ zmconv_c0_lnd, zmconv_c0_ocn, zmconv_ke, zmconv_tau + namelist /zmconv_nl/ zmconv_c0_lnd, zmconv_c0_ocn, zmconv_ke, zmconv_tau, zmconv_trigmem !----------------------------------------------------------------------------- - ! defaut: - zmconv_tau = 3600._r8 + zmconv_tau = 3600._r8 if (masterproc) then unitn = getunit() open( unitn, file=trim(nlfile), status='old' ) @@ -110,6 +115,7 @@ subroutine zmconv_readnl(nlfile) c0_ocn = zmconv_c0_ocn ke = zmconv_ke tau = zmconv_tau + trigmem = zmconv_trigmem end if @@ -119,6 +125,7 @@ subroutine zmconv_readnl(nlfile) call mpibcast(c0_ocn, 1, mpir8, 0, mpicom) call mpibcast(ke, 1, mpir8, 0, mpicom) call mpibcast(tau, 1, mpir8, 0, mpicom) + call mpibcast(trigmem, 1, mpir8, 0, mpicom) #endif end subroutine zmconv_readnl @@ -155,7 +162,7 @@ subroutine zm_convi(limcnv_in, no_deep_pbl_in) ! convection is too weak, thus adjusted to 2400. hgrid = get_resolution() - !tau = 3600._r8 + if(trigmem)tau = 3600._r8 if ( masterproc ) then write(iulog,*) 'tuning parameters zm_convi: tau',tau @@ -178,7 +185,8 @@ subroutine zm_convr(lchnk ,ncol , & tpert ,dlf ,pflx ,zdu ,rprd , & mu ,md ,du ,eu ,ed , & dp ,dsubcld ,jt ,maxg ,ideep , & - lengath ,ql ,rliq ,landfrac) + lengath ,ql ,rliq ,landfrac,hu_nm1 , & + cnv_nm1 ,tm1 ,qm1 ) !songxl 2014-05-20 !----------------------------------------------------------------------- ! ! Purpose: @@ -198,7 +206,7 @@ subroutine zm_convr(lchnk ,ncol , & ! !----------------------------------------------------------------------- use phys_control, only: cam_physpkg_is - + use time_manager, only: is_first_step, is_first_restart_step !songxl 2014-05-20 ! ! ************************ index of variables ********************** ! @@ -310,6 +318,10 @@ subroutine zm_convr(lchnk ,ncol , & real(r8), intent(in) :: pblh(pcols) real(r8), intent(in) :: tpert(pcols) real(r8), intent(in) :: landfrac(pcols) ! RBN Landfrac +!songxl 2014-05-20------------------ ! ! output arguments ! @@ -336,6 +348,11 @@ subroutine zm_convr(lchnk ,ncol , & real(r8), intent(out) :: prec(pcols) real(r8), intent(out) :: rliq(pcols) ! reserved liquid (not yet in cldliq) for energy integrals +!songxl 2014-05-20------------------ + real(r8) zs(pcols) real(r8) dlg(pcols,pver) ! gathrd version of the detraining cld h2o tend real(r8) pflxg(pcols,pverp) ! gather precip flux at each level @@ -369,9 +386,21 @@ subroutine zm_convr(lchnk ,ncol , & real(r8) qstp(pcols,pver) ! w grid slice of parcel temp. saturation mixing ratio. real(r8) tl(pcols) ! w row of parcel temperature at lcl. +!songxl 2014-05-20----------------- integer lcl(pcols) ! w base level index of deep cumulus convection. integer lel(pcols) ! w index of highest theoretical convective plume. + integer lon(pcols) ! w index of onset level for deep convection. integer maxi(pcols) ! w index of level with largest moist static energy. integer index(pcols) @@ -391,6 +420,8 @@ subroutine zm_convr(lchnk ,ncol , & real(r8) vg(pcols,pver) ! wg grid slice of gathered values of v. real(r8) cmeg(pcols,pver) + real(r8) hu_nm1g(pcols,pver) !songxl 2014-05-20 + real(r8) rprdg(pcols,pver) ! wg gathered rain production rate real(r8) capeg(pcols) ! wg gathered convective available potential energy. real(r8) tlg(pcols) ! wg grid slice of gathered values of tl. @@ -481,7 +512,7 @@ subroutine zm_convr(lchnk ,ncol , & jctop(i) = pver jcbot(i) = 1 - + if(trigmem)dcape(i) = 0._r8 !songxl 2014-05-20 end do ! ! calculate local pressure (mbs) and height (m) for both interface @@ -516,11 +547,22 @@ subroutine zm_convr(lchnk ,ncol , & q(i,k) = qh(i,k) s(i,k) = t(i,k) + (grav/cpres)*z(i,k) tp(i,k)=0.0_r8 + if(trigmem)tpm1(i,k) = 0.0_r8 !songxl 2014-05-20 shat(i,k) = s(i,k) qhat(i,k) = q(i,k) end do end do +!songxl 2014-05-20--------------------- + do i = 1,ncol capeg(i) = 0._r8 lclg(i) = 1 @@ -544,13 +586,27 @@ subroutine zm_convr(lchnk ,ncol , & ! Evaluate Tparcel, qs(Tparcel), buoyancy and CAPE, ! lcl, lel, parcel launch level at index maxi()=hmax - - call buoyan_dilute(lchnk ,ncol , & +!songxl 2014-05-20------------------ end if ! @@ -560,10 +616,26 @@ subroutine zm_convr(lchnk ,ncol , & ! lengath = 0 do i=1,ncol +! capelmt) then + lengath = lengath + 1 + index(lengath) = i + end if + else + if (dcape(i) > dcapelmt) then + lengath = lengath + 1 + index(lengath) = i + end if + end if + else if (cape(i) > capelmt) then lengath = lengath + 1 index(lengath) = i end if + end if +!>songxl 2014-05-20---------------- end do if (lengath.eq.0) return @@ -587,6 +659,7 @@ subroutine zm_convr(lchnk ,ncol , & qstpg(i,k) = qstp(ideep(i),k) ug(i,k) = 0._r8 vg(i,k) = 0._r8 + if(trigmem)hu_nm1g(i,k) = hu_nm1(ideep(i),k) !songxl 2014-05-20 end do end do ! @@ -651,7 +724,8 @@ subroutine zm_convr(lchnk ,ncol , & cmeg ,maxg ,lelg ,jt ,jlcl , & maxg ,j0 ,jd ,rl ,lengath , & rgas ,grav ,cpres ,msg , & - pflxg ,evpg ,cug ,rprdg ,limcnv ,landfracg) + pflxg ,evpg ,cug ,rprdg ,limcnv , & + landfracg, hu_nm1g ) !songxl 2014-05-20 ! ! convert detrainment from units of "1/m" to "1/mb". ! @@ -731,6 +805,17 @@ subroutine zm_convr(lchnk ,ncol , & cpres ,rl ,msg , & dlg ,evpg ,cug ) ! +!songxl 2014-05-20----------------- + ! gather back temperature and mixing ratio. ! do k = msg + 1,pver @@ -749,6 +834,12 @@ subroutine zm_convr(lchnk ,ncol , & dlf (ideep(i),k) = dlg (i,k) pflx(ideep(i),k) = pflxg(i,k) ql (ideep(i),k) = qlg (i,k) +!songxl 2014-05-20 end do end do ! @@ -1994,7 +2085,11 @@ subroutine cldprp(lchnk , & cmeg ,jb ,lel ,jt ,jlcl , & mx ,j0 ,jd ,rl ,il2g , & rd ,grav ,cp ,msg , & - pflx ,evp ,cu ,rprd ,limcnv ,landfrac) +!songxl 2014-05-20------- !----------------------------------------------------------------------- ! ! Purpose: @@ -2067,6 +2162,9 @@ subroutine cldprp(lchnk , & real(r8), intent(out) :: sd(pcols,pver) ! normalized dry stat energy of downdraft real(r8), intent(out) :: su(pcols,pver) ! normalized dry stat energy of updraft +!songxl 2014-05-20---------------- real(r8) rd ! gas constant for dry air real(r8) grav ! gravity @@ -2127,6 +2225,11 @@ subroutine cldprp(lchnk , & logical doit(pcols) logical done(pcols) + +!songxl 2014-05-20---------------- ! !------------------------------------------------------------------------------ ! @@ -2390,6 +2493,20 @@ subroutine cldprp(lchnk , & khighest = min(khighest,lel(i)) klowest = max(klowest,jb(i)) end do + +!songxl 2014-05-20-------------- + do k = klowest-1,khighest,-1 do i = 1,il2g if (k <= jb(i)-1 .and. k >= lel(i) .and. eps0(i) > 0._r8) then @@ -2399,13 +2516,21 @@ subroutine cldprp(lchnk , & eu(i,k) = 0._r8 du(i,k) = mu(i,k+1)/dz(i,k) else - hu(i,k) = mu(i,k+1)/mu(i,k)*hu(i,k+1) + & - dz(i,k)/mu(i,k)* (eu(i,k)*hmn(i,k)- du(i,k)*hsat(i,k)) +!songxl 2014-05-20-------------- end if end if end do end do ! +! ! reset cloud top index beginning from two layers above the ! cloud base (i.e. if cloud is only one layer thick, top is not reset ! @@ -2415,7 +2540,8 @@ subroutine cldprp(lchnk , & do k=klowest-2,khighest-1,-1 do i=1,il2g if (doit(i) .and. k <= jb(i)-2 .and. k >= lel(i)-1) then - if (hu(i,k) <= hsthat(i,k) .and. hu(i,k+1) > hsthat(i,k+1) & + if(trigmem)then + if (hu(i,k) <= hsthat(i,k) .and. hu(i,k+1) > hsthat(i,k+1) & .and. mu(i,k) >= 0.02_r8) then if (hu(i,k)-hsthat(i,k) < -2000._r8) then jt(i) = k + 1 @@ -2424,10 +2550,35 @@ subroutine cldprp(lchnk , & jt(i) = k doit(i) = .false. end if - else if (hu(i,k) > hu(i,jb(i)) .or. mu(i,k) < 0.02_r8) then + else + if (hu_tot(i).eq.hmn_tot(i)) then + if (hu(i,k) > hu(i,jb(i)) .or. mu(i,k) < 0.02_r8) then + jt(i) = k + 1 + doit(i) = .false. + end if + else + if ( mu(i,k) < 0.02_r8) then + jt(i) = k + 1 + doit(i) = .false. + end if + end if + end if + else ! not trigmem + if (hu(i,k) <= hsthat(i,k) .and. hu(i,k+1) > hsthat(i,k+1) & + .and. mu(i,k) >= 0.02_r8) then + if (hu(i,k)-hsthat(i,k) < -2000._r8) then + jt(i) = k + 1 + doit(i) = .false. + else + jt(i) = k + doit(i) = .false. + end if + else if (hu(i,k) > hu(i,jb(i)) .or. mu(i,k) < 0.02_r8) then jt(i) = k + 1 doit(i) = .false. - end if + end if + end if ! end trigmem +!>songxl 2014-06-20------------------------ end if end do end do @@ -2447,6 +2598,10 @@ subroutine cldprp(lchnk , & end do end do ! +!songxl 2014-05-20----------------- + ! specify downdraft properties (no downdrafts if jd.ge.jb). ! scale down downward mass flux profile so that net flux ! (up-down) at cloud base in not negative. @@ -3039,7 +3194,6 @@ subroutine buoyan_dilute(lchnk ,ncol , & real(r8), intent(in) :: pf(pcols,pver+1) ! pressure at interfaces real(r8), intent(in) :: pblt(pcols) ! index of pbl depth real(r8), intent(in) :: tpert(pcols) ! perturbation temperature by pbl processes - ! ! output arguments ! @@ -3164,7 +3318,6 @@ subroutine buoyan_dilute(lchnk ,ncol , & call parcel_dilute(lchnk, ncol, msg, mx, p, t, q, tpert, tp, tpv, qstp, pl, tl, lcl) - ! If lcl is above the nominal level of non-divergence (600 mbs), ! no deep convection is permitted (ensuing calculations ! skipped and cape retains initialized value of zero). @@ -3244,7 +3397,6 @@ subroutine buoyan_dilute(lchnk ,ncol , & end subroutine buoyan_dilute subroutine parcel_dilute (lchnk, ncol, msg, klaunch, p, t, q, tpert, tp, tpv, qstp, pl, tl, lcl) - ! Routine to determine ! 1. Tp - Parcel temperature ! 2. qstp - Saturated mixing ratio at the parcel temperature. diff --git a/models/atm/cam/src/physics/cam/zm_conv_intr.F90 b/models/atm/cam/src/physics/cam/zm_conv_intr.F90 index 181407d0b82d..b4d8562487dc 100644 --- a/models/atm/cam/src/physics/cam/zm_conv_intr.F90 +++ b/models/atm/cam/src/physics/cam/zm_conv_intr.F90 @@ -11,8 +11,9 @@ module zm_conv_intr !--------------------------------------------------------------------------------- use shr_kind_mod, only: r8=>shr_kind_r8 use physconst, only: cpair + use physconst, only: latvap, gravit !songxl 2014-05-20 use ppgrid, only: pver, pcols, pverp, begchunk, endchunk - use zm_conv, only: zm_conv_evap, zm_convr, convtran, momtran + use zm_conv, only: zm_conv_evap, zm_convr, convtran, momtran, trigmem use cam_history, only: outfld, addfld, add_default, phys_decomp use perf_mod use cam_logfile, only: iulog @@ -58,6 +59,13 @@ module zm_conv_intr prec_dp_idx, & snow_dp_idx +!songxl 2014-05-20------------------ + ! indices for fields in the physics buffer integer :: cld_idx = 0 integer :: icwmrdp_idx = 0 @@ -93,6 +101,19 @@ subroutine zm_conv_register ! deep gbm cloud liquid water (kg/kg) call pbuf_add_field('DP_CLDICE','global',dtype_r8,(/pcols,pver/), dp_cldice_idx) +!songxl 2014-05-20------------- + end subroutine zm_conv_register !========================================================================================= @@ -279,6 +300,7 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & use phys_grid, only: get_lat_p, get_lon_p use time_manager, only: get_nstep, is_first_step + use time_manager, only: is_first_restart_step !songxl 2011-09-20 use physics_buffer, only : pbuf_get_field, physics_buffer_desc, pbuf_old_tim_idx use constituents, only: pcnst, cnst_get_ind, cnst_is_convtran1 use check_energy, only: check_energy_chng @@ -339,6 +361,13 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & real(r8), pointer, dimension(:,:) :: flxsnow ! Convective-scale flux of snow at interfaces (kg/m2/s) real(r8), pointer, dimension(:,:) :: dp_cldliq real(r8), pointer, dimension(:,:) :: dp_cldice +!songxl 2014-05-20--------- + real(r8) :: jctop(pcols) ! o row of top-of-deep-convection indices passed out. real(r8) :: jcbot(pcols) ! o row of base of cloud indices passed out. @@ -394,6 +423,23 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & call pbuf_get_field(pbuf, prec_dp_idx, prec ) call pbuf_get_field(pbuf, snow_dp_idx, snow ) +! + ! | | Start of CLUBB main time step loop + ! | | + ! | | advance_clubb_core + ! | | + ! | | + ! | |\ + ! | | \ + ! | | (intent in)-------setup_pdf_parameters-------->calc. Ncnm (local) + ! | | | + ! | | \ / + ! | | mu_Ncn_i, sigma_Ncn_i, + ! | | corr_xNcn_i + ! | | | + ! | | \ / + ! | | PDF param. arrays: + ! | | mu_x_i_n, sigma_x_i_n, + ! | | corr_array_i_n + ! | | (intent out) + ! | | | + ! | | | + ! | | | + ! | | | + ! | | | + ! | | | + ! | |--(intent in)-------microphys_schemes-------------(intent in) + ! | | | + ! | | | + ! | | call a microphysics scheme + ! | | | + ! | | Local micro. scheme-----------Latin Hypercube-----------Upscaled KK + ! | | | | | + ! | | Ncm/Nc-in-cloud: Populate sample points Use PDF params. + ! | | used to find micro. using PDF params (Ncn). of Ncn + ! | | tendencies. At every sample point: (mu_Ncn_i, etc.) + ! | | | Nc = Ncn * H(chi). to find micro. + ! | | | Use sample-point Nc to tendencies. + ! | | | find micro. tendencies | + ! | | | when calling micro. scheme. | + ! | | | | | + ! | | hydromet_mc/-----------------hydromet_mc/-------------hydromet_mc + ! | | Ncm_mc (intent out) | Ncm_mc (intent out) (intent out) + ! | | | + ! | | | + ! | | | + ! | | | + ! | | | + ! | | | + ! | | | + ! | | (intent in) + ! | | | + ! | |--(intent inout)----advance_microphys + ! | | + ! | | + ! | | advance microphysics variables (hydromet, Nc_in_cloud/Ncm) one timestep + ! | | + ! | | l_predict_Nc = true: + ! | | Nc_in_cloud/Ncm necessary for starting + ! | | value of Nc_in_cloud/Ncm when advancing + ! | | one timestep using predictive equation. + ! | | + ! | | + ! | | End of CLUBB main time step loop + ! <--- + + ! References: + !------------------------------------------------------------------------- + + implicit none + + private ! default scope + + public :: Ncnm_to_Nc_in_cloud, & + Nc_in_cloud_to_Ncnm, & + Ncnm_to_Ncm, & + Ncm_to_Ncnm + + private :: bivar_NL_chi_Ncn_mean, & + bivar_Ncnm_eqn_comp + +contains + + !============================================================================= + function Ncnm_to_Nc_in_cloud( mu_chi_1, mu_chi_2, mu_Ncn_1, mu_Ncn_2, & + sigma_chi_1, sigma_chi_2, sigma_Ncn_1, & + sigma_Ncn_2, sigma_Ncn_1_n, sigma_Ncn_2_n, & + corr_chi_Ncn_1_n, corr_chi_Ncn_2_n, mixt_frac, & + cloud_frac_1, cloud_frac_2 ) & + result( Nc_in_cloud ) + + ! Description: + ! The in-cloud mean of cloud droplet concentration is calculated from the + ! PDF parameters involving simplified cloud nuclei concentration, Ncn, and + ! cloud fraction. At any point, cloud droplet concentration, Nc, is given + ! by: + ! + ! Nc = Ncn * H(chi); + ! + ! where extended liquid water mixing ratio, chi, is equal to cloud water + ! ratio, rc, when positive. When the atmosphere is saturated at this point, + ! cloud water is found, and Nc = Ncn. Otherwise, only clear air is found, + ! and Nc = 0. + ! + ! The overall mean of cloud droplet concentration, , is calculated from + ! the PDF parameters involving Ncn. The in-cloud mean of cloud droplet + ! concentration is calculated from and cloud fraction. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + cloud_frac_min + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + mu_chi_1, & ! Mean of chi (old s) (1st PDF component) [kg/kg] + mu_chi_2, & ! Mean of chi (old s) (2nd PDF component) [kg/kg] + mu_Ncn_1, & ! Mean of Ncn (1st PDF component) [num/kg] + mu_Ncn_2, & ! Mean of Ncn (2nd PDF component) [num/kg] + sigma_chi_1, & ! Standard deviation of chi (1st PDF comp.) [kg/kg] + sigma_chi_2, & ! Standard deviation of chi (2nd PDF comp.) [kg/kg] + sigma_Ncn_1, & ! Standard deviation of Ncn (1st PDF comp.) [num/kg] + sigma_Ncn_2, & ! Standard deviation of Ncn (2nd PDF comp.) [num/kg] + sigma_Ncn_1_n, & ! Standard deviation of ln Ncn (1st PDF component) [-] + sigma_Ncn_2_n, & ! Standard deviation of ln Ncn (2nd PDF component) [-] + corr_chi_Ncn_1_n, & ! Correlation of chi and ln Ncn (1st PDF comp.) [-] + corr_chi_Ncn_2_n, & ! Correlation of chi and ln Ncn (2nd PDF comp.) [-] + mixt_frac, & ! Mixture fraction [-] + cloud_frac_1, & ! Cloud fraction (1st PDF component) [-] + cloud_frac_2 ! Cloud fraction (2nd PDF component) [-] + + ! Return Variable + real( kind = core_rknd ) :: & + Nc_in_cloud ! Mean cloud droplet concentration (in-cloud) [num/kg] + + ! Local Variable + real( kind = core_rknd ) :: & + Ncm, & ! Mean cloud droplet concentration (overall) [num/kg] + cloud_frac ! Cloud fraction [-] + + + ! Calculate overall cloud fraction as calculated by the PDF. + ! The variable cloud_frac is not used here because it is altered by factors + ! such as the trapezoidal rule calculation. + ! Cloud fraction can be recalculated here from cloud_frac_1 and cloud_frac_2 + ! as long neither of these variables are altered by any factor. They can + ! only be calculated from PDF. + cloud_frac = mixt_frac * cloud_frac_1 + ( one - mixt_frac ) * cloud_frac_2 + + if ( cloud_frac > cloud_frac_min ) then + + ! There is cloud found at this grid level. Calculate Nc_in_cloud. + Ncm = Ncnm_to_Ncm( mu_chi_1, mu_chi_2, mu_Ncn_1, mu_Ncn_2, & + sigma_chi_1, sigma_chi_2, sigma_Ncn_1, & + sigma_Ncn_2, sigma_Ncn_1_n, sigma_Ncn_2_n, & + corr_chi_Ncn_1_n, corr_chi_Ncn_2_n, mixt_frac ) + + Nc_in_cloud = Ncm / cloud_frac + + else ! cloud_frac <= cloud_frac_min + + ! This level is entirely clear. Set Nc_in_cloud to . + ! Since = mu_Ncn_1 = mu_Ncn_2, use mu_Ncn_1 here. + Nc_in_cloud = mu_Ncn_1 + + endif + + + return + + end function Ncnm_to_Nc_in_cloud + + !============================================================================= + function Nc_in_cloud_to_Ncnm( mu_chi_1, mu_chi_2, sigma_chi_1, & + sigma_chi_2, mixt_frac, Nc_in_cloud, & + cloud_frac_1, cloud_frac_2, & + const_Ncnp2_on_Ncnm2, const_corr_chi_Ncn ) & + result( Ncnm ) + + ! Description: + ! The overall mean of simplified cloud nuclei concentration, , is + ! calculated from the in-cloud mean of cloud droplet concentration, , + ! cloud fraction, and some of the PDF parameters. + ! + ! At any point, cloud droplet concentration, Nc, is given by: + ! + ! Nc = Ncn * H(chi); + ! + ! where extended liquid water mixing ratio, chi, is equal to cloud water + ! ratio, rc, when positive. When the atmosphere is saturated at this point, + ! cloud water is found, and Nc = Ncn. Otherwise, only clear air is found, + ! and Nc = 0. + ! + ! The overall mean of cloud droplet concentration, , is calculated from + ! Nc_in_cloud and cloud fraction. The value of is calculated from + ! and PDF parameters. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + zero, & + cloud_frac_min + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + mu_chi_1, & ! Mean of chi (old s) (1st PDF component) [kg/kg] + mu_chi_2, & ! Mean of chi (old s) (2nd PDF component) [kg/kg] + sigma_chi_1, & ! Standard deviation of chi (1st PDF component) [kg/kg] + sigma_chi_2, & ! Standard deviation of chi (2nd PDF component) [kg/kg] + mixt_frac ! Mixture fraction [-] + + real( kind = core_rknd ), intent(in) :: & + Nc_in_cloud, & ! Mean cloud droplet conc. (in-cloud) [num/kg] + cloud_frac_1, & ! Cloud fraction (1st PDF component) [-] + cloud_frac_2, & ! Cloud fraction (2nd PDF component) [-] + const_Ncnp2_on_Ncnm2, & ! Prescribed ratio of to ^2 [-] + const_corr_chi_Ncn ! Prescribed correlation of chi and Ncn [-] + + ! Return Variable + real( kind = core_rknd ) :: & + Ncnm ! Mean simplified cloud nuclei concentration (overall) [num/kg] + + ! Local Variable + real( kind = core_rknd ) :: & + Ncm, & ! Mean cloud droplet concentration (overall) [num/kg] + cloud_frac ! Cloud fraction [-] + + + ! Calculate overall cloud fraction as calculated by the PDF. + ! The variable cloud_frac is not used here because it is altered by factors + ! such as the trapezoidal rule calculation. + ! Cloud fraction can be recalculated here from cloud_frac_1 and cloud_frac_2 + ! as long neither of these variables are altered by any factor. They can + ! only be calculated from the PDF. + cloud_frac = mixt_frac * cloud_frac_1 + ( one - mixt_frac ) * cloud_frac_2 + + if ( cloud_frac > cloud_frac_min & + .and. const_corr_chi_Ncn * const_Ncnp2_on_Ncnm2 /= zero ) then + + ! There is cloud found at this grid level. Additionally, Ncn varies. + ! Calculate Nc_in_cloud. + Ncm = Nc_in_cloud * cloud_frac + + Ncnm = Ncm_to_Ncnm( mu_chi_1, mu_chi_2, sigma_chi_1, sigma_chi_2, & + mixt_frac, Ncm, const_Ncnp2_on_Ncnm2, & + const_corr_chi_Ncn, Nc_in_cloud ) + + else ! cloud_frac <= cloud_frac_min .or. const_Ncnp2_on_Ncnm2 = 0 + + ! When Ncn is constant a a grid level, it is equal to Nc_in_cloud. + ! Additionally, when a level is entirely clear, , which is based on + ! Nc_in_cloud, here, must be set to something. Set to Nc_in_cloud. + Ncnm = Nc_in_cloud + + endif + + + return + + end function Nc_in_cloud_to_Ncnm + + !============================================================================= + function Ncnm_to_Ncm( mu_chi_1, mu_chi_2, mu_Ncn_1, mu_Ncn_2, & + sigma_chi_1, sigma_chi_2, sigma_Ncn_1, & + sigma_Ncn_2, sigma_Ncn_1_n, sigma_Ncn_2_n, & + corr_chi_Ncn_1_n, corr_chi_Ncn_2_n, mixt_frac ) & + result( Ncm ) + + ! Description: + ! The overall mean of cloud droplet concentration, , is calculated from + ! the PDF parameters involving the simplified cloud nuclei concentration, + ! Ncn. At any point, cloud droplet concentration, Nc, is given by: + ! + ! Nc = Ncn * H(chi); + ! + ! where extended liquid water mixing ratio, chi, is equal to cloud water + ! ratio, rc, when positive. When the atmosphere is saturated at this point, + ! cloud water is found, and Nc = Ncn. Otherwise, only clear air is found, + ! and Nc = 0. + ! + ! The overall mean of cloud droplet concentration, , is found by + ! integrating over the PDF of chi and Ncn, such that: + ! + ! = INT(-inf:inf) INT(0:inf) Ncn * H(chi) * P(chi,Ncn) dNcn dchi; + ! + ! which can also be written as: + ! + ! = SUM(i=1,n) mixt_frac_i + ! * INT(-inf:inf) INT(0:inf) Ncn * H(chi) * P_i(chi,Ncn) dNcn dchi; + ! + ! where n is the number of multivariate joint PDF components, mixt_frac_i is + ! the weight of the ith PDF component, and P_i is the functional form of the + ! multivariate joint PDF in the ith PDF component. + ! + ! This equation is rewritten as: + ! + ! = SUM(i=1,n) mixt_frac_i + ! * INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi. + ! + ! When both chi and Ncn vary in the ith PDF component, the integral is + ! evaluated and the result is: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi + ! = (1/2) * exp{ mu_Ncn_i_n + (1/2) * sigma_Ncn_i_n^2 } + ! * erfc( - ( 1 / sqrt(2) ) * ( ( mu_chi_i / sigma_chi_i ) + ! + rho_chi_Ncn_i_n * sigma_Ncn_i_n ) ); + ! + ! which can be reduced to: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi + ! = (1/2) * mu_Ncn_i + ! * erfc( - ( 1 / sqrt(2) ) * ( ( mu_chi_i / sigma_chi_i ) + ! + rho_chi_Ncn_i_n * sigma_Ncn_i_n ) ). + ! + ! When chi is constant, but Ncn varies, in the ith PDF component, the + ! integral is evaluated and results in: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi = mu_Ncn_i; + ! + ! when mu_chi_i > 0; and + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi = 0; + ! + ! when mu_chi_i <= 0. + ! + ! When chi varies, but Ncn is constant, in the ith PDF component, the + ! integral is evaluated and results in: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi + ! = mu_Ncn_i * (1/2) * erfc( - ( mu_chi_i / ( sqrt(2) * sigma_chi_i ) ) ). + ! + ! When both chi and Ncn are constant in the ith PDF component, the integral + ! is evaluated and results in: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi = mu_Ncn_i; + ! + ! when mu_chi_i > 0; and + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi = 0; + ! + ! when mu_chi_i <= 0. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one ! Constant(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + mu_chi_1, & ! Mean of chi (old s) (1st PDF component) [kg/kg] + mu_chi_2, & ! Mean of chi (old s) (2nd PDF component) [kg/kg] + mu_Ncn_1, & ! Mean of Ncn (1st PDF component) [num/kg] + mu_Ncn_2, & ! Mean of Ncn (2nd PDF component) [num/kg] + sigma_chi_1, & ! Standard deviation of chi (1st PDF comp.) [kg/kg] + sigma_chi_2, & ! Standard deviation of chi (2nd PDF comp.) [kg/kg] + sigma_Ncn_1, & ! Standard deviation of Ncn (1st PDF comp.) [num/kg] + sigma_Ncn_2, & ! Standard deviation of Ncn (2nd PDF comp.) [num/kg] + sigma_Ncn_1_n, & ! Standard deviation of ln Ncn (1st PDF component) [-] + sigma_Ncn_2_n, & ! Standard deviation of ln Ncn (2nd PDF component) [-] + corr_chi_Ncn_1_n, & ! Correlation of chi and ln Ncn (1st PDF comp.) [-] + corr_chi_Ncn_2_n, & ! Correlation of chi and ln Ncn (2nd PDF comp.) [-] + mixt_frac ! Mixture fraction [-] + + ! Return Variable + real( kind = core_rknd ) :: & + Ncm ! Mean cloud droplet concentration (overall) [num/kg] + + + ! Calculate mean cloud droplet concentration (overall), . + Ncm & + = mixt_frac & + * bivar_NL_chi_Ncn_mean( mu_chi_1, mu_Ncn_1, sigma_chi_1, & + sigma_Ncn_1, sigma_Ncn_1_n, corr_chi_Ncn_1_n ) & + + ( one - mixt_frac ) & + * bivar_NL_chi_Ncn_mean( mu_chi_2, mu_Ncn_2, sigma_chi_2, & + sigma_Ncn_2, sigma_Ncn_2_n, corr_chi_Ncn_2_n ) + + + return + + end function Ncnm_to_Ncm + + !============================================================================= + function Ncm_to_Ncnm( mu_chi_1, mu_chi_2, sigma_chi_1, sigma_chi_2, & + mixt_frac, Ncm, const_Ncnp2_on_Ncnm2, & + const_corr_chi_Ncn, Ncnm_val_denom_0 ) & + result( Ncnm ) + + ! Description: + ! The overall mean of simplified cloud nuclei concentration, , is + ! calculated from the overall mean of cloud droplet concentration, , and + ! some of the PDF parameters. + ! + ! At any point, cloud droplet concentration, Nc, is given by: + ! + ! Nc = Ncn * H(chi); + ! + ! where extended liquid water mixing ratio, chi, is equal to cloud water + ! ratio, rc, when positive. When the atmosphere is saturated at this point, + ! cloud water is found, and Nc = Ncn. Otherwise, only clear air is found, + ! and Nc = 0. + ! + ! The overall mean of cloud droplet concentration, , is found by + ! integrating over the PDF of chi and Ncn, such that: + ! + ! = INT(-inf:inf) INT(0:inf) Ncn * H(chi) * P(chi,Ncn) dNcn dchi; + ! + ! which can also be written as: + ! + ! = SUM(i=1,n) mixt_frac_i + ! * INT(-inf:inf) INT(0:inf) Ncn * H(chi) * P_i(chi,Ncn) dNcn dchi; + ! + ! where n is the number of multivariate joint PDF components, mixt_frac_i is + ! the weight of the ith PDF component, and P_i is the functional form of the + ! multivariate joint PDF in the ith PDF component. + ! + ! This equation is rewritten as: + ! + ! = SUM(i=1,n) mixt_frac_i + ! * INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi. + ! + ! When both chi and Ncn vary in the ith PDF component, the integral is + ! evaluated and the result is: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi + ! = (1/2) * exp{ mu_Ncn_i_n + (1/2) * sigma_Ncn_i_n^2 } + ! * erfc( - ( 1 / sqrt(2) ) * ( ( mu_chi_i / sigma_chi_i ) + ! + rho_chi_Ncn_i_n * sigma_Ncn_i_n ) ); + ! + ! which can be reduced to: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi + ! = (1/2) * mu_Ncn_i + ! * erfc( - ( 1 / sqrt(2) ) * ( ( mu_chi_i / sigma_chi_i ) + ! + rho_chi_Ncn_i_n * sigma_Ncn_i_n ) ). + ! + ! When chi is constant, but Ncn varies, in the ith PDF component, the + ! integral is evaluated and results in: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi = mu_Ncn_i; + ! + ! when mu_chi_i > 0; and + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi = 0; + ! + ! when mu_chi_i <= 0. + ! + ! When chi varies, but Ncn is constant, in the ith PDF component, the + ! integral is evaluated and results in: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi + ! = mu_Ncn_i * (1/2) * erfc( - ( mu_chi_i / ( sqrt(2) * sigma_chi_i ) ) ). + ! + ! When both chi and Ncn are constant in the ith PDF component, the integral + ! is evaluated and results in: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi = mu_Ncn_i; + ! + ! when mu_chi_i > 0; and + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi = 0; + ! + ! when mu_chi_i <= 0. + ! + ! + ! Solving for + ! ================= + ! + ! The individual marginal for simplified cloud nuclei concentration, Ncn, is + ! a single lognormal distribution over the entire horizontal domain. In + ! order to accomplish this in a two-component PDF structure, the PDF + ! parameters involving Ncn are set equal between the two components. This + ! results in: + ! + ! mu_Ncn_1 = mu_Ncn_2 = mu_Ncn_i = ; + ! mu_Ncn_1_n = mu_Ncn_2_n = mu_Ncn_i_n; + ! sigma_Ncn_1 = sigma_Ncn_2 = sigma_Ncn_i = sqrt( ); + ! sigma_Ncn_1_n = sigma_Ncn_2_n = sigma_Ncn_i_n; + ! rho_chi_Ncn_1 = rho_chi_Ncn_2 = rho_chi_Ncn_i = rho_chi_Ncn; and + ! rho_chi_Ncn_1_n = rho_chi_Ncn_2_n = rho_chi_Ncn_i_n. + ! + ! Additionally, the equation for sigma_Ncn_i_n is: + ! + ! sigma_Ncn_i_n = sqrt( ln( 1 + ( sigma_Ncn_i^2 / mu_Ncn_i^2 ) ) ); + ! + ! and the equation for rho_chi_Ncn_i_n is: + ! + ! rho_chi_Ncn_i_n + ! = rho_chi_Ncn_i * sqrt( exp{ sigma_Ncn_i_n^2 } - 1 ) / sigma_Ncn_i_n. + ! + ! The product of rho_chi_Ncn_i_n and sigma_Ncn_i_n is: + ! + ! rho_chi_Ncn_i_n * sigma_Ncn_i_n + ! = rho_chi_Ncn_i * sqrt( exp{ sigma_Ncn_i_n^2 } - 1 ). + ! + ! After substituting for sigma_Ncn_i_n^2, the equation for the product of + ! rho_chi_Ncn_i_n and sigma_Ncn_i_n is: + ! + ! rho_chi_Ncn_i_n * sigma_Ncn_i_n + ! = rho_chi_Ncn_i * sqrt( sigma_Ncn_i^2 / mu_Ncn_i^2 ); + ! + ! which can be rewritten as: + ! + ! rho_chi_Ncn_i_n * sigma_Ncn_i_n + ! = rho_chi_Ncn * sqrt( / ^2 ). + ! + ! Substituting all of this into the equation for , the equation for + ! becomes: + ! + ! = + ! * SUM(i=1,n) mixt_frac_i + ! --- + ! | (1/2) * erfc( - ( 1 / sqrt(2) ) + ! | * ( ( mu_chi_i / sigma_chi_i ) + ! | + rho_chi_Ncn * sqrt(/^2) ) ); + ! | where sigma_chi_i > 0 and > 0; + ! | + ! * | (1/2) * erfc( - ( mu_chi_i / ( sqrt(2) * sigma_chi_i ) ) ); + ! | where sigma_chi_i > 0 and = 0; + ! | + ! | 1; where sigma_chi_i = 0 and mu_chi_i > 0; + ! | + ! | 0; where sigma_chi_i = 0 and mu_chi_i <= 0. + ! --- + ! + ! In order to isolate , the value of /^2 is set to a + ! constant value, const_Ncn. The value of this constant does not depend on + ! . Likewise, the value of rho_chi_Ncn does not depend on . + ! Solving for , the equation becomes: + ! + ! + ! = / ( SUM(i=1,n) mixt_frac_i + ! --- + ! | (1/2) * erfc( - ( 1 / sqrt(2) ) + ! | * ( ( mu_chi_i / sigma_chi_i ) + ! | + rho_chi_Ncn * sqrt( const_Ncn ) ) ); + ! | where sigma_chi_i > 0 and const_Ncn > 0; + ! | + ! * | (1/2) * erfc( - ( mu_chi_i / ( sqrt(2) * sigma_chi_i ) ) ); + ! | where sigma_chi_i > 0 and const_Ncn = 0; + ! | + ! | 1; where sigma_chi_i = 0 and mu_chi_i > 0; + ! | + ! | 0; where sigma_chi_i = 0 and mu_chi_i <= 0 ). + ! --- + ! + ! When the denominator term is 0, there is only clear air. Both the + ! numerator () and the denominator have a value of 0, and is set + ! to an appropriate value. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + zero + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + mu_chi_1, & ! Mean of chi (old s) (1st PDF component) [kg/kg] + mu_chi_2, & ! Mean of chi (old s) (2nd PDF component) [kg/kg] + sigma_chi_1, & ! Standard deviation of chi (1st PDF component) [kg/kg] + sigma_chi_2, & ! Standard deviation of chi (2nd PDF component) [kg/kg] + mixt_frac ! Mixture fraction [-] + + real( kind = core_rknd ), intent(in) :: & + Ncm, & ! Mean cloud droplet conc. (overall) [num/kg] + const_Ncnp2_on_Ncnm2, & ! Prescribed ratio of to ^2 [-] + const_corr_chi_Ncn, & ! Prescribed correlation of chi and Ncn [-] + Ncnm_val_denom_0 ! Ncnm value -- denominator in eqn. is 0 [num/kg] + + ! Return Variable + real( kind = core_rknd ) :: & + Ncnm ! Mean simplified cloud nuclei concentration (overall) [num/kg] + + ! Local Variable + real( kind = core_rknd ) :: & + denominator_term ! Denominator in the equation for [-] + + + denominator_term & + = mixt_frac & + * bivar_Ncnm_eqn_comp( mu_chi_1, sigma_chi_1, & + const_Ncnp2_on_Ncnm2, const_corr_chi_Ncn ) & + + ( one - mixt_frac ) & + * bivar_Ncnm_eqn_comp( mu_chi_2, sigma_chi_2, & + const_Ncnp2_on_Ncnm2, const_corr_chi_Ncn ) + + + if ( denominator_term > zero ) then + + Ncnm = Ncm / denominator_term + + else ! denominator_term = 0 + + ! When the denominator is 0, it is usually because there is only clear + ! air. In that scenario, Ncm should also be 0. Set Ncnm to a value that + ! is usual or typical + Ncnm = Ncnm_val_denom_0 + + endif ! denominator_term > 0 + + + return + + end function Ncm_to_Ncnm + + !============================================================================= + function bivar_NL_chi_Ncn_mean( mu_chi_i, mu_Ncn_i, sigma_chi_i, & + sigma_Ncn_i, sigma_Ncn_i_n, corr_chi_Ncn_i_n ) + + ! Description: + ! The double integral over Ncn * H(chi) multiplied by the + ! bivariate normal-lognormal joint PDF of chi and Ncn is evaluated. The + ! integral is given by: + ! + ! INT(-inf:inf) INT(0:inf) Ncn * H(chi) * P_i(chi,Ncn) dNcn dchi; + ! + ! which reduces to: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi; + ! + ! where the individual marginal distribution of chi is normal in the ith PDF + ! component and the individual marginal distribution of Ncn is lognormal in + ! the ith PDF component. + ! + ! When both chi and Ncn vary in the ith PDF component, the integral is + ! evaluated and the result is: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi + ! = (1/2) * exp{ mu_Ncn_i_n + (1/2) * sigma_Ncn_i_n^2 } + ! * erfc( - ( 1 / sqrt(2) ) * ( ( mu_chi_i / sigma_chi_i ) + ! + rho_chi_Ncn_i_n * sigma_Ncn_i_n ) ); + ! + ! which can be reduced to: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi + ! = (1/2) * mu_Ncn_i + ! * erfc( - ( 1 / sqrt(2) ) * ( ( mu_chi_i / sigma_chi_i ) + ! + rho_chi_Ncn_i_n * sigma_Ncn_i_n ) ). + ! + ! When chi is constant, but Ncn varies, in the ith PDF component, the + ! integral is evaluated and results in: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi = mu_Ncn_i; + ! + ! when mu_chi_i > 0; and + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi = 0; + ! + ! when mu_chi_i <= 0. + ! + ! When chi varies, but Ncn is constant, in the ith PDF component, the + ! integral is evaluated and results in: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi + ! = mu_Ncn_i * (1/2) * erfc( - ( mu_chi_i / ( sqrt(2) * sigma_chi_i ) ) ). + ! + ! When both chi and Ncn are constant in the ith PDF component, the integral + ! is evaluated and results in: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi = mu_Ncn_i; + ! + ! when mu_chi_i > 0; and + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi = 0; + ! + ! when mu_chi_i <= 0. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + sqrt_2, & ! Constant(s) + one, & + one_half, & + zero, & + chi_tol, & + Ncn_tol + + use anl_erf, only: & + erfc ! Procedure(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + mu_chi_i, & ! Mean of chi (old s) (ith PDF component) [kg/kg] + mu_Ncn_i, & ! Mean of Ncn (ith PDF component) [num/kg] + sigma_chi_i, & ! Standard deviation of chi (ith PDF comp.) [kg/kg] + sigma_Ncn_i, & ! Standard deviation of Ncn (ith PDF comp.) [num/kg] + sigma_Ncn_i_n, & ! Standard deviation of ln Ncn (ith PDF component) [-] + corr_chi_Ncn_i_n ! Correlation of chi and ln Ncn (ith PDF comp.) [-] + + ! Return Variable + real( kind = core_rknd ) :: & + bivar_NL_chi_Ncn_mean + + + if ( sigma_chi_i <=chi_tol .and. sigma_Ncn_i <= Ncn_tol ) then + + ! The ith PDF component variances of both chi and Ncn are 0. + + if ( mu_chi_i > zero ) then + + bivar_NL_chi_Ncn_mean = mu_Ncn_i + + else ! mu_chi_i <= 0 + + bivar_NL_chi_Ncn_mean = zero + + endif + + + elseif ( sigma_chi_i <= chi_tol ) then + + ! The ith PDF component variance of chi is 0. + + if ( mu_chi_i > zero ) then + + bivar_NL_chi_Ncn_mean = mu_Ncn_i + + else ! mu_chi_i <= 0 + + bivar_NL_chi_Ncn_mean = zero + + endif + + + elseif ( sigma_Ncn_i <= Ncn_tol ) then + + ! The ith PDF component variance of Ncn is 0. + + bivar_NL_chi_Ncn_mean & + = mu_Ncn_i * one_half * erfc( - ( mu_chi_i / ( sqrt_2 * sigma_chi_i ) ) ) + + + else + + ! Both chi and Ncn vary in the ith PDF component. + + bivar_NL_chi_Ncn_mean & + = one_half * mu_Ncn_i & + * erfc( - ( one / sqrt_2 ) & + * ( ( mu_chi_i / sigma_chi_i ) & + + corr_chi_Ncn_i_n * sigma_Ncn_i_n ) ) + + + endif + + + return + + end function bivar_NL_chi_Ncn_mean + + !============================================================================= + function bivar_Ncnm_eqn_comp( mu_chi_i, sigma_chi_i, & + const_Ncnp2_on_Ncnm2, const_corr_chi_Ncn ) + + ! Description: + ! When is found based on the value of , the following equation is + ! used: + ! + ! + ! = / ( SUM(i=1,n) mixt_frac_i + ! --- + ! | (1/2) * erfc( - ( 1 / sqrt(2) ) + ! | * ( ( mu_chi_i / sigma_chi_i ) + ! | + rho_chi_Ncn * sqrt( const_Ncn ) ) ); + ! | where sigma_chi_i > 0 and const_Ncn > 0; + ! | + ! * | (1/2) * erfc( - ( mu_chi_i / ( sqrt(2) * sigma_chi_i ) ) ); + ! | where sigma_chi_i > 0 and const_Ncn = 0; + ! | + ! | 1; where sigma_chi_i = 0 and mu_chi_i > 0; + ! | + ! | 0; where sigma_chi_i = 0 and mu_chi_i <= 0 ). + ! --- + ! + ! In the above equation, const_Ncn = / ^2. It is a constant, + ! prescribed parameter. Likewise, rho_chi_Ncn is a parameter that is not + ! based on the value of . + ! + ! When the denominator term is 0, there is only clear air. Both the + ! numerator () and the denominator have a value of 0, and is set + ! to an appropriate value. + ! + ! The contribution of the ith PDF component to the denominator term in the + ! equation is calculated here. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + sqrt_2, & ! Constant(s) + one, & + one_half, & + zero, & + chi_tol + + use anl_erf, only: & + erfc ! Procedure(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + mu_chi_i, & ! Mean of chi (old s) (ith PDF component) [kg/kg] + sigma_chi_i ! Standard deviation of chi (ith PDF component) [kg/kg] + + real( kind = core_rknd ), intent(in) :: & + const_Ncnp2_on_Ncnm2, & ! Prescribed ratio of to ^2 [-] + const_corr_chi_Ncn ! Prescribed correlation of chi and Ncn [-] + + ! Return Variable + real( kind = core_rknd ) :: & + bivar_Ncnm_eqn_comp + + + if ( sigma_chi_i <= chi_tol ) then + + ! The ith PDF component variances of chi is 0. The value of the ith PDF + ! component variance of Ncn does not matter in this scenario. + + if ( mu_chi_i > zero ) then + + bivar_Ncnm_eqn_comp = one + + else ! mu_chi_i <= 0 + + bivar_Ncnm_eqn_comp = zero + + endif + + + elseif ( const_Ncnp2_on_Ncnm2 == zero ) then + + ! The ith PDF component variance of Ncn is 0. + + bivar_Ncnm_eqn_comp & + = one_half * erfc( - ( mu_chi_i / ( sqrt_2 * sigma_chi_i ) ) ) + + + else + + ! Both chi and Ncn vary in the ith PDF component. + + bivar_Ncnm_eqn_comp & + = one_half & + * erfc( - ( one / sqrt_2 ) & + * ( ( mu_chi_i / sigma_chi_i ) & + + const_corr_chi_Ncn * sqrt( const_Ncnp2_on_Ncnm2 ) ) ) + + + endif + + + return + + end function bivar_Ncnm_eqn_comp + +!=============================================================================== + +end module Nc_Ncn_eqns diff --git a/models/atm/cam/src/physics/clubb/Skw_module.F90 b/models/atm/cam/src/physics/clubb/Skw_module.F90 index c51011eae8a1..5c68391bc6b7 100644 --- a/models/atm/cam/src/physics/clubb/Skw_module.F90 +++ b/models/atm/cam/src/physics/clubb/Skw_module.F90 @@ -1,5 +1,6 @@ -!$Id: Skw_module.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -!------------------------------------------------------------------------------- +!------------------------------------------------------------------------- +!$Id: Skw_module.F90 6849 2014-04-22 21:52:30Z charlass@uwm.edu $ +!=============================================================================== module Skw_module implicit none @@ -28,12 +29,16 @@ elemental function Skw_func( wp2, wp3 ) & use clubb_precision, only: & core_rknd ! Variable(s) + use parameters_tunable, only: & + Skw_denom_coef + implicit none ! External intrinsic :: min, max ! Parameter Constants + ! Whether to apply clipping to the final result logical, parameter :: & l_clipping_kluge = .false. @@ -42,15 +47,6 @@ elemental function Skw_func( wp2, wp3 ) & wp2, & ! w'^2 [m^2/s^2] wp3 ! w'^3 [m^3/s^3] - real( kind = core_rknd ), parameter :: & - -#ifdef CLUBB_CAM - Skw_denom_coef = 0.0_core_rknd ! want this as zero if running CAM-CLUBB -#else - Skw_denom_coef = 8.0_core_rknd ! Factor to decrease sensitivity in the denominator - ! of Skw calculation -#endif - ! Output Variable real( kind = core_rknd ) :: & Skw ! Result Skw [-] @@ -60,9 +56,9 @@ elemental function Skw_func( wp2, wp3 ) & !Skw = wp3 / ( max( wp2, w_tol_sqd ) )**1.5_core_rknd ! Calculation of skewness to help reduce the sensitivity of this value to ! small values of wp2. - Skw = wp3 / ( ( wp2 + Skw_denom_coef * w_tol_sqd ) )**1.5_core_rknd + Skw = wp3 / ( wp2 + Skw_denom_coef * w_tol_sqd )**1.5_core_rknd - ! This is no longer need since clipping is already + ! This is no longer needed since clipping is already ! imposed on wp2 and wp3 elsewhere in the code if ( l_clipping_kluge ) then Skw = min( max( Skw, -Skw_max_mag ), Skw_max_mag ) diff --git a/models/atm/cam/src/physics/clubb/T_in_K_module.F90 b/models/atm/cam/src/physics/clubb/T_in_K_module.F90 index 5bc5c918a23c..17c040fbc1d5 100644 --- a/models/atm/cam/src/physics/clubb/T_in_K_module.F90 +++ b/models/atm/cam/src/physics/clubb/T_in_K_module.F90 @@ -1,5 +1,6 @@ -! $Id: T_in_K_module.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ - +!------------------------------------------------------------------------- +! $Id: T_in_K_module.F90 6849 2014-04-22 21:52:30Z charlass@uwm.edu $ +!=============================================================================== module T_in_K_module implicit none diff --git a/models/atm/cam/src/physics/clubb/advance_clubb_core_module.F90 b/models/atm/cam/src/physics/clubb/advance_clubb_core_module.F90 new file mode 100644 index 000000000000..0b2fd52f5dfa --- /dev/null +++ b/models/atm/cam/src/physics/clubb/advance_clubb_core_module.F90 @@ -0,0 +1,3397 @@ +!----------------------------------------------------------------------- +! $Id: advance_clubb_core_module.F90 7416 2014-12-04 20:16:51Z schemena@uwm.edu $ +!----------------------------------------------------------------------- +module advance_clubb_core_module + +! Description: +! The module containing the `core' of the CLUBB parameterization. +! A host model implementing CLUBB should only require this subroutine +! and the functions and subroutines it calls. +! +! References: +! ``A PDF-Based Model for Boundary Layer Clouds. Part I: +! Method and Model Description'' Golaz, et al. (2002) +! JAS, Vol. 59, pp. 3540--3551. +! +! Copyright Notice: +! +! This code and the source code it references are (C) 2006-2014 +! Jean-Christophe Golaz, Vincent E. Larson, Brian M. Griffin, +! David P. Schanen, Adam J. Smith, and Michael J. Falk. +! +! The distribution of this code and derived works thereof +! should include this notice. +! +! Portions of this code derived from other sources (Hugh Morrison, +! ACM TOMS, Numerical Recipes, et cetera) are the intellectual +! property of their respective authors as noted and are also subject +! to copyright. +!----------------------------------------------------------------------- + + implicit none + + public :: & + setup_clubb_core, & + advance_clubb_core, & + cleanup_clubb_core, & + set_Lscale_max, & + calculate_thlp2_rad + + private ! Default Scope + + contains + + !----------------------------------------------------------------------- + + !####################################################################### + !####################################################################### + ! If you change the argument list of advance_clubb_core you also have to + ! change the calls to this function in the host models CAM, WRF, SAM + ! and GFDL. + !####################################################################### + !####################################################################### + subroutine advance_clubb_core & + ( l_implemented, dt, fcor, sfc_elevation, hydromet_dim, & ! intent(in) + thlm_forcing, rtm_forcing, um_forcing, vm_forcing, & ! intent(in) + sclrm_forcing, edsclrm_forcing, wprtp_forcing, & ! intent(in) + wpthlp_forcing, rtp2_forcing, thlp2_forcing, & ! intent(in) + rtpthlp_forcing, wm_zm, wm_zt, & ! intent(in) + wpthlp_sfc, wprtp_sfc, upwp_sfc, vpwp_sfc, & ! intent(in) + wpsclrp_sfc, wpedsclrp_sfc, & ! intent(in) + p_in_Pa, rho_zm, rho, exner, & ! intent(in) + rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & ! intent(in) + invrs_rho_ds_zt, thv_ds_zm, thv_ds_zt, hydromet, & ! intent(in) + rfrzm, radf, do_expldiff, & ! intent(in) +#ifdef CLUBBND_CAM + varmu, & +#endif + wphydrometp, wp2hmp, rtphmp_zt, thlphmp_zt, & ! intent(in) + host_dx, host_dy, & ! intent(in) + um, vm, upwp, vpwp, up2, vp2, & ! intent(inout) + thlm, rtm, wprtp, wpthlp, & ! intent(inout) + wp2, wp3, rtp2, thlp2, rtpthlp, & ! intent(inout) + sclrm, & +#ifdef GFDL + sclrm_trsport_only, & ! h1g, 2010-06-16 ! intent(inout) +#endif + sclrp2, sclrprtp, sclrpthlp, & ! intent(inout) + wpsclrp, edsclrm, err_code, & ! intent(inout) +#ifdef GFDL + RH_crit, & !h1g, 2010-06-16 ! intent(inout) + do_liquid_only_in_clubb, & ! intent(in) +#endif + rcm, wprcp, cloud_frac, ice_supersat_frac, & ! intent(out) + rcm_in_layer, cloud_cover, & ! intent(out) +#if defined(CLUBB_CAM) || defined(GFDL) + khzm, khzt, & ! intent(out) +#endif +#ifdef CLUBB_CAM + qclvar, thlprcp_out, & ! intent(out) +#endif + pdf_params ) ! intent(out) + + ! Description: + ! Subroutine to advance the model one timestep + + ! References: + ! ``A PDF-Based Model for Boundary Layer Clouds. Part I: + ! Method and Model Description'' Golaz, et al. (2002) + ! JAS, Vol. 59, pp. 3540--3551. + !----------------------------------------------------------------------- + + ! Modules to be included + + use constants_clubb, only: & + em_min, & + thl_tol, & + rt_tol, & + w_tol_sqd, & + ep2, & + Cp, & + Lv, & + Ls, & + ep1, & + p0, & + kappa, & + fstderr, & + zero_threshold, & + three_halves, & + zero, & + unused_var + + use parameters_tunable, only: & + gamma_coefc, & ! Variable(s) + gamma_coefb, & + gamma_coef, & + taumax, & + c_K, & + mu, & + Lscale_mu_coef, & + Lscale_pert_coef, & + c_K10 + + use parameters_model, only: & + sclr_dim, & ! Variable(s) + edsclr_dim, & + sclr_tol, & + ts_nudge, & + rtm_min, & + rtm_nudge_max_altitude + + use model_flags, only: & + l_tke_aniso, & ! Variable(s) + l_gamma_Skw, & + l_trapezoidal_rule_zt, & + l_trapezoidal_rule_zm, & + l_call_pdf_closure_twice, & + l_host_applies_sfc_fluxes, & + l_use_cloud_cover, & + l_rtm_nudge + + use grid_class, only: & + gr, & ! Variable(s) + zm2zt, & ! Procedure(s) + zt2zm, & + ddzm + + use numerical_check, only: & + parameterization_check, & ! Procedure(s) + calculate_spurious_source + + use variables_diagnostic_module, only: & + Skw_zt, & ! Variable(s) + Skw_zm, & + sigma_sqd_w_zt, & + wp4, & + thlpthvp, & + rtpthvp, & + rtprcp, & + thlprcp, & + rcp2, & + rsat, & + pdf_params_zm, & + wprtp2, & + wp2rtp, & + wpthlp2, & + wp2thlp, & + wprtpthlp, & + wpthvp, & + wp2thvp, & + wp2rcp + + use variables_diagnostic_module, only: & + thvm, & + em, & + Lscale, & + Lscale_up, & + Lscale_down, & + tau_zm, & + tau_zt, & + Kh_zm, & + Kh_zt, & + vg, & + ug, & + um_ref, & + vm_ref + use variables_diagnostic_module, only: & + wp2_zt, & + thlp2_zt, & + wpthlp_zt, & + wprtp_zt, & + rtp2_zt, & + rtpthlp_zt, & + up2_zt, & + vp2_zt, & + upwp_zt, & + vpwp_zt, & + rtm_ref, & + thlm_ref + + use variables_diagnostic_module, only: & + wpedsclrp, & + sclrpthvp, & ! sclr'th_v' + sclrprcp, & ! sclr'rc' + wp2sclrp, & ! w'^2 sclr' + wpsclrp2, & ! w'sclr'^2 + wpsclrprtp, & ! w'sclr'rt' + wpsclrpthlp, & ! w'sclr'thl' + wp3_zm, & ! wp3 interpolated to momentum levels + Skw_velocity, & ! Skewness velocity [m/s] + a3_coef, & ! The a3 coefficient [-] + a3_coef_zt ! The a3 coefficient interp. to the zt grid [-] + + use variables_diagnostic_module, only: & + wp3_on_wp2, & ! Variable(s) + wp3_on_wp2_zt + + use pdf_parameter_module, only: & + pdf_parameter ! Type + +#ifdef GFDL + use advance_sclrm_Nd_module, only: & ! h1g, 2010-06-16 begin mod + advance_sclrm_Nd_diffusion_OG, & + advance_sclrm_Nd_upwind, & + advance_sclrm_Nd_semi_implicit ! h1g, 2010-06-16 end mod +#endif + + use advance_xm_wpxp_module, only: & + ! Variable(s) + advance_xm_wpxp ! Compute mean/flux terms + + use advance_xp2_xpyp_module, only: & + ! Variable(s) + advance_xp2_xpyp ! Computes variance terms + + use surface_varnce_module, only: & + surface_varnce ! Procedure + + use pdf_closure_module, only: & + ! Procedure + pdf_closure, & ! Prob. density function + calc_vert_avg_cf_component + + use mixing_length, only: & + compute_length ! Procedure + + use advance_windm_edsclrm_module, only: & + advance_windm_edsclrm ! Procedure(s) + + use saturation, only: & + ! Procedure + sat_mixrat_liq ! Saturation mixing ratio + + use advance_wp2_wp3_module, only: & + advance_wp2_wp3 ! Procedure + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use error_code, only : & + clubb_at_least_debug_level, & ! Procedure(s) + report_error, & + fatal_error + + use Skw_module, only: & + Skw_func ! Procedure + + use clip_explicit, only: & + clip_covars_denom ! Procedure(s) + + use T_in_K_module, only: & + ! Read values from namelist + thlm2T_in_K ! Procedure + + use stats_clubb_utilities, only: & + stats_accumulate ! Procedure + + use stats_type_utilities, only: & + stat_update_var_pt, & ! Procedure(s) + stat_update_var, & + stat_begin_update, & + stat_begin_update_pt, & + stat_end_update, & + stat_end_update_pt + + use stats_variables, only: & + irtp2_bt, & ! Variable(s) + ithlp2_bt, & + irtpthlp_bt, & + iwp2_bt, & + iwp3_bt, & + ivp2_bt, & + iup2_bt, & + iwprtp_bt, & + iwpthlp_bt, & + irtm_bt, & + ithlm_bt, & + ivm_bt, & + ium_bt, & + ircp2, & + iwp4, & + irsat, & + irvm, & + irel_humidity, & + iwpthlp_zt, & + iSkw_zt, & + iSkw_zm + + use stats_variables, only: & + iwprtp_zt, & + iup2_zt, & + ivp2_zt, & + iupwp_zt, & + ivpwp_zt, & + ithlp2_sf, & + irtp2_sf, & + irtpthlp_sf, & + iup2_sf, & + ivp2_sf, & + iwp2_sf, & + l_stats_samp, & + l_stats, & + stats_zt, & + stats_zm, & + stats_sfc, & + irtm_spur_src, & + ithlm_spur_src + + use stats_variables, only: & + irfrzm, & ! Variable(s) + icloud_frac_refined, & + istability_correction, & + ircm_refined + + use stats_variables, only: & + iSkw_velocity, & ! Variable(s) + igamma_Skw_fnc, & + iLscale_pert_1, & + iLscale_pert_2 + + use fill_holes, only: & + vertical_integral, & ! Procedure(s) + fill_holes_vertical + + use sigma_sqd_w_module, only: & + compute_sigma_sqd_w ! Procedure(s) + + use array_index, only: & + iirrm ! Variable + + use pdf_utilities, only: & + compute_mean_binormal + + use advance_helper_module, only: & + calc_stability_correction ! Procedure(s) + + use interpolation, only: & + pvertinterp + + implicit none + + !!! External + intrinsic :: sqrt, min, max, exp, mod, real + + ! Constant Parameters + logical, parameter :: l_avg_Lscale = .false. ! Lscale is calculated in subroutine compute_length; if l_avg_Lscale + ! is true, compute_length is called two additional times with + ! perturbed values of rtm and thlm. An average value of Lscale + ! from the three calls to compute_length is then calculated. + ! This reduces temporal noise in RICO, BOMEX, LBA, and other cases. +#ifdef CLUBBND_CAM + + logical, parameter :: & + l_Lscale_plume_centered = .true. ! Alternate that uses the PDF to + ! compute the perturbed values + + logical, parameter :: & + l_use_ice_latent = .true. !Includes the effects of ice latent heating in turbulence terms + +#else + + logical, parameter :: & + l_Lscale_plume_centered = .false. ! Alternate that uses the PDF to + ! compute the perturbed values + + logical, parameter :: & + l_use_ice_latent = .false. !Includes the effects of ice latent heating in turbulence terms + +#endif + + logical, parameter :: & + l_iter_xp2_xpyp = .true. ! Set to true when rtp2/thlp2/rtpthlp, et cetera are prognostic + + logical, parameter :: & + l_refine_grid_in_cloud = .false., & ! Compute cloud_frac and rcm on a refined grid + + l_interactive_refined = .false. ! Should the refined grid code feed into the model? + ! Only has meaning if l_refined_grid_in_cloud is .true. + + real( kind = core_rknd ), parameter :: & + chi_at_liq_sat = 0._core_rknd ! Value of chi(s) at saturation with respect to ice + ! (zero for liquid) + logical, parameter :: & + l_stability_correct_tau_zm = .true. ! Use tau_N2_zm instead of tau_zm in wpxp_pr1 + + !!! Input Variables + logical, intent(in) :: & + l_implemented ! Is this part of a larger host model (T/F) ? + + real( kind = core_rknd ), intent(in) :: & + dt ! Current timestep duration [s] + + real( kind = core_rknd ), intent(in) :: & + fcor, & ! Coriolis forcing [s^-1] + sfc_elevation ! Elevation of ground level [m AMSL] + + integer, intent(in) :: & + hydromet_dim ! Total number of hydrometeors [#] + + ! Input Variables + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + thlm_forcing, & ! theta_l forcing (thermodynamic levels) [K/s] + rtm_forcing, & ! r_t forcing (thermodynamic levels) [(kg/kg)/s] + um_forcing, & ! u wind forcing (thermodynamic levels) [m/s/s] + vm_forcing, & ! v wind forcing (thermodynamic levels) [m/s/s] + wprtp_forcing, & ! forcing (momentum levels) [m*K/s^2] + wpthlp_forcing, & ! forcing (momentum levels) [m*(kg/kg)/s^2] + rtp2_forcing, & ! forcing (momentum levels) [(kg/kg)^2/s] + thlp2_forcing, & ! forcing (momentum levels) [K^2/s] + rtpthlp_forcing, & ! forcing (momentum levels) [K*(kg/kg)/s] + wm_zm, & ! w mean wind component on momentum levels [m/s] + wm_zt, & ! w mean wind component on thermo. levels [m/s] + p_in_Pa, & ! Air pressure (thermodynamic levels) [Pa] + rho_zm, & ! Air density on momentum levels [kg/m^3] + rho, & ! Air density on thermodynamic levels [kg/m^3] + exner, & ! Exner function (thermodynamic levels) [-] + rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] + rho_ds_zt, & ! Dry, static density on thermo. levels [kg/m^3] + invrs_rho_ds_zm, & ! Inv. dry, static density @ momentum levs. [m^3/kg] + invrs_rho_ds_zt, & ! Inv. dry, static density @ thermo. levs. [m^3/kg] + thv_ds_zm, & ! Dry, base-state theta_v on momentum levs. [K] + thv_ds_zt, & ! Dry, base-state theta_v on thermo. levs. [K] + rfrzm ! Total ice-phase water mixing ratio [kg/kg] + + logical, intent(in) :: do_expldiff + +#ifdef CLUBBND_CAM + real( kind = core_rknd ), intent(in) :: varmu +#endif + + real( kind = core_rknd ), dimension(gr%nz,hydromet_dim), intent(in) :: & + hydromet ! Collection of hydrometeors [units vary] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + radf ! Buoyancy production at the CL top due to LW radiative cooling [m^2/s^3] + + real( kind = core_rknd ), dimension(gr%nz, hydromet_dim), intent(in) :: & + wphydrometp, & ! Covariance of w and a hydrometeor [(m/s) ] + wp2hmp, & ! Third-order moment: < w'^2 hm' > [(m/s)^2 ] + rtphmp_zt, & ! Covariance of rt and hm (on t-levs.) [(kg/kg) ] + thlphmp_zt ! Covariance of thl and hm (on t-levs.) [K ] + + real( kind = core_rknd ), intent(in) :: & + wpthlp_sfc, & ! w' theta_l' at surface [(m K)/s] + wprtp_sfc, & ! w' r_t' at surface [(kg m)/( kg s)] + upwp_sfc, & ! u'w' at surface [m^2/s^2] + vpwp_sfc ! v'w' at surface [m^2/s^2] + + ! Passive scalar variables + real( kind = core_rknd ), intent(in), dimension(gr%nz,sclr_dim) :: & + sclrm_forcing ! Passive scalar forcing [{units vary}/s] + + real( kind = core_rknd ), intent(in), dimension(sclr_dim) :: & + wpsclrp_sfc ! Scalar flux at surface [{units vary} m/s] + + ! Eddy passive scalar variables + real( kind = core_rknd ), intent(in), dimension(gr%nz,edsclr_dim) :: & + edsclrm_forcing ! Eddy passive scalar forcing [{units vary}/s] + + real( kind = core_rknd ), intent(in), dimension(edsclr_dim) :: & + wpedsclrp_sfc ! Eddy-Scalar flux at surface [{units vary} m/s] + + ! Host model horizontal grid spacing, if part of host model. + real( kind = core_rknd ), intent(in) :: & + host_dx, & ! East-West horizontal grid spacing [m] + host_dy ! North-South horizontal grid spacing [m] + + !!! Input/Output Variables + ! These are prognostic or are planned to be in the future + real( kind = core_rknd ), intent(inout), dimension(gr%nz) :: & + um, & ! u mean wind component (thermodynamic levels) [m/s] + upwp, & ! u'w' (momentum levels) [m^2/s^2] + vm, & ! v mean wind component (thermodynamic levels) [m/s] + vpwp, & ! v'w' (momentum levels) [m^2/s^2] + up2, & ! u'^2 (momentum levels) [m^2/s^2] + vp2, & ! v'^2 (momentum levels) [m^2/s^2] + rtm, & ! total water mixing ratio, r_t (thermo. levels) [kg/kg] + wprtp, & ! w' r_t' (momentum levels) [(kg/kg) m/s] + thlm, & ! liq. water pot. temp., th_l (thermo. levels) [K] + wpthlp, & ! w' th_l' (momentum levels) [(m/s) K] + rtp2, & ! r_t'^2 (momentum levels) [(kg/kg)^2] + thlp2, & ! th_l'^2 (momentum levels) [K^2] + rtpthlp, & ! r_t' th_l' (momentum levels) [(kg/kg) K] + wp2, & ! w'^2 (momentum levels) [m^2/s^2] + wp3 ! w'^3 (thermodynamic levels) [m^3/s^3] + + ! Passive scalar variables + real( kind = core_rknd ), intent(inout), dimension(gr%nz,sclr_dim) :: & + sclrm, & ! Passive scalar mean (thermo. levels) [units vary] + wpsclrp, & ! w'sclr' (momentum levels) [{units vary} m/s] + sclrp2, & ! sclr'^2 (momentum levels) [{units vary}^2] + sclrprtp, & ! sclr'rt' (momentum levels) [{units vary} (kg/kg)] + sclrpthlp ! sclr'thl' (momentum levels) [{units vary} K] + +#ifdef GFDL + real( kind = core_rknd ), intent(inout), dimension(gr%nz,sclr_dim) :: & ! h1g, 2010-06-16 + sclrm_trsport_only ! Passive scalar concentration due to pure transport [{units vary}/s] +#endif + + ! Eddy passive scalar variable + real( kind = core_rknd ), intent(inout), dimension(gr%nz,edsclr_dim) :: & + edsclrm ! Eddy passive scalar mean (thermo. levels) [units vary] + + ! Variables that need to be output for use in other parts of the CLUBB + ! code, such as microphysics (rcm, pdf_params), forcings (rcm), and/or + ! BUGSrad (cloud_cover). + real( kind = core_rknd ), intent(out), dimension(gr%nz) :: & + rcm, & ! cloud water mixing ratio, r_c (thermo. levels) [kg/kg] + rcm_in_layer, & ! rcm in cloud layer [kg/kg] + cloud_cover ! cloud cover [-] + + type(pdf_parameter), dimension(gr%nz), intent(out) :: & + pdf_params ! PDF parameters [units vary] + + ! Variables that need to be output for use in host models + real( kind = core_rknd ), intent(out), dimension(gr%nz) :: & + wprcp, & ! w'r_c' (momentum levels) [(kg/kg) m/s] + cloud_frac, & ! cloud fraction (thermodynamic levels) [-] + ice_supersat_frac ! ice cloud fraction (thermodynamic levels) [-] + + ! Eric Raut declared this variable solely for output to disk + real( kind = core_rknd ), dimension(gr%nz) :: & + rc_coef ! Coefficient of X' R_l' in Eq. (34) [-] + +#if defined(CLUBB_CAM) || defined(GFDL) + real( kind = core_rknd ), intent(out), dimension(gr%nz) :: & + khzt, & ! eddy diffusivity on thermo levels + khzm, & ! eddy diffusivity on momentum levels + thlprcp_out +#endif + +#ifdef CLUBB_CAM + real( kind = core_rknd), intent(out), dimension(gr%nz) :: & + qclvar ! cloud water variance +#endif + + real( kind = core_rknd ), dimension(gr%nz) :: & + Km_zm + + real( kind = core_rknd ):: newmu + + !!! Output Variable + ! Diagnostic, for if some calculation goes amiss. + integer, intent(inout) :: err_code + +#ifdef GFDL + ! hlg, 2010-06-16 + real( kind = core_rknd ), intent(inOUT), dimension(gr%nz, min(1,sclr_dim) , 2) :: & + RH_crit ! critical relative humidity for droplet and ice nucleation +! ---> h1g, 2012-06-14 + logical, intent(in) :: do_liquid_only_in_clubb +! <--- h1g, 2012-06-14 +#endif + + !!! Local Variables + integer :: i, k, ixind, & + err_code_pdf_closure, err_code_surface + + real( kind = core_rknd ), dimension(gr%nz) :: & + sigma_sqd_w, & ! PDF width parameter (momentum levels) [-] + sqrt_em_zt, & ! sqrt( em ) on zt levels; where em is TKE [m/s] + gamma_Skw_fnc, & ! Gamma as a function of skewness [???] + Lscale_pert_1, Lscale_pert_2, & ! For avg. calculation of Lscale [m] + thlm_pert_1, thlm_pert_2, & ! For avg. calculation of Lscale [K] + rtm_pert_1, rtm_pert_2, & ! For avg. calculation of Lscale [kg/kg] + thlm_pert_pos_rt, thlm_pert_neg_rt, & ! For avg. calculation of Lscale [K] + rtm_pert_pos_rt, rtm_pert_neg_rt ! For avg. calculation of Lscale [kg/kg] + !Lscale_weight Uncomment this if you need to use this vairable at some point. + + ! For pdf_closure + real( kind = core_rknd ), dimension(gr%nz,sclr_dim) :: & + wpsclrp_zt, & ! w' sclr' on thermo. levels + sclrp2_zt, & ! sclr'^2 on thermo. levels + sclrprtp_zt, & ! sclr' r_t' on thermo. levels + sclrpthlp_zt ! sclr' th_l' on thermo. levels + + real( kind = core_rknd ), dimension(gr%nz) :: & + p_in_Pa_zm, & ! Pressure interpolated to momentum levels [Pa] + exner_zm, & ! Exner interpolated to momentum levels [-] + w_1_zm, & ! Mean w (1st PDF component) [m/s] + w_2_zm, & ! Mean w (2nd PDF component) [m/s] + varnce_w_1_zm, & ! Variance of w (1st PDF component) [m^2/s^2] + varnce_w_2_zm, & ! Variance of w (2nd PDF component) [m^2/s^2] + mixt_frac_zm ! Weight of 1st PDF component (Sk_w dependent) [-] + + real( kind = core_rknd ), dimension(gr%nz,hydromet_dim) :: & + wphydrometp_zt, & ! Covariance of w and hm (on t-levs.) [(m/s) ] + wp2hmp_zm, & ! Moment (on m-levs.) [(m/s)^2 ] + rtphmp, & ! Covariance of rt and hm [(kg/kg) ] + thlphmp ! Covariance of thl and hm [K ] + + integer :: & + wprtp_cl_num, & ! Instance of w'r_t' clipping (1st or 3rd). + wpthlp_cl_num, & ! Instance of w'th_l' clipping (1st or 3rd). + wpsclrp_cl_num, & ! Instance of w'sclr' clipping (1st or 3rd). + upwp_cl_num, & ! Instance of u'w' clipping (1st or 2nd). + vpwp_cl_num ! Instance of v'w' clipping (1st or 2nd). + + ! These local variables are declared because they originally belong on the momentum + ! grid levels, but pdf_closure outputs them on the thermodynamic grid levels. + real( kind = core_rknd ), dimension(gr%nz) :: & + wp4_zt, & ! w'^4 (on thermo. grid) [m^4/s^4] + wpthvp_zt, & ! Buoyancy flux (on thermo. grid) [(K m)/s] + rtpthvp_zt, & ! r_t' th_v' (on thermo. grid) [(kg K)/kg] + thlpthvp_zt, & ! th_l' th_v' (on thermo. grid) [K^2] + wprcp_zt, & ! w' r_c' (on thermo. grid) [(m kg)/(s kg)] + rtprcp_zt, & ! r_t' r_c' (on thermo. grid) [(kg^2)/(kg^2)] + thlprcp_zt, & ! th_l' r_c' (on thermo. grid) [(K kg)/kg] + rcp2_zt, & ! r_c'^2 (on thermo. grid) [(kg^2)/(kg^2)] + rc_coef_zt ! X'R_l' coef. (on thermo. grid) [-] + + real( kind = core_rknd ), dimension(gr%nz, sclr_dim) :: & + sclrpthvp_zt, & ! sclr'th_v' (on thermo. grid) + sclrprcp_zt ! sclr'rc' (on thermo. grid) + + real( kind = core_rknd ), dimension(gr%nz) :: & + wprtp2_zm, & ! w'rt'^2 on momentum grid [m kg^2/kg^2] + wp2rtp_zm, & ! w'^2 rt' on momentum grid [m^2 kg/kg] + wpthlp2_zm, & ! w'thl'^2 on momentum grid [m K^2/s] + wp2thlp_zm, & ! w'^2 thl' on momentum grid [m^2 K/s^2] + wprtpthlp_zm, & ! w'rt'thl' on momentum grid [m kg K/kg s] + cloud_frac_zm, & ! Cloud Fraction on momentum grid [-] + ice_supersat_frac_zm, & ! Ice Cloud Fraction on momentum grid [-] + rtm_zm, & ! Total water mixing ratio [kg/kg] + thlm_zm, & ! Liquid potential temperature [kg/kg] + rcm_zm, & ! Liquid water mixing ratio on momentum grid [kg/kg] + wp2thvp_zm, & ! w'^2 th_v' on momentum grid [m^2 K/s^2] + wp2rcp_zm, & ! w'^2 rc' on momentum grid [m^2 kg/kg s^2] + sign_rtpthlp ! sign of the covariance rtpthlp [-] + + real( kind = core_rknd ), dimension(gr%nz,sclr_dim) :: & + wpsclrprtp_zm, & ! w'sclr'rt' on momentum grid + wpsclrp2_zm, & ! w'sclr'^2 on momentum grid + wpsclrpthlp_zm, & ! w'sclr'thl' on momentum grid + wp2sclrp_zm, & ! w'^2 sclr' on momentum grid + sclrm_zm ! Passive scalar mean on momentum grid + + real( kind = core_rknd ) :: & + rtm_integral_before, & + rtm_integral_after, & + rtm_integral_forcing, & + rtm_flux_top, & + rtm_flux_sfc, & + rtm_spur_src, & + thlm_integral_before, & + thlm_integral_after, & + thlm_integral_forcing, & + thlm_flux_top, & + thlm_flux_sfc, & + thlm_spur_src, & + mu_pert_1, mu_pert_2, & ! For l_avg_Lscale + mu_pert_pos_rt, mu_pert_neg_rt ! For l_Lscale_plume_centered + + !The following variables are defined for use when l_use_ice_latent = .true. + type(pdf_parameter), dimension(gr%nz) :: & + pdf_params_frz, & + pdf_params_zm_frz + + + real( kind = core_rknd ), dimension(gr%nz) :: & + rtm_frz, & + thlm_frz, & + wp4_zt_frz, & + wprtp2_frz, & + wp2rtp_frz, & + wpthlp2_frz, & + wp2thlp_frz, & + wprtpthlp_frz, & + cloud_frac_frz, & + ice_supersat_frac_frz, & + rcm_frz, & + wpthvp_frz, & + wpthvp_zt_frz, & + wp2thvp_frz, & + wp2thvp_zm_frz, & + rtpthvp_frz, & + rtpthvp_zt_frz, & + thlpthvp_frz, & + thlpthvp_zt_frz, & + wprcp_zt_frz, & + wp2rcp_frz + + real( kind = core_rknd ), dimension(gr%nz) :: & + rtprcp_zt_frz, & + thlprcp_zt_frz, & + rcp2_zt_frz, & + rc_coef_zt_frz, & + wp4_frz, & + wprtp2_zm_frz, & + wp2rtp_zm_frz, & + wpthlp2_zm_frz, & + wp2thlp_zm_frz, & + wprtpthlp_zm_frz, & + cloud_frac_zm_frz, & + ice_supersat_frac_zm_frz, & + rcm_zm_frz, & + wprcp_frz, & + wp2rcp_zm_frz, & + rtprcp_frz, & + thlprcp_frz, & + rcp2_frz, & + rtm_zm_frz, & + thlm_zm_frz, & + rc_coef_frz + + real( kind = core_rknd ), dimension(gr%nz,sclr_dim) :: & + wpsclrprtp_frz, & + wpsclrp2_frz, & + sclrpthvp_zt_frz, & + wpsclrpthlp_frz, & + sclrprcp_zt_frz, & + wp2sclrp_frz, & + wpsclrprtp_zm_frz, & + wpsclrp2_zm_frz, & + sclrpthvp_frz, & + wpsclrpthlp_zm_frz, & + sclrprcp_frz, & + wp2sclrp_zm_frz + + real( kind = core_rknd ) :: & + cloud_frac_1_refined, & ! cloud_frac_1 computed on refined grid + cloud_frac_2_refined, & ! cloud_frac_2 computed on refined grid + rc_1_refined, & ! rc_1 computed on refined grid + rc_2_refined, & ! rc_2 computed on refined grid + cloud_frac_refined, & ! cloud_frac gridbox mean on refined grid + rcm_refined, & ! rcm gridbox mean on refined grid + thlm1000, & + thlm700 + + real( kind = core_rknd ), dimension(gr%nz) :: & + rrm ! Rain water mixing ratio + + real( kind = core_rknd ), dimension(gr%nz) :: & + stability_correction, & ! Stability correction factor + tau_N2_zm, & ! Tau with a static stability correction applied to it [s] + tau_C6_zm, & ! Tau values used for the C6 (pr1) term in wpxp [s] + tau_C1_zm ! Tau values used for the C1 (dp1) term in wp2 [s] + + real( kind = core_rknd ) :: Lscale_max + + !----- Begin Code ----- + + ! Determine the maximum allowable value for Lscale (in meters). + call set_Lscale_max( l_implemented, host_dx, host_dy, & ! intent(in) + Lscale_max ) ! intent(out) + + if ( l_stats .and. l_stats_samp ) then + ! Spurious source will only be calculated if rtm_ma and thlm_ma are zero. + ! Therefore, wm must be zero or l_implemented must be true. + if ( l_implemented .or. ( all( wm_zt == 0._core_rknd ) .and. & + all( wm_zm == 0._core_rknd ) ) ) then + ! Get the vertical integral of rtm and thlm before this function begins + ! so that spurious source can be calculated + rtm_integral_before & + = vertical_integral( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & + rtm(2:gr%nz), gr%invrs_dzt(2:gr%nz) ) + + thlm_integral_before & + = vertical_integral( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & + thlm(2:gr%nz), gr%invrs_dzt(2:gr%nz) ) + end if + end if + + !---------------------------------------------------------------- + ! Test input variables + !---------------------------------------------------------------- + if ( clubb_at_least_debug_level( 2 ) ) then + call parameterization_check & + ( thlm_forcing, rtm_forcing, um_forcing, vm_forcing, & ! intent(in) + wm_zm, wm_zt, p_in_Pa, rho_zm, rho, exner, & ! intent(in) + rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & ! intent(in) + invrs_rho_ds_zt, thv_ds_zm, thv_ds_zt, & ! intent(in) + wpthlp_sfc, wprtp_sfc, upwp_sfc, vpwp_sfc, & ! intent(in) + um, upwp, vm, vpwp, up2, vp2, & ! intent(in) + rtm, wprtp, thlm, wpthlp, & ! intent(in) + wp2, wp3, rtp2, thlp2, rtpthlp, & ! intent(in) + "beginning of ", & ! intent(in) + wpsclrp_sfc, wpedsclrp_sfc, & ! intent(in) + sclrm, wpsclrp, sclrp2, sclrprtp, sclrpthlp, & ! intent(in) + sclrm_forcing, edsclrm, edsclrm_forcing, & ! intent(in) + err_code ) ! intent(inout) + end if + !----------------------------------------------------------------------- + + if ( l_stats_samp ) then + call stat_update_var( irfrzm, rfrzm, & ! intent(in) + stats_zt ) ! intent(inout) + end if + + ! Set up budget stats variables. + if ( l_stats_samp ) then + + call stat_begin_update( iwp2_bt, wp2 / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_begin_update( ivp2_bt, vp2 / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_begin_update( iup2_bt, up2 / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_begin_update( iwprtp_bt, wprtp / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_begin_update( iwpthlp_bt, wpthlp / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_begin_update( irtp2_bt, rtp2 / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_begin_update( ithlp2_bt, thlp2 / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_begin_update( irtpthlp_bt, rtpthlp / dt, & ! intent(in) + stats_zm ) ! intent(inout) + + call stat_begin_update( irtm_bt, rtm / dt, & ! intent(in) + stats_zt ) ! intent(inout) + call stat_begin_update( ithlm_bt, thlm / dt, & ! intent(in) + stats_zt ) ! intent(inout) + call stat_begin_update( ium_bt, um / dt, & ! intent(in) + stats_zt ) ! intent(inout) + call stat_begin_update( ivm_bt, vm / dt, & ! intent(in) + stats_zt ) ! intent(inout) + call stat_begin_update( iwp3_bt, wp3 / dt, & ! intent(in) + stats_zt ) ! intent(inout) + + end if + + ! SET SURFACE VALUES OF FLUXES (BROUGHT IN) + ! We only do this for host models that do not apply the flux + ! elsewhere in the code (e.g. WRF). In other cases the _sfc variables will + ! only be used to compute the variance at the surface. -dschanen 8 Sept 2009 + if ( .not. l_host_applies_sfc_fluxes ) then + + wpthlp(1) = wpthlp_sfc + wprtp(1) = wprtp_sfc + upwp(1) = upwp_sfc + vpwp(1) = vpwp_sfc + + ! Set fluxes for passive scalars (if enabled) + if ( sclr_dim > 0 ) then + wpsclrp(1,1:sclr_dim) = wpsclrp_sfc(1:sclr_dim) + end if + + if ( edsclr_dim > 0 ) then + wpedsclrp(1,1:edsclr_dim) = wpedsclrp_sfc(1:edsclr_dim) + end if + + else + + wpthlp(1) = 0.0_core_rknd + wprtp(1) = 0.0_core_rknd + upwp(1) = 0.0_core_rknd + vpwp(1) = 0.0_core_rknd + + ! Set fluxes for passive scalars (if enabled) + if ( sclr_dim > 0 ) then + wpsclrp(1,1:sclr_dim) = 0.0_core_rknd + end if + + if ( edsclr_dim > 0 ) then + wpedsclrp(1,1:edsclr_dim) = 0.0_core_rknd + end if + + end if ! ~l_host_applies_sfc_fluxes + +#ifdef CLUBBND_CAM + newmu = varmu +#else + newmu = mu +#endif + + !--------------------------------------------------------------------------- + ! Interpolate wp3 to momentum levels, and wp2 to thermodynamic levels + ! and then compute Skw for m & t grid + !--------------------------------------------------------------------------- + + wp2_zt = max( zm2zt( wp2 ), w_tol_sqd ) ! Positive definite quantity + wp3_zm = zt2zm( wp3 ) + + Skw_zt(1:gr%nz) = Skw_func( wp2_zt(1:gr%nz), wp3(1:gr%nz) ) + Skw_zm(1:gr%nz) = Skw_func( wp2(1:gr%nz), wp3_zm(1:gr%nz) ) + + if ( l_stats_samp ) then + call stat_update_var( iSkw_zt, Skw_zt, & ! In + stats_zt ) ! In/Out + call stat_update_var( iSkw_zm, Skw_zm, & + stats_zm ) ! In/Out + end if + + ! The right hand side of this conjunction is only for reducing cpu time, + ! since the more complicated formula is mathematically equivalent + if ( l_gamma_Skw .and. ( gamma_coef /= gamma_coefb ) ) then + !---------------------------------------------------------------- + ! Compute gamma as a function of Skw - 14 April 06 dschanen + !---------------------------------------------------------------- + + gamma_Skw_fnc = gamma_coefb + (gamma_coef-gamma_coefb) & + *exp( -(1.0_core_rknd/2.0_core_rknd) * (Skw_zm/gamma_coefc)**2 ) + + else + + gamma_Skw_fnc = gamma_coef + + end if + + ! Compute sigma_sqd_w (dimensionless PDF width parameter) + sigma_sqd_w = compute_sigma_sqd_w( gamma_Skw_fnc, wp2, thlp2, rtp2, wpthlp, wprtp ) + + if ( l_stats_samp ) then + call stat_update_var( igamma_Skw_fnc, gamma_Skw_fnc, & ! intent(in) + stats_zm ) ! intent(inout) + endif + + ! Smooth in the vertical using interpolation + sigma_sqd_w = zt2zm( zm2zt( sigma_sqd_w ) ) + + ! Interpolate the the stats_zt grid + sigma_sqd_w_zt = max( zm2zt( sigma_sqd_w ), zero_threshold ) ! Pos. def. quantity + + ! Compute the a3 coefficient (formula 25 in `Equations for CLUBB') +! a3_coef = 3.0_core_rknd * sigma_sqd_w*sigma_sqd_w & +! + 6.0_core_rknd*(1.0_core_rknd-sigma_sqd_w)*sigma_sqd_w & +! + (1.0_core_rknd-sigma_sqd_w)*(1.0_core_rknd-sigma_sqd_w) & +! - 3.0_core_rknd + + ! This is a simplified version of the formula above. + a3_coef = -2._core_rknd * ( 1._core_rknd - sigma_sqd_w )**2 + + ! We found we obtain fewer spikes in wp3 when we clip a3 to be no greater + ! than -1.4 -dschanen 4 Jan 2011 + a3_coef = max( a3_coef, -1.4_core_rknd ) ! Known magic number + + a3_coef_zt = zm2zt( a3_coef ) + + !--------------------------------------------------------------------------- + ! Interpolate thlp2, rtp2, and rtpthlp to thermodynamic levels, + !--------------------------------------------------------------------------- + + ! Interpolate variances to the stats_zt grid (statistics and closure) + thlp2_zt = max( zm2zt( thlp2 ), thl_tol**2 ) ! Positive def. quantity + rtp2_zt = max( zm2zt( rtp2 ), rt_tol**2 ) ! Positive def. quantity + rtpthlp_zt = zm2zt( rtpthlp ) + + ! Compute skewness velocity for stats output purposes + if ( iSkw_velocity > 0 ) then + Skw_velocity = ( 1.0_core_rknd / ( 1.0_core_rknd - sigma_sqd_w(1:gr%nz) ) ) & + * ( wp3_zm(1:gr%nz) / max( wp2(1:gr%nz), w_tol_sqd ) ) + end if + + ! Compute wp3 / wp2 on zt levels. Always use the interpolated value in the + ! denominator since it's less likely to create spikes + wp3_on_wp2_zt = ( wp3(1:gr%nz) / max( wp2_zt(1:gr%nz), w_tol_sqd ) ) + + ! Clip wp3_on_wp2_zt if it's too large + do k=1, gr%nz + if( wp3_on_wp2_zt(k) < 0._core_rknd ) then + wp3_on_wp2_zt = max( -1000._core_rknd, wp3_on_wp2_zt ) + else + wp3_on_wp2_zt = min( 1000._core_rknd, wp3_on_wp2_zt ) + end if + end do + + ! Compute wp3_on_wp2 by interpolating wp3_on_wp2_zt + wp3_on_wp2 = zt2zm( wp3_on_wp2_zt ) + + ! Smooth again as above + wp3_on_wp2_zt = zm2zt( wp3_on_wp2 ) + + !---------------------------------------------------------------- + ! Call closure scheme + !---------------------------------------------------------------- + + ! Put passive scalar input on the t grid for the PDF + do i = 1, sclr_dim, 1 + wpsclrp_zt(:,i) = zm2zt( wpsclrp(:,i) ) + sclrp2_zt(:,i) = max( zm2zt( sclrp2(:,i) ), zero_threshold ) ! Pos. def. quantity + sclrprtp_zt(:,i) = zm2zt( sclrprtp(:,i) ) + sclrpthlp_zt(:,i) = zm2zt( sclrpthlp(:,i) ) + end do ! i = 1, sclr_dim, 1 + + ! Interpolate hydrometeor mixed moments to momentum levels. + do i = 1, hydromet_dim, 1 + wphydrometp_zt(:,i) = zm2zt( wphydrometp(:,i) ) + enddo ! i = 1, hydromet_dim, 1 + + + do k = 1, gr%nz, 1 + + call pdf_closure & + ( hydromet_dim, p_in_Pa(k), exner(k), thv_ds_zt(k), wm_zt(k), & ! intent(in) + wp2_zt(k), wp3(k), sigma_sqd_w_zt(k), & ! intent(in) + Skw_zt(k), rtm(k), rtp2_zt(k), & ! intent(in) + zm2zt( wprtp, k ), thlm(k), thlp2_zt(k), & ! intent(in) + zm2zt( wpthlp, k ), rtpthlp_zt(k), sclrm(k,:), & ! intent(in) + wpsclrp_zt(k,:), sclrp2_zt(k,:), sclrprtp_zt(k,:), & ! intent(in) + sclrpthlp_zt(k,:), k, & ! intent(in) +#ifdef GFDL + RH_crit(k, : , :), do_liquid_only_in_clubb, & ! intent(in) +#endif + wphydrometp_zt(k,:), wp2hmp(k,:), & ! intent(in) + rtphmp_zt(k,:), thlphmp_zt(k,:), & ! intent(in) + wp4_zt(k), wprtp2(k), wp2rtp(k), & ! intent(out) + wpthlp2(k), wp2thlp(k), wprtpthlp(k), & ! intent(out) + cloud_frac(k), ice_supersat_frac(k), & ! intent(out) + rcm(k), wpthvp_zt(k), wp2thvp(k), rtpthvp_zt(k), & ! intent(out) + thlpthvp_zt(k), wprcp_zt(k), wp2rcp(k), rtprcp_zt(k), & ! intent(out) + thlprcp_zt(k), rcp2_zt(k), pdf_params(k), & ! intent(out) + err_code_pdf_closure, & ! intent(out) + wpsclrprtp(k,:), wpsclrp2(k,:), sclrpthvp_zt(k,:), & ! intent(out) + wpsclrpthlp(k,:), sclrprcp_zt(k,:), wp2sclrp(k,:), & ! intent(out) + rc_coef_zt(k) ) ! intent(out) + + ! Subroutine may produce NaN values, and if so, exit + ! gracefully. + ! Joshua Fasching March 2008 + + if ( fatal_error( err_code_pdf_closure ) ) then + + if ( clubb_at_least_debug_level( 1 ) ) then + write(fstderr,*) "At grid level = ",k + end if + + err_code = err_code_pdf_closure + end if + + end do ! k = 1, gr%nz, 1 + + if ( l_refine_grid_in_cloud ) then + + ! Compute cloud_frac and rcm on a refined grid to improve parameterization + ! of subgrid clouds + do k=1, gr%nz + + if ( pdf_params(k)%chi_1/pdf_params(k)%stdev_chi_1 > -1._core_rknd ) then + + ! Recalculate cloud_frac and r_c for each PDF component + + call calc_vert_avg_cf_component & + ( gr%nz, k, gr%zt, pdf_params%chi_1, & ! Intent(in) + pdf_params%stdev_chi_1, (/(chi_at_liq_sat,i=1,gr%nz)/), & ! Intent(in) + cloud_frac_1_refined, rc_1_refined ) ! Intent(out) + + call calc_vert_avg_cf_component & + ( gr%nz, k, gr%zt, pdf_params%chi_2, & ! Intent(in) + pdf_params%stdev_chi_2, (/(chi_at_liq_sat,i=1,gr%nz)/), & ! Intent(in) + cloud_frac_2_refined, rc_2_refined ) ! Intent(out) + + cloud_frac_refined = compute_mean_binormal & + ( cloud_frac_1_refined, cloud_frac_2_refined, & + pdf_params(k)%mixt_frac ) + + rcm_refined = compute_mean_binormal & + ( rc_1_refined, rc_2_refined, pdf_params(k)%mixt_frac ) + + if ( l_interactive_refined ) then + ! I commented out the lines that modify the values in pdf_params, as it seems that + ! these values need to remain consistent with the rest of the PDF. + ! Eric Raut Jun 2014 + ! Replace pdf_closure estimates with refined estimates + ! pdf_params(k)%rc_1 = rc_1_refined + ! pdf_params(k)%rc_2 = rc_2_refined + rcm(k) = rcm_refined + + ! pdf_params(k)%cloud_frac_1 = cloud_frac_1_refined + ! pdf_params(k)%cloud_frac_2 = cloud_frac_2_refined + cloud_frac(k) = cloud_frac_refined + end if + + else + ! Set these equal to the non-refined values so we have something to + ! output to stats! + cloud_frac_refined = cloud_frac(k) + rcm_refined = rcm(k) + end if ! pdf_params(k)%chi_1/pdf_params(k)%stdev_chi_1 > -1._core_rknd + + ! Stats output + if ( l_stats_samp ) then + call stat_update_var_pt( icloud_frac_refined, k, cloud_frac_refined, stats_zt ) + call stat_update_var_pt( ircm_refined, k, rcm_refined, stats_zt ) + end if + + end do ! k=1, gr%nz + + end if ! l_refine_grid_in_cloud + + if( l_rtm_nudge ) then + ! Nudge rtm to prevent excessive drying + where( rtm < rtm_min .and. gr%zt < rtm_nudge_max_altitude ) + rtm = rtm + (rtm_ref - rtm) * ( dt / ts_nudge ) + end where + end if + + + if ( l_call_pdf_closure_twice ) then + ! Call pdf_closure a second time on momentum levels, to + ! output (rather than interpolate) the variables which + ! belong on the momentum levels. + + ! Interpolate sclrm to the momentum level for use in + ! the second call to pdf_closure + do i = 1, sclr_dim + sclrm_zm(:,i) = zt2zm( sclrm(:,i) ) + ! Clip if extrap. causes sclrm_zm to be less than sclr_tol + sclrm_zm(gr%nz,i) = max( sclrm_zm(gr%nz,i), sclr_tol(i) ) + end do ! i = 1, sclr_dim + + ! Interpolate pressure, p_in_Pa, to momentum levels. + ! The pressure at thermodynamic level k = 1 has been set to be the surface + ! (or model lower boundary) pressure. Since the surface (or model lower + ! boundary) is located at momentum level k = 1, the pressure there is + ! p_sfc, which is p_in_Pa(1). Thus, p_in_Pa_zm(1) = p_in_Pa(1). + p_in_Pa_zm(:) = zt2zm( p_in_Pa ) + p_in_Pa_zm(1) = p_in_Pa(1) + + ! Clip pressure if the extrapolation leads to a negative value of pressure + p_in_Pa_zm(gr%nz) = max( p_in_Pa_zm(gr%nz), 0.5_core_rknd*p_in_Pa(gr%nz) ) + ! Set exner at momentum levels, exner_zm, based on p_in_Pa_zm. + exner_zm(:) = (p_in_Pa_zm(:)/p0)**kappa + + rtm_zm = zt2zm( rtm ) + ! Clip if extrapolation at the top level causes rtm_zm to be < rt_tol + rtm_zm(gr%nz) = max( rtm_zm(gr%nz), rt_tol ) + thlm_zm = zt2zm( thlm ) + ! Clip if extrapolation at the top level causes thlm_zm to be < thl_tol + thlm_zm(gr%nz) = max( thlm_zm(gr%nz), thl_tol ) + + ! Interpolate hydrometeor mixed moments to momentum levels. + do i = 1, hydromet_dim, 1 + rtphmp(:,i) = zt2zm( rtphmp_zt(:,i) ) + thlphmp(:,i) = zt2zm( thlphmp_zt(:,i) ) + wp2hmp_zm(:,i) = zt2zm( wp2hmp(:,i) ) + enddo ! i = 1, hydromet_dim, 1 + + ! Call pdf_closure to output the variables which belong on the momentum grid. + do k = 1, gr%nz, 1 + + call pdf_closure & + ( hydromet_dim, p_in_Pa_zm(k), exner_zm(k), thv_ds_zm(k), wm_zm(k), & ! intent(in) + wp2(k), wp3_zm(k), sigma_sqd_w(k), & ! intent(in) + Skw_zm(k), rtm_zm(k), rtp2(k), & ! intent(in) + wprtp(k), thlm_zm(k), thlp2(k), & ! intent(in) + wpthlp(k), rtpthlp(k), sclrm_zm(k,:), & ! intent(in) + wpsclrp(k,:), sclrp2(k,:), sclrprtp(k,:), & ! intent(in) + sclrpthlp(k,:), k, & ! intent(in) +#ifdef GFDL + RH_crit(k, : , :), do_liquid_only_in_clubb, & ! intent(in) +#endif + wphydrometp(k,:), wp2hmp_zm(k,:), & ! intent(in) + rtphmp(k,:), thlphmp(k,:), & ! intent(in) + wp4(k), wprtp2_zm(k), wp2rtp_zm(k), & ! intent(out) + wpthlp2_zm(k), wp2thlp_zm(k), wprtpthlp_zm(k), & ! intent(out) + cloud_frac_zm(k), ice_supersat_frac_zm(k), & ! intent(out) + rcm_zm(k), wpthvp(k), wp2thvp_zm(k), rtpthvp(k), & ! intent(out) + thlpthvp(k), wprcp(k), wp2rcp_zm(k), rtprcp(k), & ! intent(out) + thlprcp(k), rcp2(k), pdf_params_zm(k), & ! intent(out) + err_code_pdf_closure, & ! intent(out) + wpsclrprtp_zm(k,:), wpsclrp2_zm(k,:), sclrpthvp(k,:), & ! intent(out) + wpsclrpthlp_zm(k,:), sclrprcp(k,:), wp2sclrp_zm(k,:), & ! intent(out) + rc_coef(k) ) ! intent(out) + + ! Subroutine may produce NaN values, and if so, exit + ! gracefully. + ! Joshua Fasching March 2008 + + + if ( fatal_error( err_code_pdf_closure ) ) then + + if ( clubb_at_least_debug_level( 1 ) ) then + write(fstderr,*) "At grid level = ",k + end if + + err_code = err_code_pdf_closure + end if + + end do ! k = 1, gr%nz, 1 + + else ! l_call_pdf_closure_twice is false + + ! Interpolate momentum variables output from the first call to + ! pdf_closure back to momentum grid. + ! Since top momentum level is higher than top thermo level, + ! Set variables at top momentum level to 0. + + ! Only do this for wp4 and rcp2 if we're saving stats, since they are not + ! used elsewhere in the parameterization + if ( iwp4 > 0 ) then + wp4 = max( zt2zm( wp4_zt ), zero_threshold ) ! Pos. def. quantity + wp4(gr%nz) = 0.0_core_rknd + end if + +#ifndef CLUBB_CAM + ! CAM-CLUBB needs cloud water variance thus always compute this + if ( ircp2 > 0 ) then +#endif + rcp2 = max( zt2zm( rcp2_zt ), zero_threshold ) ! Pos. def. quantity +#ifndef CLUBB_CAM + rcp2(gr%nz) = 0.0_core_rknd + end if +#endif + + wpthvp = zt2zm( wpthvp_zt ) + wpthvp(gr%nz) = 0.0_core_rknd + thlpthvp = zt2zm( thlpthvp_zt ) + thlpthvp(gr%nz) = 0.0_core_rknd + rtpthvp = zt2zm( rtpthvp_zt ) + rtpthvp(gr%nz) = 0.0_core_rknd + wprcp = zt2zm( wprcp_zt ) + wprcp(gr%nz) = 0.0_core_rknd + rc_coef = zt2zm( rc_coef_zt ) + rc_coef(gr%nz) = 0.0_core_rknd + rtprcp = zt2zm( rtprcp_zt ) + rtprcp(gr%nz) = 0.0_core_rknd + thlprcp = zt2zm( thlprcp_zt ) + thlprcp(gr%nz) = 0.0_core_rknd + + ! Interpolate passive scalars back onto the m grid + do i = 1, sclr_dim + sclrpthvp(:,i) = zt2zm( sclrpthvp_zt(:,i) ) + sclrpthvp(gr%nz,i) = 0.0_core_rknd + sclrprcp(:,i) = zt2zm( sclrprcp_zt(:,i) ) + sclrprcp(gr%nz,i) = 0.0_core_rknd + end do ! i=1, sclr_dim + + end if ! l_call_pdf_closure_twice + + ! If l_trapezoidal_rule_zt is true, call trapezoidal_rule_zt for + ! thermodynamic-level variables output from pdf_closure. + ! ldgrant June 2009 + if ( l_trapezoidal_rule_zt ) then + call trapezoidal_rule_zt & + ( l_call_pdf_closure_twice, & ! intent(in) + wprtp2, wpthlp2, & ! intent(inout) + wprtpthlp, cloud_frac, ice_supersat_frac, & ! intent(inout) + rcm, wp2thvp, wpsclrprtp, wpsclrp2, & ! intent(inout) + wpsclrpthlp, pdf_params, & ! intent(inout) + wprtp2_zm, wpthlp2_zm, & ! intent(inout) + wprtpthlp_zm, cloud_frac_zm, & ! intent(inout) + ice_supersat_frac_zm, rcm_zm, wp2thvp_zm, & ! intent(inout) + wpsclrprtp_zm, wpsclrp2_zm, wpsclrpthlp_zm, & ! intent(inout) + pdf_params_zm ) ! intent(inout) + end if ! l_trapezoidal_rule_zt + + ! If l_trapezoidal_rule_zm is true, call trapezoidal_rule_zm for + ! the important momentum-level variabes output from pdf_closure. + ! ldgrant Feb. 2010 + if ( l_trapezoidal_rule_zm ) then + call trapezoidal_rule_zm & + ( wpthvp_zt, thlpthvp_zt, rtpthvp_zt, & ! intent(in) + wpthvp, thlpthvp, rtpthvp ) ! intent(inout) + end if ! l_trapezoidal_rule_zm + + ! Vince Larson clipped rcm in order to prevent rvm < 0. 5 Apr 2008. + ! This code won't work unless rtm >= 0 !!! + ! We do not clip rcm_in_layer because rcm_in_layer only influences + ! radiation, and we do not want to bother recomputing it. + ! Code is duplicated from below to ensure that relative humidity + ! is calculated properly. 3 Sep 2009 + call clip_rcm( rtm, 'rtm < rcm after pdf_closure', & ! intent (in) + rcm ) ! intent (inout) + + ! Compute variables cloud_cover and rcm_in_layer. + ! Added July 2009 + call compute_cloud_cover & + ( pdf_params, cloud_frac, rcm, & ! intent(in) + cloud_cover, rcm_in_layer ) ! intent(out) + + ! Use cloud_cover and rcm_in_layer to help boost cloud_frac and rcm to help + ! increase cloudiness at coarser grid resolutions. + if ( l_use_cloud_cover ) then + cloud_frac = cloud_cover + rcm = rcm_in_layer + end if + + ! Clip cloud fraction here if it still exceeds 1.0 due to round off + cloud_frac = min( 1.0_core_rknd, cloud_frac ) + ! Ditto with ice cloud fraction + ice_supersat_frac = min( 1.0_core_rknd, ice_supersat_frac ) + + if (l_use_ice_latent) then + !A third call to pdf_closure, with terms modified to include the effects + !of latent heating due to ice. Thlm and rtm add the effects of ice, and + !the terms are all renamed with "_frz" appended. The modified terms will + !be fed into the calculations of the turbulence terms. storer-3/14/13 + + !Also added rain for completeness. storer-3/4/14 + + if ( iirrm > 0 ) then + rrm = hydromet(:,iirrm) + else + rrm = zero + end if + + thlm_frz = thlm - (Lv / (Cp*exner) ) * rrm - (Ls / (Cp*exner) ) * rfrzm + rtm_frz = rtm + rrm + rfrzm + + + do k = 1, gr%nz, 1 + + call pdf_closure & + ( hydromet_dim, p_in_Pa(k), exner(k), thv_ds_zt(k), wm_zt(k), & ! intent(in) + wp2_zt(k), wp3(k), sigma_sqd_w_zt(k), & ! intent(in) + Skw_zt(k), rtm_frz(k), rtp2_zt(k), & ! intent(in) + zm2zt( wprtp, k ), thlm_frz(k), thlp2_zt(k), & ! intent(in) + zm2zt( wpthlp, k ), rtpthlp_zt(k), sclrm(k,:), & ! intent(in) + wpsclrp_zt(k,:), sclrp2_zt(k,:), sclrprtp_zt(k,:), & ! intent(in) + sclrpthlp_zt(k,:), k, & ! intent(in) +#ifdef GFDL + RH_crit(k, : , :), do_liquid_only_in_clubb, & ! intent(in) +#endif + wphydrometp_zt(k,:), wp2hmp(k,:), & ! intent(in) + rtphmp_zt(k,:), thlphmp_zt(k,:), & ! intent(in) + wp4_zt_frz(k), wprtp2_frz(k), wp2rtp_frz(k), & ! intent(out) + wpthlp2_frz(k), wp2thlp_frz(k), wprtpthlp_frz(k), & ! intent(out) + cloud_frac_frz(k), ice_supersat_frac_frz(k), & ! intent(out) + rcm_frz(k), wpthvp_zt_frz(k), wp2thvp_frz(k), rtpthvp_zt_frz(k), & ! intent(out) + thlpthvp_zt_frz(k), wprcp_zt_frz(k), wp2rcp_frz(k), rtprcp_zt_frz(k), & ! intent(out) + thlprcp_zt_frz(k), rcp2_zt_frz(k), pdf_params_frz(k), & ! intent(out) + err_code_pdf_closure, & ! intent(out) + wpsclrprtp_frz(k,:), wpsclrp2_frz(k,:), sclrpthvp_zt_frz(k,:), & ! intent(out) + wpsclrpthlp_frz(k,:), sclrprcp_zt_frz(k,:), wp2sclrp_frz(k,:), & ! intent(out) + rc_coef_zt_frz(k) ) ! intent(out) + + ! Subroutine may produce NaN values, and if so, exit gracefully. + ! Joshua Fasching March 2008 + + if ( fatal_error( err_code_pdf_closure ) ) then + + if ( clubb_at_least_debug_level ( 1 ) )then + write(fstderr,*) "At grid level = ", k + end if + + err_code = err_code_pdf_closure + end if + + end do !k=1, gr%nz, 1 + + + if( l_rtm_nudge ) then + ! Nudge rtm to prevent excessive drying + where( rtm < rtm_min .and. gr%zt < rtm_nudge_max_altitude ) + rtm = rtm + (rtm_ref - rtm) * ( dt / ts_nudge ) + end where + end if + + rtm_zm_frz = zt2zm( rtm_frz ) + ! Clip if extrapolation at the top level causes rtm_zm to be < rt_tol + rtm_zm_frz(gr%nz) = max( rtm_zm_frz(gr%nz), rt_tol ) + thlm_zm_frz = zt2zm( thlm_frz ) + ! Clip if extrapolation at the top level causes thlm_zm to be < thl_tol + thlm_zm_frz(gr%nz) = max( thlm_zm_frz(gr%nz), thl_tol ) + + if ( l_call_pdf_closure_twice ) then + ! Call pdf_closure again to output the variables which belong on the momentum grid. + do k=1, gr%nz, 1 + call pdf_closure & + ( hydromet_dim, p_in_Pa_zm(k), exner_zm(k), thv_ds_zm(k), wm_zm(k), & ! intent(in) + wp2(k), wp3_zm(k), sigma_sqd_w(k), & ! intent(in) + Skw_zm(k), rtm_zm_frz(k), rtp2(k), & ! intent(in) + wprtp(k), thlm_zm_frz(k), thlp2(k), & ! intent(in) + wpthlp(k), rtpthlp(k), sclrm_zm(k,:), & ! intent(in) + wpsclrp(k,:), sclrp2(k,:), sclrprtp(k,:), & ! intent(in) + sclrpthlp(k,:), k, & ! intent(in) +#ifdef GFDL + RH_crit(k, : , :), do_liquid_only_in_clubb, & ! intent(in) +#endif + wphydrometp(k,:), wp2hmp_zm(k,:), & ! intent(in) + rtphmp(k,:), thlphmp(k,:), & ! intent(in) + wp4_frz(k), wprtp2_zm_frz(k), wp2rtp_zm_frz(k), & ! intent(out) + wpthlp2_zm_frz(k), wp2thlp_zm_frz(k), wprtpthlp_zm_frz(k), & ! intent(out) + cloud_frac_zm_frz(k), ice_supersat_frac_zm_frz(k), & ! intent(out) + rcm_zm_frz(k), wpthvp_frz(k), wp2thvp_zm_frz(k), rtpthvp_frz(k), & ! intent(out) + thlpthvp_frz(k), wprcp_frz(k), wp2rcp_zm_frz(k), rtprcp_frz(k), & ! intent(out) + thlprcp_frz(k), rcp2_frz(k), pdf_params_zm_frz(k), & ! intent(out) + err_code_pdf_closure, & ! intent(out) + wpsclrprtp_zm_frz(k,:), wpsclrp2_zm_frz(k,:), sclrpthvp_frz(k,:), & ! intent(out) + wpsclrpthlp_zm_frz(k,:), sclrprcp_frz(k,:), wp2sclrp_zm_frz(k,:), & ! intent(out) + rc_coef_frz(k) ) ! intent(out) + + ! Subroutine may produce NaN values, and if so, exit + ! gracefully. + ! Joshua Fasching March 2008 + + + if ( fatal_error( err_code_pdf_closure ) ) then + + if ( clubb_at_least_debug_level( 1 ) ) then + write(fstderr,*) "At grid level = ",k + end if + + err_code = err_code_pdf_closure + end if + + end do ! k = 1, gr%nz, 1 + else ! l_call_pdf_closure_twice is false + + wpthvp_frz = zt2zm( wpthvp_zt_frz ) + wpthvp_frz(gr%nz) = 0.0_core_rknd + thlpthvp_frz = zt2zm( thlpthvp_zt_frz ) + thlpthvp_frz(gr%nz) = 0.0_core_rknd + rtpthvp_frz = zt2zm( rtpthvp_zt_frz ) + rtpthvp_frz(gr%nz) = 0.0_core_rknd + + end if ! l_call_pdf_closure_twice + + if ( l_trapezoidal_rule_zt ) then + call trapezoidal_rule_zt & + ( l_call_pdf_closure_twice, & ! intent(in) + wprtp2_frz, wpthlp2_frz, & ! intent(inout) + wprtpthlp_frz, cloud_frac_frz, ice_supersat_frac_frz, & ! intent(inout) + rcm_frz, wp2thvp_frz, wpsclrprtp_frz, wpsclrp2_frz, & ! intent(inout) + wpsclrpthlp_frz, pdf_params_frz, & ! intent(inout) + wprtp2_zm_frz, wpthlp2_zm_frz, & ! intent(inout) + wprtpthlp_zm_frz, cloud_frac_zm_frz, & ! intent(inout) + ice_supersat_frac_zm_frz, rcm_zm_frz, wp2thvp_zm_frz, & ! intent(inout) + wpsclrprtp_zm_frz, wpsclrp2_zm_frz, wpsclrpthlp_zm_frz, & ! intent(inout) + pdf_params_zm_frz ) ! intent(inout) + end if ! l_trapezoidal_rule_zt + + ! If l_trapezoidal_rule_zm is true, call trapezoidal_rule_zm for + ! the important momentum-level variabes output from pdf_closure. + ! ldgrant Feb. 2010 + if ( l_trapezoidal_rule_zm ) then + call trapezoidal_rule_zm & + ( wpthvp_zt_frz, thlpthvp_zt_frz, rtpthvp_zt_frz, & ! intent(in) + wpthvp_frz, thlpthvp_frz, rtpthvp_frz ) ! intent(inout) + end if ! l_trapezoidal_rule_zm + + wpthvp = wpthvp_frz + wp2thvp = wp2thvp_frz + thlpthvp = thlpthvp_frz + rtpthvp = rtpthvp_frz + + end if ! l_use_ice_latent = .true. + + + + + + !---------------------------------------------------------------- + ! Compute thvm + !---------------------------------------------------------------- + + thvm = thlm + ep1 * thv_ds_zt * rtm & + + ( Lv/(Cp*exner) - ep2 * thv_ds_zt ) * rcm + + !---------------------------------------------------------------- + ! Compute tke (turbulent kinetic energy) + !---------------------------------------------------------------- + + if ( .not. l_tke_aniso ) then + ! tke is assumed to be 3/2 of wp2 + em = three_halves * wp2 ! Known magic number + else + em = 0.5_core_rknd * ( wp2 + vp2 + up2 ) + end if + + !---------------------------------------------------------------- + ! Compute mixing length + !---------------------------------------------------------------- + + if ( l_avg_Lscale .and. .not. l_Lscale_plume_centered ) then + ! Call compute length two additional times with perturbed values + ! of rtm and thlm so that an average value of Lscale may be calculated. + if ( l_use_ice_latent ) then + !Include the effects of ice in the length scale calculation + + thlm_pert_1 = thlm_frz + Lscale_pert_coef * sqrt( max( thlp2, thl_tol**2 ) ) + rtm_pert_1 = rtm_frz + Lscale_pert_coef * sqrt( max( rtp2, rt_tol**2 ) ) + mu_pert_1 = newmu / Lscale_mu_coef + + thlm_pert_2 = thlm_frz - Lscale_pert_coef * sqrt( max( thlp2, thl_tol**2 ) ) + rtm_pert_2 = rtm_frz - Lscale_pert_coef * sqrt( max( rtp2, rt_tol**2 ) ) + mu_pert_2 = newmu * Lscale_mu_coef + else + thlm_pert_1 = thlm + Lscale_pert_coef * sqrt( max( thlp2, thl_tol**2 ) ) + rtm_pert_1 = rtm + Lscale_pert_coef * sqrt( max( rtp2, rt_tol**2 ) ) + mu_pert_1 = newmu / Lscale_mu_coef + + thlm_pert_2 = thlm - Lscale_pert_coef * sqrt( max( thlp2, thl_tol**2 ) ) + rtm_pert_2 = rtm - Lscale_pert_coef * sqrt( max( rtp2, rt_tol**2 ) ) + mu_pert_2 = newmu * Lscale_mu_coef + end if + + call compute_length( thvm, thlm_pert_1, rtm_pert_1, em, Lscale_max, & ! intent(in) + p_in_Pa, exner, thv_ds_zt, mu_pert_1, l_implemented, & ! intent(in) + err_code, & ! intent(inout) + Lscale_pert_1, Lscale_up, Lscale_down ) ! intent(out) + + call compute_length( thvm, thlm_pert_2, rtm_pert_2, em, Lscale_max, & ! intent(in) + p_in_Pa, exner, thv_ds_zt, mu_pert_2, l_implemented, & ! intent(in) + err_code, & ! intent(inout) + Lscale_pert_2, Lscale_up, Lscale_down ) ! intent(out) + + else if ( l_avg_Lscale .and. l_Lscale_plume_centered ) then + ! Take the values of thl and rt based one 1st or 2nd plume + + do k = 1, gr%nz, 1 + sign_rtpthlp(k) = sign(1.0_core_rknd, rtpthlp(k)) + end do + + if ( l_use_ice_latent ) then + where ( pdf_params_frz%rt_1 > pdf_params_frz%rt_2 ) + rtm_pert_pos_rt = pdf_params_frz%rt_1 & + + Lscale_pert_coef * sqrt( max( pdf_params_frz%varnce_rt_1, rt_tol**2 ) ) + thlm_pert_pos_rt = pdf_params_frz%thl_1 + ( sign_rtpthlp * Lscale_pert_coef & + * sqrt( max( pdf_params_frz%varnce_thl_1, thl_tol**2 ) ) ) + thlm_pert_neg_rt = pdf_params_frz%thl_2 - ( sign_rtpthlp * Lscale_pert_coef & + * sqrt( max( pdf_params_frz%varnce_thl_2, thl_tol**2 ) ) ) + rtm_pert_neg_rt = pdf_params_frz%rt_2 & + - Lscale_pert_coef * sqrt( max( pdf_params_frz%varnce_rt_2, rt_tol**2 ) ) + !Lscale_weight = pdf_params%mixt_frac + else where + rtm_pert_pos_rt = pdf_params_frz%rt_2 & + + Lscale_pert_coef * sqrt( max( pdf_params_frz%varnce_rt_2, rt_tol**2 ) ) + thlm_pert_pos_rt = pdf_params_frz%thl_2 + ( sign_rtpthlp * Lscale_pert_coef & + * sqrt( max( pdf_params_frz%varnce_thl_2, thl_tol**2 ) ) ) + thlm_pert_neg_rt = pdf_params_frz%thl_1 - ( sign_rtpthlp * Lscale_pert_coef & + * sqrt( max( pdf_params_frz%varnce_thl_1, thl_tol**2 ) ) ) + rtm_pert_neg_rt = pdf_params_frz%rt_1 & + - Lscale_pert_coef * sqrt( max( pdf_params_frz%varnce_rt_1, rt_tol**2 ) ) + !Lscale_weight = 1.0_core_rknd - pdf_params%mixt_frac + end where + else + where ( pdf_params%rt_1 > pdf_params%rt_2 ) + rtm_pert_pos_rt = pdf_params%rt_1 & + + Lscale_pert_coef * sqrt( max( pdf_params%varnce_rt_1, rt_tol**2 ) ) + thlm_pert_pos_rt = pdf_params%thl_1 + ( sign_rtpthlp * Lscale_pert_coef & + * sqrt( max( pdf_params%varnce_thl_1, thl_tol**2 ) ) ) + thlm_pert_neg_rt = pdf_params%thl_2 - ( sign_rtpthlp * Lscale_pert_coef & + * sqrt( max( pdf_params%varnce_thl_2, thl_tol**2 ) ) ) + rtm_pert_neg_rt = pdf_params%rt_2 & + - Lscale_pert_coef * sqrt( max( pdf_params%varnce_rt_2, rt_tol**2 ) ) + !Lscale_weight = pdf_params%mixt_frac + else where + rtm_pert_pos_rt = pdf_params%rt_2 & + + Lscale_pert_coef * sqrt( max( pdf_params%varnce_rt_2, rt_tol**2 ) ) + thlm_pert_pos_rt = pdf_params%thl_2 + ( sign_rtpthlp * Lscale_pert_coef & + * sqrt( max( pdf_params%varnce_thl_2, thl_tol**2 ) ) ) + thlm_pert_neg_rt = pdf_params%thl_1 - ( sign_rtpthlp * Lscale_pert_coef & + * sqrt( max( pdf_params%varnce_thl_1, thl_tol**2 ) ) ) + rtm_pert_neg_rt = pdf_params%rt_1 & + - Lscale_pert_coef * sqrt( max( pdf_params%varnce_rt_1, rt_tol**2 ) ) + !Lscale_weight = 1.0_core_rknd - pdf_params%mixt_frac + end where + end if + mu_pert_pos_rt = newmu / Lscale_mu_coef + mu_pert_neg_rt = newmu * Lscale_mu_coef + + ! Call length with perturbed values of thl and rt + call compute_length( thvm, thlm_pert_pos_rt, rtm_pert_pos_rt, em, Lscale_max, &!intent(in) + p_in_Pa, exner, thv_ds_zt, mu_pert_pos_rt, l_implemented, & !intent(in) + err_code, & ! intent(inout) + Lscale_pert_1, Lscale_up, Lscale_down ) ! intent(out) + + call compute_length( thvm, thlm_pert_neg_rt, rtm_pert_neg_rt, em, Lscale_max, &!intent(in) + p_in_Pa, exner, thv_ds_zt, mu_pert_neg_rt, l_implemented, & !intent(in) + err_code, & ! intent(inout) + Lscale_pert_2, Lscale_up, Lscale_down ) ! intent(out) + else + Lscale_pert_1 = unused_var ! Undefined + Lscale_pert_2 = unused_var ! Undefined + + end if ! l_avg_Lscale + + if ( l_stats_samp ) then + call stat_update_var( iLscale_pert_1, Lscale_pert_1, & ! intent(in) + stats_zt ) ! intent(inout) + call stat_update_var( iLscale_pert_2, Lscale_pert_2, & ! intent(in) + stats_zt ) ! intent(inout) + end if ! l_stats_samp + + ! ********** NOTE: ********** + ! This call to compute_length must be last. Otherwise, the values of + ! Lscale_up and Lscale_down in stats will be based on perturbation length scales + ! rather than the mean length scale. + call compute_length( thvm, thlm, rtm, em, Lscale_max, & ! intent(in) + p_in_Pa, exner, thv_ds_zt, newmu, l_implemented, & ! intent(in) + err_code, & ! intent(inout) + Lscale, Lscale_up, Lscale_down ) ! intent(out) + + if ( l_avg_Lscale ) then + if ( l_Lscale_plume_centered ) then + ! Weighted average of mean, pert_1, & pert_2 +! Lscale = 0.5_core_rknd * ( Lscale + Lscale_weight*Lscale_pert_1 & +! + (1.0_core_rknd-Lscale_weight)*Lscale_pert_2 ) + + ! Weighted average of just the perturbed values +! Lscale = Lscale_weight*Lscale_pert_1 + (1.0_core_rknd-Lscale_weight)*Lscale_pert_2 + + ! Un-weighted average of just the perturbed values + Lscale = 0.5_core_rknd*( Lscale_pert_1 + Lscale_pert_2 ) + else + Lscale = (1.0_core_rknd/3.0_core_rknd) * ( Lscale + Lscale_pert_1 + Lscale_pert_2 ) + end if + end if + + !---------------------------------------------------------------- + ! Dissipation time + !---------------------------------------------------------------- +! Vince Larson replaced the cutoff of em_min by w_tol**2. 7 Jul 2007 +! This is to prevent tau from being too large (producing little damping) +! in stably stratified layers with little turbulence. +! sqrt_em_zt = SQRT( MAX( em_min, zm2zt( em ) ) ) +! tau_zt = MIN( Lscale / sqrt_em_zt, taumax ) +! tau_zm & +! = MIN( ( zt2zm( Lscale ) / SQRT( MAX( em_min, em ) ) ), taumax ) +! Addition by Brian: Model constant em_min is now set to (3/2)*w_tol_sqd. +! Thus, em_min can replace w_tol_sqd here. + sqrt_em_zt = SQRT( MAX( em_min, zm2zt( em ) ) ) + + tau_zt = MIN( Lscale / sqrt_em_zt, taumax ) + tau_zm = MIN( ( MAX( zt2zm( Lscale ), zero_threshold ) & + / SQRT( MAX( em_min, em ) ) ), taumax ) +! End Vince Larson's replacement. + + ! Determine the static stability corrected version of tau_zm + ! Create a damping time scale that is more strongly damped at the + ! altitudes where the Brunt-Vaisala frequency (N^2) is large. + tau_N2_zm = tau_zm / calc_stability_correction( thlm, Lscale, em ) + + ! Modification to damp noise in stable region +! Vince Larson commented out because it may prevent turbulence from +! initiating in unstable regions. 7 Jul 2007 +! do k = 1, gr%nz +! if ( wp2(k) <= 0.005_core_rknd ) then +! tau_zt(k) = taumin +! tau_zm(k) = taumin +! end if +! end do +! End Vince Larson's commenting. + + !---------------------------------------------------------------- + ! Eddy diffusivity coefficient + !---------------------------------------------------------------- + ! c_K is 0.548 usually (Duynkerke and Driedonks 1987) + ! CLUBB uses a smaller value to better fit empirical data. + + Kh_zt = c_K * Lscale * sqrt_em_zt + Kh_zm = c_K * max( zt2zm( Lscale ), zero_threshold ) & + * sqrt( max( em, em_min ) ) + +#if defined(CLUBB_CAM) || defined(GFDL) + khzt(:) = Kh_zt(:) + khzm(:) = Kh_zm(:) + thlprcp_out(:) = thlprcp(:) +#endif + +#ifdef CLUBB_CAM + qclvar(:) = rcp2_zt(:) +#endif + + !---------------------------------------------------------------- + ! Set Surface variances + !---------------------------------------------------------------- + + ! Surface variances should be set here, before the call to either + ! advance_xp2_xpyp or advance_wp2_wp3. + ! Surface effects should not be included with any case where the lowest + ! level is not the ground level. Brian Griffin. December 22, 2005. + if ( gr%zm(1) == sfc_elevation ) then + + ! Reflect surface varnce changes in budget + if ( l_stats_samp ) then + call stat_begin_update_pt( ithlp2_sf, 1, & ! intent(in) + thlp2(1) / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_begin_update_pt( irtp2_sf, 1, & ! intent(in) + rtp2(1) / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_begin_update_pt( irtpthlp_sf, 1, & ! intent(in) + rtpthlp(1) / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_begin_update_pt( iup2_sf, 1, & ! intent(in) + up2(1) / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_begin_update_pt( ivp2_sf, 1, & ! intent(in) + vp2(1) / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_begin_update_pt( iwp2_sf, 1, & ! intent(in) + wp2(1) / dt, & ! intent(in) + stats_zm ) ! intent(inout) + end if + + call surface_varnce( upwp_sfc, vpwp_sfc, wpthlp_sfc, wprtp_sfc, & ! intent(in) + um(2), vm(2), Lscale_up(2), wpsclrp_sfc, & ! intent(in) + wp2(1), up2(1), vp2(1), & ! intent(out) + thlp2(1), rtp2(1), rtpthlp(1), err_code_surface,& ! intent(out) + sclrp2(1,1:sclr_dim), & ! intent(out) + sclrprtp(1,1:sclr_dim), & ! intent(out) + sclrpthlp(1,1:sclr_dim) ) ! intent(out) + + if ( fatal_error( err_code_surface ) ) then + call report_error( err_code_surface ) ! intent(in) + err_code = err_code_surface + end if + + ! Update surface stats + if ( l_stats_samp ) then + call stat_end_update_pt( ithlp2_sf, 1, & ! intent(in) + thlp2(1) / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_end_update_pt( irtp2_sf, 1, & ! intent(in) + rtp2(1) / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_end_update_pt( irtpthlp_sf, 1, & ! intent(in) + rtpthlp(1) / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_end_update_pt( iup2_sf, 1, & ! intent(in) + up2(1) / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_end_update_pt( ivp2_sf, 1, & ! intent(in) + vp2(1) / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_end_update_pt( iwp2_sf, 1, & ! intent(in) + wp2(1) / dt, & ! intent(in) + stats_zm ) ! intent(inout) + end if + + else + + ! Variances for cases where the lowest level is not at the surface. + ! Eliminate surface effects on lowest level variances. + wp2(1) = w_tol_sqd + up2(1) = w_tol_sqd + vp2(1) = w_tol_sqd + thlp2(1) = thl_tol**2 + rtp2(1) = rt_tol**2 + rtpthlp(1) = 0.0_core_rknd + + do i = 1, sclr_dim, 1 + sclrp2(1,i) = 0.0_core_rknd + sclrprtp(1,i) = 0.0_core_rknd + sclrpthlp(1,i) = 0.0_core_rknd + end do + + end if ! gr%zm(1) == sfc_elevation + + + !####################################################################### + !############## ADVANCE PROGNOSTIC VARIABLES ONE TIMESTEP ############## + !####################################################################### + + ! Store the saturation mixing ratio for output purposes. Brian + ! Compute rsat if either rsat or rel_humidity is to be saved. ldgrant + if ( ( irsat > 0 ) .or. ( irel_humidity > 0 ) ) then + rsat = sat_mixrat_liq( p_in_Pa, thlm2T_in_K( thlm, exner, rcm ) ) + end if + + + if ( l_stats_samp ) then + call stat_update_var( irvm, rtm - rcm, & !intent(in) + stats_zt ) !intent(inout) + + ! Output relative humidity (q/q∗ where q∗ is the saturation mixing ratio over liquid) + ! Added an extra check for irel_humidity > 0; otherwise, if both irsat = 0 and + ! irel_humidity = 0, rsat is not computed, leading to a floating-point exception + ! when stat_update_var is called for rel_humidity. ldgrant + if ( irel_humidity > 0 ) then + call stat_update_var( irel_humidity, (rtm - rcm) / rsat, & !intent(in) + stats_zt) !intent(inout) + end if ! irel_humidity > 0 + end if ! l_stats_samp + + !---------------------------------------------------------------- + ! Advance rtm/wprtp and thlm/wpthlp one time step + !---------------------------------------------------------------- + if ( l_call_pdf_closure_twice ) then + w_1_zm = pdf_params_zm%w_1 + w_2_zm = pdf_params_zm%w_2 + varnce_w_1_zm = pdf_params_zm%varnce_w_1 + varnce_w_2_zm = pdf_params_zm%varnce_w_2 + mixt_frac_zm = pdf_params_zm%mixt_frac + else + w_1_zm = zt2zm( pdf_params%w_1 ) + w_2_zm = zt2zm( pdf_params%w_2 ) + varnce_w_1_zm = zt2zm( pdf_params%varnce_w_1 ) + varnce_w_2_zm = zt2zm( pdf_params%varnce_w_2 ) + mixt_frac_zm = zt2zm( pdf_params%mixt_frac ) + end if + + ! Determine stability correction factor + stability_correction = calc_stability_correction( thlm, Lscale, em ) ! In + if ( l_stats_samp ) then + call stat_update_var( istability_correction, stability_correction, & ! In + stats_zm ) ! In/Out + end if + + ! Here we determine if we're using tau_zm or tau_N2_zm, which is tau + ! that has been stability corrected for stably stratified regions. + ! -dschanen 7 Nov 2014 + if ( l_stability_correct_tau_zm ) then + tau_N2_zm = tau_zm / stability_correction + tau_C6_zm = tau_N2_zm + tau_C1_zm = tau_N2_zm + + else + tau_N2_zm = unused_var + tau_C6_zm = tau_zm + tau_C1_zm = tau_zm + + end if ! l_stability_correction + + call advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & ! intent(in) + Lscale, wp3_on_wp2, wp3_on_wp2_zt, Kh_zt, Kh_zm, & ! intent(in) + tau_C6_zm, Skw_zm, rtpthvp, rtm_forcing, & ! intent(in) + wprtp_forcing, rtm_ref, thlpthvp, & ! intent(in) + thlm_forcing, wpthlp_forcing, thlm_ref, & ! intent(in) + rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & ! intent(in) + invrs_rho_ds_zt, thv_ds_zm, rtp2, thlp2, & ! intent(in) + w_1_zm, w_2_zm, varnce_w_1_zm, varnce_w_2_zm, & ! intent(in) + mixt_frac_zm, l_implemented, em, & ! intent(in) + sclrpthvp, sclrm_forcing, sclrp2, & ! intent(in) + rtm, wprtp, thlm, wpthlp, & ! intent(inout) + err_code, & ! intent(inout) + sclrm, wpsclrp ) ! intent(inout) + + ! Vince Larson clipped rcm in order to prevent rvm < 0. 5 Apr 2008. + ! This code won't work unless rtm >= 0 !!! + ! We do not clip rcm_in_layer because rcm_in_layer only influences + ! radiation, and we do not want to bother recomputing it. 6 Aug 2009 + call clip_rcm( rtm, 'rtm < rcm in advance_xm_wpxp', & ! intent(in) + rcm ) ! intent(inout) + +#ifdef GFDL + call advance_sclrm_Nd_diffusion_OG( dt, & ! h1g, 2012-06-16 ! intent(in) + sclrm, sclrm_trsport_only, & ! intent(inout) + Kh_zm, cloud_frac, & ! intent(in) + err_code ) ! intent(out) +#endif + + !---------------------------------------------------------------- + ! Compute some of the variances and covariances. These include the variance of + ! total water (rtp2), liquid potential termperature (thlp2), their + ! covariance (rtpthlp), and the variance of horizontal wind (up2 and vp2). + ! The variance of vertical velocity is computed later. + !---------------------------------------------------------------- + + ! We found that certain cases require a time tendency to run + ! at shorter timesteps so these are prognosed now. + + ! We found that if we call advance_xp2_xpyp first, we can use a longer timestep. + call advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, thlm, & ! intent(in) + wpthlp, wpthvp, um, vm, wp2, wp2_zt, & ! intent(in) + wp3, upwp, vpwp, sigma_sqd_w, Skw_zm, & ! intent(in) + Kh_zt, rtp2_forcing, thlp2_forcing, & ! intent(in) + rtpthlp_forcing, rho_ds_zm, rho_ds_zt, & ! intent(in) + invrs_rho_ds_zm, thv_ds_zm, & ! intent(in) + Lscale, wp3_on_wp2, wp3_on_wp2_zt, & ! intent(in) + l_iter_xp2_xpyp, dt, & ! intent(in) + sclrm, wpsclrp, & ! intent(in) + rtp2, thlp2, rtpthlp, up2, vp2, & ! intent(inout) + err_code, & ! intent(inout) + sclrp2, sclrprtp, sclrpthlp ) ! intent(inout) + + !---------------------------------------------------------------- + ! Covariance clipping for wprtp, wpthlp, wpsclrp, upwp, and vpwp + ! after subroutine advance_xp2_xpyp updated xp2. + !---------------------------------------------------------------- + + wprtp_cl_num = 2 ! Second instance of w'r_t' clipping. + wpthlp_cl_num = 2 ! Second instance of w'th_l' clipping. + wpsclrp_cl_num = 2 ! Second instance of w'sclr' clipping. + upwp_cl_num = 1 ! First instance of u'w' clipping. + vpwp_cl_num = 1 ! First instance of v'w' clipping. + + call clip_covars_denom( dt, rtp2, thlp2, up2, vp2, wp2, & ! intent(in) + sclrp2, wprtp_cl_num, wpthlp_cl_num, & ! intent(in) + wpsclrp_cl_num, upwp_cl_num, vpwp_cl_num, & ! intent(in) + wprtp, wpthlp, upwp, vpwp, wpsclrp ) ! intent(inout) + + + !---------------------------------------------------------------- + ! Advance 2nd and 3rd order moment of vertical velocity (wp2 / wp3) + ! by one timestep + !---------------------------------------------------------------- + + call advance_wp2_wp3 & + ( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & ! intent(in) + a3_coef, a3_coef_zt, wp3_on_wp2, & ! intent(in) + wpthvp, wp2thvp, um, vm, upwp, vpwp, & ! intent(in) + up2, vp2, Kh_zm, Kh_zt, tau_zm, tau_zt, tau_C1_zm, & ! intent(in) + Skw_zm, Skw_zt, rho_ds_zm, rho_ds_zt, & ! intent(in) + invrs_rho_ds_zm, invrs_rho_ds_zt, radf, & ! intent(in) + thv_ds_zm, thv_ds_zt, pdf_params%mixt_frac, & ! intent(in) + wp2, wp3, wp3_zm, wp2_zt, err_code ) ! intent(inout) + + !---------------------------------------------------------------- + ! Covariance clipping for wprtp, wpthlp, wpsclrp, upwp, and vpwp + ! after subroutine advance_wp2_wp3 updated wp2. + !---------------------------------------------------------------- + + wprtp_cl_num = 3 ! Third instance of w'r_t' clipping. + wpthlp_cl_num = 3 ! Third instance of w'th_l' clipping. + wpsclrp_cl_num = 3 ! Third instance of w'sclr' clipping. + upwp_cl_num = 2 ! Second instance of u'w' clipping. + vpwp_cl_num = 2 ! Second instance of v'w' clipping. + + call clip_covars_denom( dt, rtp2, thlp2, up2, vp2, wp2, & ! intent(in) + sclrp2, wprtp_cl_num, wpthlp_cl_num, & ! intent(in) + wpsclrp_cl_num, upwp_cl_num, vpwp_cl_num, & ! intent(in) + wprtp, wpthlp, upwp, vpwp, wpsclrp ) ! intent(inout) + + !---------------------------------------------------------------- + ! Advance the horizontal mean of the wind in the x-y directions + ! (i.e. um, vm) and the mean of the eddy-diffusivity scalars + ! (i.e. edsclrm) by one time step + !----------------------------------------------------------------i + + Km_zm = Kh_zm * c_K10 + + if (do_expldiff) then + edsclrm(:,edsclr_dim-1)=thlm(:) + edsclrm(:,edsclr_dim)=rtm(:) + endif + + call advance_windm_edsclrm( dt, wm_zt, Km_zm, ug, vg, um_ref, vm_ref, & ! intent(in) + wp2, up2, vp2, um_forcing, vm_forcing, & ! intent(in) + edsclrm_forcing, & ! intent(in) + rho_ds_zm, invrs_rho_ds_zt, & ! intent(in) + fcor, l_implemented, & ! intent(in) + um, vm, edsclrm, & ! intent(inout) + upwp, vpwp, wpedsclrp, & ! intent(inout) + err_code ) ! intent(inout) + + call pvertinterp(gr%nz, p_in_Pa, 70000.0_core_rknd, thlm, thlm700) + call pvertinterp(gr%nz, p_in_Pa, 100000.0_core_rknd, thlm, thlm1000) + if (do_expldiff .and. thlm700 - thlm1000 .lt. 20.0_core_rknd) then + thlm(:) = edsclrm(:,edsclr_dim-1) + rtm(:) = edsclrm(:,edsclr_dim) + endif + + do ixind=1,edsclr_dim + call fill_holes_vertical(2,0.0_core_rknd,"zt",rho_ds_zt,rho_ds_zm,edsclrm(:,ixind)) + enddo + + !####################################################################### + !############# ACCUMULATE STATISTICS ############# + !####################################################################### + + if ( l_stats_samp ) then + + call stat_end_update( iwp2_bt, wp2 / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_end_update( ivp2_bt, vp2 / dt,& ! intent(in) + stats_zm ) ! intent(inout) + call stat_end_update( iup2_bt, up2 / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_end_update( iwprtp_bt, wprtp / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_end_update( iwpthlp_bt, wpthlp / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_end_update( irtp2_bt, rtp2 / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_end_update( ithlp2_bt, thlp2 / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_end_update( irtpthlp_bt, rtpthlp / dt, & ! intent(in) + stats_zm ) ! intent(inout) + + call stat_end_update( irtm_bt, rtm / dt, & ! intent(in) + stats_zt ) ! intent(inout) + call stat_end_update( ithlm_bt, thlm / dt, & ! intent(in) + stats_zt ) ! intent(inout) + call stat_end_update( ium_bt, um / dt, & ! intent(in) + stats_zt ) ! intent(inout) + call stat_end_update( ivm_bt, vm / dt, & ! intent(in) + stats_zt ) ! intent(inout) + call stat_end_update( iwp3_bt, wp3 / dt, & ! intent(in) + stats_zt ) ! intent(inout) + + end if ! l_stats_samp + + + if ( iwpthlp_zt > 0 ) then + wpthlp_zt = zm2zt( wpthlp ) + end if + + if ( iwprtp_zt > 0 ) then + wprtp_zt = zm2zt( wprtp ) + end if + + if ( iup2_zt > 0 ) then + up2_zt = max( zm2zt( up2 ), w_tol_sqd ) + end if + + if (ivp2_zt > 0 ) then + vp2_zt = max( zm2zt( vp2 ), w_tol_sqd ) + end if + + if ( iupwp_zt > 0 ) then + upwp_zt = zm2zt( upwp ) + end if + + if ( ivpwp_zt > 0 ) then + vpwp_zt = zm2zt( vpwp ) + end if + + call stats_accumulate & + ( um, vm, upwp, vpwp, up2, vp2, & ! intent(in) + thlm, rtm, wprtp, wpthlp, & ! intent(in) + wp2, wp3, rtp2, thlp2, rtpthlp, & ! intent(in) + p_in_Pa, exner, rho, rho_zm, & ! intent(in) + rho_ds_zm, rho_ds_zt, thv_ds_zm, & ! intent(in) + thv_ds_zt, wm_zt, wm_zm, rcm, wprcp, rc_coef, & ! intent(in) + rcm_zm, rtm_zm, thlm_zm, cloud_frac, ice_supersat_frac,& ! intent(in) + cloud_frac_zm, ice_supersat_frac_zm, rcm_in_layer, & ! intent(in) + cloud_cover, sigma_sqd_w, pdf_params, & ! intent(in) + sclrm, sclrp2, sclrprtp, sclrpthlp, sclrm_forcing, & ! intent(in) + wpsclrp, edsclrm, edsclrm_forcing ) ! intent(in) + + + if ( clubb_at_least_debug_level( 2 ) ) then + call parameterization_check & + ( thlm_forcing, rtm_forcing, um_forcing, vm_forcing, & ! intent(in) + wm_zm, wm_zt, p_in_Pa, rho_zm, rho, exner, & ! intent(in) + rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & ! intent(in) + invrs_rho_ds_zt, thv_ds_zm, thv_ds_zt, & ! intent(in) + wpthlp_sfc, wprtp_sfc, upwp_sfc, vpwp_sfc, & ! intent(in) + um, upwp, vm, vpwp, up2, vp2, & ! intent(in) + rtm, wprtp, thlm, wpthlp, & ! intent(in) + wp2, wp3, rtp2, thlp2, rtpthlp, & ! intent(in) + "end of ", & ! intent(in) + wpsclrp_sfc, wpedsclrp_sfc, & ! intent(in) + sclrm, wpsclrp, sclrp2, sclrprtp, sclrpthlp, & ! intent(in) + sclrm_forcing, edsclrm, edsclrm_forcing, & ! intent(in) + err_code ) ! intent(inout) + end if + + if ( l_stats .and. l_stats_samp ) then + ! Spurious source will only be calculated if rtm_ma and thlm_ma are zero. + ! Therefore, wm must be zero or l_implemented must be true. + if ( l_implemented .or. ( all( wm_zt == 0._core_rknd ) .and. & + all( wm_zm == 0._core_rknd ) ) ) then + ! Calculate the spurious source for rtm + rtm_flux_top = rho_ds_zm(gr%nz) * wprtp(gr%nz) + + if ( .not. l_host_applies_sfc_fluxes ) then + rtm_flux_sfc = rho_ds_zm(1) * wprtp_sfc + else + rtm_flux_sfc = 0.0_core_rknd + end if + + rtm_integral_after & + = vertical_integral( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & + rtm(2:gr%nz), gr%invrs_dzt(2:gr%nz) ) + + rtm_integral_forcing & + = vertical_integral( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & + rtm_forcing(2:gr%nz), gr%invrs_dzt(2:gr%nz) ) + + rtm_spur_src & + = calculate_spurious_source( rtm_integral_after, & + rtm_integral_before, & + rtm_flux_top, rtm_flux_sfc, & + rtm_integral_forcing, & + dt ) + + ! Calculate the spurious source for thlm + thlm_flux_top = rho_ds_zm(gr%nz) * wpthlp(gr%nz) + + if ( .not. l_host_applies_sfc_fluxes ) then + thlm_flux_sfc = rho_ds_zm(1) * wpthlp_sfc + else + thlm_flux_sfc = 0.0_core_rknd + end if + + thlm_integral_after & + = vertical_integral( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & + thlm(2:gr%nz), gr%invrs_dzt(2:gr%nz) ) + + thlm_integral_forcing & + = vertical_integral( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & + thlm_forcing(2:gr%nz), gr%invrs_dzt(2:gr%nz) ) + + thlm_spur_src & + = calculate_spurious_source( thlm_integral_after, & + thlm_integral_before, & + thlm_flux_top, thlm_flux_sfc, & + thlm_integral_forcing, & + dt ) + else ! If l_implemented is false, we don't want spurious source output + rtm_spur_src = -9999.0_core_rknd + thlm_spur_src = -9999.0_core_rknd + end if + + ! Write the var to stats + call stat_update_var_pt( irtm_spur_src, 1, rtm_spur_src, & ! intent(in) + stats_sfc ) ! intent(inout) + call stat_update_var_pt( ithlm_spur_src, 1, thlm_spur_src, & ! intent(in) + stats_sfc ) ! intent(inout) + end if + + return + end subroutine advance_clubb_core + + !----------------------------------------------------------------------- + subroutine setup_clubb_core & + ( nzmax, T0_in, ts_nudge_in, & ! intent(in) + hydromet_dim_in, sclr_dim_in, & ! intent(in) + sclr_tol_in, edsclr_dim_in, params, & ! intent(in) + l_host_applies_sfc_fluxes, & ! intent(in) + l_uv_nudge, saturation_formula, & ! intent(in) +#ifdef GFDL + I_sat_sphum, & ! intent(in) h1g, 2010-06-16 +#endif + l_implemented, grid_type, deltaz, zm_init, zm_top, & ! intent(in) + momentum_heights, thermodynamic_heights, & ! intent(in) + sfc_elevation, & ! intent(in) +#ifdef GFDL + cloud_frac_min , & ! intent(in) h1g, 2010-06-16 +#endif + err_code ) ! intent(out) + ! + ! Description: + ! Subroutine to set up the model for execution. + ! + ! References: + ! None + !------------------------------------------------------------------------- + use grid_class, only: & + setup_grid, & ! Procedure + gr ! Variable(s) + + use parameter_indices, only: & + nparams ! Variable(s) + + use parameters_tunable, only: & + setup_parameters ! Procedure + + use parameters_model, only: & + setup_parameters_model ! Procedure + + use variables_diagnostic_module, only: & + setup_diagnostic_variables ! Procedure + + use variables_prognostic_module, only: & + setup_prognostic_variables ! Procedure + + use constants_clubb, only: & + fstderr ! Variable(s) + + use error_code, only: & + clubb_no_error ! Constant(s) + + use model_flags, only: & + setup_model_flags ! Subroutine + +#ifdef MKL + use csr_matrix_module, only: & + initialize_csr_matrix, & ! Subroutine + intlc_5d_5d_ja_size ! Variable + + use gmres_wrap, only: & + gmres_init ! Subroutine + + use gmres_cache, only: & + gmres_cache_temp_init, &! Subroutine + gmres_idx_wp2wp3 ! Variable +#endif /* MKL */ + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + + ! Grid definition + integer, intent(in) :: nzmax ! Vertical grid levels [#] + ! Only true when used in a host model + ! CLUBB determines what nzmax should be + ! given zm_init and zm_top when + ! running in standalone mode. + + real( kind = core_rknd ), intent(in) :: & + sfc_elevation ! Elevation of ground level [m AMSL] + + ! Flag to see if CLUBB is running on it's own, + ! or if it's implemented as part of a host model. + logical, intent(in) :: l_implemented ! (T/F) + + ! If CLUBB is running on it's own, this option determines + ! if it is using: + ! 1) an evenly-spaced grid, + ! 2) a stretched (unevenly-spaced) grid entered on the + ! thermodynamic grid levels (with momentum levels set + ! halfway between thermodynamic levels), or + ! 3) a stretched (unevenly-spaced) grid entered on the + ! momentum grid levels (with thermodynamic levels set + ! halfway between momentum levels). + integer, intent(in) :: grid_type + + ! If the CLUBB model is running by itself, and is using an + ! evenly-spaced grid (grid_type = 1), it needs the vertical + ! grid spacing, momentum-level starting altitude, and maximum + ! altitude as input. + real( kind = core_rknd ), intent(in) :: & + deltaz, & ! Change in altitude per level [m] + zm_init, & ! Initial grid altitude (momentum level) [m] + zm_top ! Maximum grid altitude (momentum level) [m] + + ! If the CLUBB parameterization is implemented in a host model, + ! it needs to use the host model's momentum level altitudes + ! and thermodynamic level altitudes. + ! If the CLUBB model is running by itself, but is using a + ! stretched grid entered on thermodynamic levels (grid_type = 2), + ! it needs to use the thermodynamic level altitudes as input. + ! If the CLUBB model is running by itself, but is using a + ! stretched grid entered on momentum levels (grid_type = 3), + ! it needs to use the momentum level altitudes as input. + real( kind = core_rknd ), intent(in), dimension(nzmax) :: & + momentum_heights, & ! Momentum level altitudes (input) [m] + thermodynamic_heights ! Thermodynamic level altitudes (input) [m] + + ! Model parameters + real( kind = core_rknd ), intent(in) :: & + T0_in, ts_nudge_in + + integer, intent(in) :: & + hydromet_dim_in, & ! Number of hydrometeor species + sclr_dim_in, & ! Number of passive scalars + edsclr_dim_in ! Number of eddy-diff. passive scalars + + real( kind = core_rknd ), intent(in), dimension(sclr_dim_in) :: & + sclr_tol_in ! Thresholds for passive scalars + + real( kind = core_rknd ), intent(in), dimension(nparams) :: & + params ! Including C1, nu1, nu2, etc. + + ! Flags + logical, intent(in) :: & + l_uv_nudge, & ! Wind nudging + l_host_applies_sfc_fluxes ! Whether to apply for the surface flux + + character(len=*), intent(in) :: & + saturation_formula ! Approximation for saturation vapor pressure + +#ifdef GFDL + logical, intent(in) :: & ! h1g, 2010-06-16 begin mod + I_sat_sphum + + real( kind = core_rknd ), intent(in) :: & + cloud_frac_min ! h1g, 2010-06-16 end mod +#endif + + ! Output variables + integer, intent(out) :: & + err_code ! Diagnostic for a problem with the setup + + ! Local variables + integer :: begin_height, end_height + + !----- Begin Code ----- + + ! Sanity check for the saturation formula + select case ( trim( saturation_formula ) ) + case ( "bolton", "Bolton" ) + ! Using the Bolton 1980 approximations for SVP over vapor/ice + + case ( "flatau", "Flatau" ) + ! Using the Flatau, et al. polynomial approximation for SVP over vapor/ice + + case ( "gfdl", "GFDL" ) ! h1g, 2010-06-16 + ! Using the GFDL SVP formula (Goff-Gratch) + + ! Add new saturation formulas after this + + case default + write(fstderr,*) "Error in setup_clubb_core." + write(fstderr,*) "Unknown approx. of saturation vapor pressure: "// & + trim( saturation_formula ) + stop + end select + + ! Setup grid + call setup_grid( nzmax, sfc_elevation, l_implemented, & ! intent(in) + grid_type, deltaz, zm_init, zm_top, & ! intent(in) + momentum_heights, thermodynamic_heights, & ! intent(in) + begin_height, end_height ) ! intent(out) + + ! Setup flags +#ifdef GFDL + call setup_model_flags & + ( l_host_applies_sfc_fluxes, & ! intent(in) + l_uv_nudge, saturation_formula, & ! intent(in) + I_sat_sphum ) ! intent(in) h1g, 2010-06-16 + +#else + call setup_model_flags & + ( l_host_applies_sfc_fluxes, & ! intent(in) + l_uv_nudge, saturation_formula ) ! intent(in) +#endif + + + ! Define model constant parameters +#ifdef GFDL + call setup_parameters_model( T0_in, ts_nudge_in, & ! intent(in) + hydromet_dim_in, & ! intent(in) + sclr_dim_in, sclr_tol_in, edsclr_dim_in, & ! intent(in) + cloud_frac_min ) ! intent(in) h1g, 2010-06-16 +#else + call setup_parameters_model( T0_in, ts_nudge_in, & ! intent(in) + hydromet_dim_in, & ! intent(in) + sclr_dim_in, sclr_tol_in, edsclr_dim_in ) ! intent(in) +#endif + + ! Define tunable constant parameters + call setup_parameters & + ( deltaz, params, gr%nz, & ! intent(in) + grid_type, momentum_heights(begin_height:end_height), & ! intent(in) + thermodynamic_heights(begin_height:end_height), & ! intent(in) + err_code ) ! intent(out) + + ! Error Report + ! Joshua Fasching February 2008 + if ( err_code /= clubb_no_error ) then + + write(fstderr,*) "Error in setup_clubb_core" + + write(fstderr,*) "Intent(in)" + + write(fstderr,*) "deltaz = ", deltaz + write(fstderr,*) "zm_init = ", zm_init + write(fstderr,*) "zm_top = ", zm_top + write(fstderr,*) "momentum_heights = ", momentum_heights + write(fstderr,*) "thermodynamic_heights = ", & + thermodynamic_heights + write(fstderr,*) "T0_in = ", T0_in + write(fstderr,*) "ts_nudge_in = ", ts_nudge_in + write(fstderr,*) "params = ", params + + return + + end if + +#ifdef GFDL +! setup prognostic_variables + call setup_prognostic_variables( gr%nz ) ! intent(in) h1g, 2010-06-16 +#else + if ( .not. l_implemented ) then + call setup_prognostic_variables( gr%nz ) ! intent(in) + end if +#endif + + ! The diagnostic variables need to be + ! declared, allocated, initialized, and deallocated whether CLUBB + ! is part of a larger model or not. + call setup_diagnostic_variables( gr%nz ) ! intent(in) + +#ifdef MKL + ! Initialize the CSR matrix class. + if ( l_gmres ) then + call initialize_csr_matrix + end if + + if ( l_gmres ) then + call gmres_cache_temp_init( gr%nz ) ! intent(in) + call gmres_init( (2 * gr%nz), intlc_5d_5d_ja_size ) ! intent(in) + end if +#endif /* MKL */ + + return + end subroutine setup_clubb_core + + !---------------------------------------------------------------------------- + subroutine cleanup_clubb_core( l_implemented ) + ! + ! Description: + ! Frees memory used by the model itself. + ! + ! References: + ! None + !--------------------------------------------------------------------------- + use parameters_model, only: sclr_tol ! Variable + + use variables_diagnostic_module, only: & + cleanup_diagnostic_variables ! Procedure + + use variables_prognostic_module, only: & + cleanup_prognostic_variables ! Procedure + + use grid_class, only: & + cleanup_grid ! Procedure + + use parameters_tunable, only: & + cleanup_nu ! Procedure + + implicit none + + ! Flag to see if CLUBB is running on it's own, + ! or if it's implemented as part of a host model. + logical, intent(in) :: l_implemented ! (T/F) + + !----- Begin Code ----- +#ifdef GFDL + ! cleanup prognostic_variables + call cleanup_prognostic_variables( ) ! h1g, 2010-06-16 +#else + if ( .not. l_implemented ) then + call cleanup_prognostic_variables( ) + end if +#endif + + ! The diagnostic variables need to be + ! declared, allocated, initialized, and deallocated whether CLUBB + ! is part of a larger model or not. + call cleanup_diagnostic_variables( ) + + ! De-allocate the array for the passive scalar tolerances + deallocate( sclr_tol ) + + ! De-allocate the arrays for the grid + call cleanup_grid( ) + + ! De-allocate the arrays for nu + call cleanup_nu( ) + + return + end subroutine cleanup_clubb_core + + !----------------------------------------------------------------------- + subroutine trapezoidal_rule_zt & + ( l_call_pdf_closure_twice, & ! intent(in) + wprtp2, wpthlp2, & ! intent(inout) + wprtpthlp, cloud_frac, ice_supersat_frac, & ! intent(inout) + rcm, wp2thvp, wpsclrprtp, wpsclrp2, & ! intent(inout) + wpsclrpthlp, pdf_params, & ! intent(inout) + wprtp2_zm, wpthlp2_zm, & ! intent(inout) + wprtpthlp_zm, cloud_frac_zm, & ! intent(inout) + ice_supersat_frac_zm, rcm_zm, wp2thvp_zm, & ! intent(inout) + wpsclrprtp_zm, wpsclrp2_zm, wpsclrpthlp_zm, & ! intent(inout) + pdf_params_zm ) ! intent(inout) + ! + ! Description: + ! This subroutine takes the output variables on the thermo. + ! grid and either: interpolates them to the momentum grid, or uses the + ! values output from the second call to pdf_closure on momentum levels if + ! l_call_pdf_closure_twice is true. It then calls the function + ! trapezoid_zt to recompute the variables on the thermo. grid. + ! + ! ldgrant June 2009 + ! + ! Note: + ! The argument variables in the last 5 lines of the subroutine + ! (wprtp2_zm through pdf_params_zm) are declared intent(inout) because + ! if l_call_pdf_closure_twice is true, these variables will already have + ! values from pdf_closure on momentum levels and will not be altered in + ! this subroutine. However, if l_call_pdf_closure_twice is false, these + ! variables will not have values yet and will be interpolated to + ! momentum levels in this subroutine. + ! References: + ! None + !----------------------------------------------------------------------- + + use constants_clubb, only: & + fstderr ! Constant(s) + + use stats_variables, only: & + iwprtp2, & ! Varibles + iwprtpthlp, & + iwpthlp2, & + iwprtp2, & + iwpsclrp2, & + iwpsclrprtp, & + iwpsclrpthlp, & + l_stats + + use grid_class, only: & + gr, & ! Variable + zt2zm ! Procedure + + use parameters_model, only: & + sclr_dim ! Number of passive scalar variables + + use pdf_parameter_module, only: & + pdf_parameter ! Derived data type + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Constant parameters + logical, parameter :: & + l_apply_rule_to_pdf_params = .false. ! Apply the trapezoidal rule to pdf_params + + ! Input variables + logical, intent(in) :: l_call_pdf_closure_twice + + ! Input/Output variables + ! Thermodynamic level variables output from the first call to pdf_closure + real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & + wprtp2, & ! w'rt'^2 [m kg^2/kg^2] + wpthlp2, & ! w'thl'^2 [m K^2/s] + wprtpthlp, & ! w'rt'thl' [m kg K/kg s] + cloud_frac, & ! Cloud Fraction [-] + ice_supersat_frac, & ! Ice Cloud Fraction [-] + rcm, & ! Liquid water mixing ratio [kg/kg] + wp2thvp ! w'^2 th_v' [m^2 K/s^2] + + real( kind = core_rknd ), dimension(gr%nz,sclr_dim), intent(inout) :: & + wpsclrprtp, & ! w'sclr'rt' + wpsclrp2, & ! w'sclr'^2 + wpsclrpthlp ! w'sclr'thl' + + type (pdf_parameter), dimension(gr%nz), intent(inout) :: & + pdf_params ! PDF parameters [units vary] + + ! Thermo. level variables brought to momentum levels either by + ! interpolation (in subroutine trapezoidal_rule_zt) or by + ! the second call to pdf_closure (in subroutine advance_clubb_core) + real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & + wprtp2_zm, & ! w'rt'^2 on momentum grid [m kg^2/kg^2] + wpthlp2_zm, & ! w'thl'^2 on momentum grid [m K^2/s] + wprtpthlp_zm, & ! w'rt'thl' on momentum grid [m kg K/kg s] + cloud_frac_zm, & ! Cloud Fraction on momentum grid [-] + ice_supersat_frac_zm, & ! Ice Cloud Fraction on momentum grid [-] + rcm_zm, & ! Liquid water mixing ratio on momentum grid [kg/kg] + wp2thvp_zm ! w'^2 th_v' on momentum grid [m^2 K/s^2] + + real( kind = core_rknd ), dimension(gr%nz,sclr_dim), intent(inout) :: & + wpsclrprtp_zm, & ! w'sclr'rt' on momentum grid + wpsclrp2_zm, & ! w'sclr'^2 on momentum grid + wpsclrpthlp_zm ! w'sclr'thl' on momentum grid + + type (pdf_parameter), dimension(gr%nz), intent(inout) :: & + pdf_params_zm ! PDF parameters on momentum grid [units vary] + + ! Local variables + + ! Components of PDF_parameters on the momentum grid (_zm) and on the thermo. grid (_zt) + real( kind = core_rknd ), dimension(gr%nz) :: & + w_1_zt, & ! Mean of w for 1st normal distribution [m/s] + w_1_zm, & ! Mean of w for 1st normal distribution [m/s] + w_2_zm, & ! Mean of w for 2nd normal distribution [m/s] + w_2_zt, & ! Mean of w for 2nd normal distribution [m/s] + varnce_w_1_zm, & ! Variance of w for 1st normal distribution [m^2/s^2] + varnce_w_1_zt, & ! Variance of w for 1st normal distribution [m^2/s^2] + varnce_w_2_zm, & ! Variance of w for 2nd normal distribution [m^2/s^2] + varnce_w_2_zt, & ! Variance of w for 2nd normal distribution [m^2/s^2] + rt_1_zm, & ! Mean of r_t for 1st normal distribution [kg/kg] + rt_1_zt, & ! Mean of r_t for 1st normal distribution [kg/kg] + rt_2_zm, & ! Mean of r_t for 2nd normal distribution [kg/kg] + rt_2_zt, & ! Mean of r_t for 2nd normal distribution [kg/kg] + varnce_rt_1_zm, & ! Variance of r_t for 1st normal distribution [kg^2/kg^2] + varnce_rt_1_zt, & ! Variance of r_t for 1st normal distribution [kg^2/kg^2] + varnce_rt_2_zm, & ! Variance of r_t for 2nd normal distribution [kg^2/kg^2] + varnce_rt_2_zt, & ! Variance of r_t for 2nd normal distribution [kg^2/kg^2] + crt_1_zm, & ! Coefficient for s' [-] + crt_1_zt, & ! Coefficient for s' [-] + crt_2_zm ! Coefficient for s' [-] + + real( kind = core_rknd ), dimension(gr%nz) :: & + crt_2_zt, & ! Coefficient for s' [-] + cthl_1_zm, & ! Coefficient for s' [1/K] + cthl_1_zt, & ! Coefficient for s' [1/K] + cthl_2_zm, & ! Coefficient for s' [1/K] + cthl_2_zt, & ! Coefficient for s' [1/K] + thl_1_zm, & ! Mean of th_l for 1st normal distribution [K] + thl_1_zt, & ! Mean of th_l for 1st normal distribution [K] + thl_2_zm, & ! Mean of th_l for 2nd normal distribution [K] + thl_2_zt, & ! Mean of th_l for 2nd normal distribution + varnce_thl_1_zm, & ! Variance of th_l for 1st normal distribution [K^2] + varnce_thl_1_zt, & ! Variance of th_l for 1st normal distribution [K^2] + varnce_thl_2_zm, & ! Variance of th_l for 2nd normal distribution [K^2] + varnce_thl_2_zt ! Variance of th_l for 2nd normal distribution [K^2] + + real( kind = core_rknd ), dimension(gr%nz) :: & + mixt_frac_zm, & ! Weight of 1st normal distribution (Sk_w dependent) [-] + mixt_frac_zt, & ! Weight of 1st normal distribution (Sk_w dependent) [-] + rc_1_zm, & ! Mean of r_c for 1st normal distribution [kg/kg] + rc_1_zt, & ! Mean of r_c for 1st normal distribution [kg/kg] + rc_2_zm, & ! Mean of r_c for 2nd normal distribution [kg/kg] + rc_2_zt, & ! Mean of r_c for 2nd normal distribution [kg/kg] + rsatl_1_zm, & ! Mean of r_sl for 1st normal distribution [kg/kg] + rsatl_1_zt, & ! Mean of r_sl for 1st normal distribution [kg/kg] + rsatl_2_zm, & ! Mean of r_sl for 2nd normal distribution [kg/kg] + rsatl_2_zt, & ! Mean of r_sl for 2nd normal distribution [kg/kg] + cloud_frac_1_zm, & ! Cloud fraction for 1st normal distribution [-] + cloud_frac_1_zt, & ! Cloud fraction for 1st normal distribution [-] + cloud_frac_2_zm, & ! Cloud fraction for 2nd normal distribution [-] + cloud_frac_2_zt, & ! Cloud fraction for 2nd normal distribution [-] + chi_1_zm, & ! Mean of chi(s) for 1st normal distribution [kg/kg] + chi_1_zt, & ! Mean of chi(s) for 1st normal distribution [kg/kg] + chi_2_zm, & ! Mean of chi(s) for 2nd normal distribution [kg/kg] + chi_2_zt, & ! Mean of chi(s) for 2nd normal distribution [kg/kg] + stdev_chi_1_zm ! Standard deviation of chi(s) for 1st normal distribution [kg/kg] + + real( kind = core_rknd ), dimension(gr%nz) :: & + stdev_chi_1_zt, & ! Standard deviation of chi(s) for 1st normal distribution [kg/kg] + stdev_chi_2_zm, & ! Standard deviation of chi(s) for 2nd normal distribution [kg/kg] + stdev_chi_2_zt, & ! Standard deviation of chi(s) for 2nd normal distribution [kg/kg] + stdev_eta_1_zm, & ! Standard deviation of eta(t) for 1st normal distribution [kg/kg] + stdev_eta_1_zt, & ! Standard deviation of eta(t) for 1st normal distribution [kg/kg] + stdev_eta_2_zm, & ! Standard deviation of eta(t) for 2nd normal distribution [kg/kg] + stdev_eta_2_zt, & ! Standard deviation of eta(t) for 2nd normal distribution [kg/kg] + rrtthl_zm, & ! Within-a-normal correlation of r_t and th_l [-] + rrtthl_zt, & ! Within-a-normal correlation of r_t and th_l [-] + alpha_thl_zm, & ! Factor relating to normalized variance for th_l [-] + alpha_thl_zt, & ! Factor relating to normalized variance for th_l [-] + alpha_rt_zm, & ! Factor relating to normalized variance for r_t [-] + alpha_rt_zt ! Factor relating to normalized variance for r_t [-] + + integer :: i + + !----------------------- Begin Code ----------------------------- + + ! Store components of pdf_params in the locally declared variables + ! We only apply the trapezoidal rule to these when + ! l_apply_rule_to_pdf_params is true. This is because when we apply the + ! rule to the final result of pdf_closure rather than the intermediate + ! results it can lead to an inconsistency in how we determine which + ! PDF component a point is in and whether the point is in or out of cloud, + ! which is turn will break the latin hypercube code that samples + ! preferentially in cloud. -dschanen 13 Feb 2012 + + if ( l_apply_rule_to_pdf_params ) then + w_1_zt = pdf_params%w_1 + w_2_zt = pdf_params%w_2 + varnce_w_1_zt = pdf_params%varnce_w_1 + varnce_w_2_zt = pdf_params%varnce_w_2 + rt_1_zt = pdf_params%rt_1 + rt_2_zt = pdf_params%rt_2 + varnce_rt_1_zt = pdf_params%varnce_rt_1 + varnce_rt_2_zt = pdf_params%varnce_rt_2 + crt_1_zt = pdf_params%crt_1 + crt_2_zt = pdf_params%crt_2 + cthl_1_zt = pdf_params%cthl_1 + cthl_2_zt = pdf_params%cthl_2 + thl_1_zt = pdf_params%thl_1 + thl_2_zt = pdf_params%thl_2 + varnce_thl_1_zt = pdf_params%varnce_thl_1 + varnce_thl_2_zt = pdf_params%varnce_thl_2 + mixt_frac_zt = pdf_params%mixt_frac + rc_1_zt = pdf_params%rc_1 + rc_2_zt = pdf_params%rc_2 + rsatl_1_zt = pdf_params%rsatl_1 + rsatl_2_zt = pdf_params%rsatl_2 + cloud_frac_1_zt = pdf_params%cloud_frac_1 + cloud_frac_2_zt = pdf_params%cloud_frac_2 + chi_1_zt = pdf_params%chi_1 + chi_2_zt = pdf_params%chi_2 + stdev_chi_1_zt = pdf_params%stdev_chi_1 + stdev_chi_2_zt = pdf_params%stdev_chi_2 + stdev_eta_1_zt = pdf_params%stdev_eta_1 + stdev_eta_2_zt = pdf_params%stdev_eta_2 + rrtthl_zt = pdf_params%rrtthl + alpha_thl_zt = pdf_params%alpha_thl + alpha_rt_zt = pdf_params%alpha_rt + end if + + ! If l_call_pdf_closure_twice is true, the _zm variables already have + ! values from the second call to pdf_closure in advance_clubb_core. + ! If it is false, the variables are interpolated to the _zm levels. + if ( l_call_pdf_closure_twice ) then + + ! Store, in locally declared variables, the pdf_params output + ! from the second call to pdf_closure + if ( l_apply_rule_to_pdf_params ) then + w_1_zm = pdf_params_zm%w_1 + w_2_zm = pdf_params_zm%w_2 + varnce_w_1_zm = pdf_params_zm%varnce_w_1 + varnce_w_2_zm = pdf_params_zm%varnce_w_2 + rt_1_zm = pdf_params_zm%rt_1 + rt_2_zm = pdf_params_zm%rt_2 + varnce_rt_1_zm = pdf_params_zm%varnce_rt_1 + varnce_rt_2_zm = pdf_params_zm%varnce_rt_2 + crt_1_zm = pdf_params_zm%crt_1 + crt_2_zm = pdf_params_zm%crt_2 + cthl_1_zm = pdf_params_zm%cthl_1 + cthl_2_zm = pdf_params_zm%cthl_2 + thl_1_zm = pdf_params_zm%thl_1 + thl_2_zm = pdf_params_zm%thl_2 + varnce_thl_1_zm = pdf_params_zm%varnce_thl_1 + varnce_thl_2_zm = pdf_params_zm%varnce_thl_2 + mixt_frac_zm = pdf_params_zm%mixt_frac + rc_1_zm = pdf_params_zm%rc_1 + rc_2_zm = pdf_params_zm%rc_2 + rsatl_1_zm = pdf_params_zm%rsatl_1 + rsatl_2_zm = pdf_params_zm%rsatl_2 + cloud_frac_1_zm = pdf_params_zm%cloud_frac_1 + cloud_frac_2_zm = pdf_params_zm%cloud_frac_2 + chi_1_zm = pdf_params_zm%chi_1 + chi_2_zm = pdf_params_zm%chi_2 + stdev_chi_1_zm = pdf_params_zm%stdev_chi_1 + stdev_chi_2_zm = pdf_params_zm%stdev_chi_2 + stdev_eta_1_zm = pdf_params_zm%stdev_eta_1 + stdev_eta_2_zm = pdf_params_zm%stdev_eta_2 + rrtthl_zm = pdf_params_zm%rrtthl + alpha_thl_zm = pdf_params_zm%alpha_thl + alpha_rt_zm = pdf_params_zm%alpha_rt + end if + + else + + ! Interpolate thermodynamic variables to the momentum grid. + ! Since top momentum level is higher than top thermo. level, + ! set variables at top momentum level to 0. + wprtp2_zm = zt2zm( wprtp2 ) + wprtp2_zm(gr%nz) = 0.0_core_rknd + wpthlp2_zm = zt2zm( wpthlp2 ) + wpthlp2_zm(gr%nz) = 0.0_core_rknd + wprtpthlp_zm = zt2zm( wprtpthlp ) + wprtpthlp_zm(gr%nz) = 0.0_core_rknd + cloud_frac_zm = zt2zm( cloud_frac ) + cloud_frac_zm(gr%nz) = 0.0_core_rknd + ice_supersat_frac_zm = zt2zm( ice_supersat_frac ) + ice_supersat_frac_zm(gr%nz) = 0.0_core_rknd + rcm_zm = zt2zm( rcm ) + rcm_zm(gr%nz) = 0.0_core_rknd + wp2thvp_zm = zt2zm( wp2thvp ) + wp2thvp_zm(gr%nz) = 0.0_core_rknd + + do i = 1, sclr_dim + wpsclrprtp_zm(:,i) = zt2zm( wpsclrprtp(:,i) ) + wpsclrprtp_zm(gr%nz,i) = 0.0_core_rknd + wpsclrp2_zm(:,i) = zt2zm( wpsclrp2(:,i) ) + wpsclrp2_zm(gr%nz,i) = 0.0_core_rknd + wpsclrpthlp_zm(:,i) = zt2zm( wpsclrpthlp(:,i) ) + wpsclrpthlp_zm(gr%nz,i) = 0.0_core_rknd + end do ! i = 1, sclr_dim + + if ( l_apply_rule_to_pdf_params ) then + w_1_zm = zt2zm( pdf_params%w_1 ) + w_1_zm(gr%nz) = 0.0_core_rknd + w_2_zm = zt2zm( pdf_params%w_2 ) + w_2_zm(gr%nz) = 0.0_core_rknd + varnce_w_1_zm = zt2zm( pdf_params%varnce_w_1 ) + varnce_w_1_zm(gr%nz) = 0.0_core_rknd + varnce_w_2_zm = zt2zm( pdf_params%varnce_w_2 ) + varnce_w_2_zm(gr%nz) = 0.0_core_rknd + rt_1_zm = zt2zm( pdf_params%rt_1 ) + rt_1_zm(gr%nz) = 0.0_core_rknd + rt_2_zm = zt2zm( pdf_params%rt_2 ) + rt_2_zm(gr%nz) = 0.0_core_rknd + varnce_rt_1_zm = zt2zm( pdf_params%varnce_rt_1 ) + varnce_rt_1_zm(gr%nz) = 0.0_core_rknd + varnce_rt_2_zm = zt2zm( pdf_params%varnce_rt_2 ) + varnce_rt_2_zm(gr%nz) = 0.0_core_rknd + crt_1_zm = zt2zm( pdf_params%crt_1 ) + crt_1_zm(gr%nz) = 0.0_core_rknd + crt_2_zm = zt2zm( pdf_params%crt_2 ) + crt_2_zm(gr%nz) = 0.0_core_rknd + cthl_1_zm = zt2zm( pdf_params%cthl_1 ) + cthl_1_zm(gr%nz) = 0.0_core_rknd + cthl_2_zm = zt2zm( pdf_params%cthl_2 ) + cthl_2_zm(gr%nz) = 0.0_core_rknd + thl_1_zm = zt2zm( pdf_params%thl_1 ) + thl_1_zm(gr%nz) = 0.0_core_rknd + thl_2_zm = zt2zm( pdf_params%thl_2 ) + thl_2_zm(gr%nz) = 0.0_core_rknd + varnce_thl_1_zm = zt2zm( pdf_params%varnce_thl_1 ) + varnce_thl_1_zm(gr%nz) = 0.0_core_rknd + varnce_thl_2_zm = zt2zm( pdf_params%varnce_thl_2 ) + varnce_thl_2_zm(gr%nz) = 0.0_core_rknd + mixt_frac_zm = zt2zm( pdf_params%mixt_frac ) + mixt_frac_zm(gr%nz) = 0.0_core_rknd + rc_1_zm = zt2zm( pdf_params%rc_1 ) + rc_1_zm(gr%nz) = 0.0_core_rknd + rc_2_zm = zt2zm( pdf_params%rc_2 ) + rc_2_zm(gr%nz) = 0.0_core_rknd + rsatl_1_zm = zt2zm( pdf_params%rsatl_1 ) + rsatl_1_zm(gr%nz) = 0.0_core_rknd + rsatl_2_zm = zt2zm( pdf_params%rsatl_2 ) + rsatl_2_zm(gr%nz) = 0.0_core_rknd + cloud_frac_1_zm = zt2zm( pdf_params%cloud_frac_1 ) + cloud_frac_1_zm(gr%nz) = 0.0_core_rknd + cloud_frac_2_zm = zt2zm( pdf_params%cloud_frac_2 ) + cloud_frac_2_zm(gr%nz) = 0.0_core_rknd + chi_1_zm = zt2zm( pdf_params%chi_1 ) + chi_1_zm(gr%nz) = 0.0_core_rknd + chi_2_zm = zt2zm( pdf_params%chi_2 ) + chi_2_zm(gr%nz) = 0.0_core_rknd + stdev_chi_1_zm = zt2zm( pdf_params%stdev_chi_1 ) + stdev_chi_1_zm(gr%nz) = 0.0_core_rknd + stdev_chi_2_zm = zt2zm( pdf_params%stdev_chi_2 ) + stdev_chi_2_zm(gr%nz) = 0.0_core_rknd + stdev_eta_1_zm = zt2zm( pdf_params%stdev_eta_1 ) + stdev_eta_1_zm(gr%nz) = 0.0_core_rknd + stdev_eta_2_zm = zt2zm( pdf_params%stdev_eta_2 ) + stdev_eta_2_zm(gr%nz) = 0.0_core_rknd + rrtthl_zm = zt2zm( pdf_params%rrtthl ) + rrtthl_zm(gr%nz) = 0.0_core_rknd + alpha_thl_zm = zt2zm( pdf_params%alpha_thl ) + alpha_thl_zm(gr%nz) = 0.0_core_rknd + alpha_rt_zm = zt2zm( pdf_params%alpha_rt ) + alpha_rt_zm(gr%nz) = 0.0_core_rknd + end if + end if ! l_call_pdf_closure_twice + + if ( l_stats ) then + ! Use the trapezoidal rule to recompute the variables on the stats_zt level + if ( iwprtp2 > 0 ) then + wprtp2 = trapezoid_zt( wprtp2, wprtp2_zm ) + end if + if ( iwpthlp2 > 0 ) then + wpthlp2 = trapezoid_zt( wpthlp2, wpthlp2_zm ) + end if + if ( iwprtpthlp > 0 ) then + wprtpthlp = trapezoid_zt( wprtpthlp, wprtpthlp_zm ) + end if + + do i = 1, sclr_dim + if ( iwpsclrprtp(i) > 0 ) then + wpsclrprtp(:,i) = trapezoid_zt( wpsclrprtp(:,i), wpsclrprtp_zm(:,i) ) + end if + if ( iwpsclrpthlp(i) > 0 ) then + wpsclrpthlp(:,i) = trapezoid_zt( wpsclrpthlp(:,i), wpsclrpthlp_zm(:,i) ) + end if + if ( iwpsclrp2(i) > 0 ) then + wpsclrp2(:,i) = trapezoid_zt( wpsclrp2(:,i), wpsclrp2_zm(:,i) ) + end if + end do ! i = 1, sclr_dim + end if ! l_stats + + cloud_frac = trapezoid_zt( cloud_frac, cloud_frac_zm ) + ice_supersat_frac = trapezoid_zt( ice_supersat_frac, ice_supersat_frac_zm ) + rcm = trapezoid_zt( rcm, rcm_zm ) + + wp2thvp = trapezoid_zt( wp2thvp, wp2thvp_zm ) + + if ( l_apply_rule_to_pdf_params ) then + ! Note: this code makes PDF component cloud water mixing ratios and + ! cloud fractions inconsistent with the PDF. Other parts of + ! CLUBB require PDF component cloud fractions to remain + ! consistent with the PDF. This code needs to be refactored + ! so that cloud_frac_1 and cloud_frac_2 are preserved. + write(fstderr,*) "The code in l_apply_rule_to_pdf_params does not " & + // "preserve cloud_frac_1 and cloud_frac_2 in a " & + // "manner consistent with the PDF as required " & + // "by other parts of CLUBB." + stop "Please refactor before continuing." + pdf_params%w_1 = trapezoid_zt( w_1_zt, w_1_zm ) + pdf_params%w_2 = trapezoid_zt( w_2_zt, w_2_zm ) + pdf_params%varnce_w_1 = trapezoid_zt( varnce_w_1_zt, varnce_w_1_zm ) + pdf_params%varnce_w_2 = trapezoid_zt( varnce_w_2_zt, varnce_w_2_zm ) + pdf_params%rt_1 = trapezoid_zt( rt_1_zt, rt_1_zm ) + pdf_params%rt_2 = trapezoid_zt( rt_2_zt, rt_2_zm ) + pdf_params%varnce_rt_1 = trapezoid_zt( varnce_rt_1_zt, varnce_rt_1_zm ) + pdf_params%varnce_rt_2 = trapezoid_zt( varnce_rt_2_zt, varnce_rt_2_zm ) + pdf_params%crt_1 = trapezoid_zt( crt_1_zt, crt_1_zm ) + pdf_params%crt_2 = trapezoid_zt( crt_2_zt, crt_2_zm ) + pdf_params%cthl_1 = trapezoid_zt( cthl_1_zt, cthl_1_zm ) + pdf_params%cthl_2 = trapezoid_zt( cthl_2_zt, cthl_2_zm ) + pdf_params%thl_1 = trapezoid_zt( thl_1_zt, thl_1_zm ) + pdf_params%thl_2 = trapezoid_zt( thl_2_zt, thl_2_zm ) + pdf_params%varnce_thl_1 = trapezoid_zt( varnce_thl_1_zt, varnce_thl_1_zm ) + pdf_params%varnce_thl_2 = trapezoid_zt( varnce_thl_2_zt, varnce_thl_2_zm ) + pdf_params%mixt_frac = trapezoid_zt( mixt_frac_zt, mixt_frac_zm ) + pdf_params%rc_1 = trapezoid_zt( rc_1_zt, rc_1_zm ) + pdf_params%rc_2 = trapezoid_zt( rc_2_zt, rc_2_zm ) + pdf_params%rsatl_1 = trapezoid_zt( rsatl_1_zt, rsatl_1_zm ) + pdf_params%rsatl_2 = trapezoid_zt( rsatl_2_zt, rsatl_2_zm ) + pdf_params%cloud_frac_1 = trapezoid_zt( cloud_frac_1_zt, cloud_frac_1_zm ) + pdf_params%cloud_frac_2 = trapezoid_zt( cloud_frac_2_zt, cloud_frac_2_zm ) + pdf_params%chi_1 = trapezoid_zt( chi_1_zt, chi_1_zm ) + pdf_params%chi_2 = trapezoid_zt( chi_2_zt, chi_2_zm ) + pdf_params%rrtthl = trapezoid_zt( rrtthl_zt, rrtthl_zm ) + pdf_params%alpha_thl = trapezoid_zt( alpha_thl_zt, alpha_thl_zm ) + pdf_params%alpha_rt = trapezoid_zt( alpha_rt_zt, alpha_rt_zm ) + pdf_params%stdev_chi_1 = trapezoid_zt( stdev_chi_1_zt, stdev_chi_1_zm ) + pdf_params%stdev_chi_2 = trapezoid_zt( stdev_chi_2_zt, stdev_chi_2_zm ) + pdf_params%stdev_eta_1 = trapezoid_zt( stdev_eta_1_zt, stdev_eta_1_zm ) + pdf_params%stdev_eta_2 = trapezoid_zt( stdev_eta_2_zt, stdev_eta_2_zm ) + end if + + ! End of trapezoidal rule + + return + end subroutine trapezoidal_rule_zt + + !----------------------------------------------------------------------- + subroutine trapezoidal_rule_zm & + ( wpthvp_zt, thlpthvp_zt, rtpthvp_zt, & ! intent(in) + wpthvp, thlpthvp, rtpthvp ) ! intent(inout) + ! + ! Description: + ! This subroutine recomputes three variables on the + ! momentum grid from pdf_closure -- wpthvp, thlpthvp, and + ! rtpthvp -- by calling the function trapezoid_zm. Only these three + ! variables are used in this subroutine because they are the only + ! pdf_closure momentum variables used elsewhere in CLUBB. + ! + ! The _zt variables are output from the first call to pdf_closure. + ! The _zm variables are output from the second call to pdf_closure + ! on the momentum levels. + ! This is done before the call to this subroutine. + ! + ! ldgrant Feb. 2010 + ! + ! References: + ! None + !----------------------------------------------------------------------- + + use grid_class, only: gr ! Variable + + use clubb_precision, only: & + core_rknd ! variable(s) + + implicit none + + ! Input variables + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + wpthvp_zt, & ! Buoyancy flux (on thermo. grid) [(K m)/s] + thlpthvp_zt, & ! th_l' th_v' (on thermo. grid) [K^2] + rtpthvp_zt ! r_t' th_v' (on thermo. grid) [(kg K)/kg] + + ! Input/Output variables + real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & + wpthvp, & ! Buoyancy flux [(K m)/s] + thlpthvp, & ! th_l' th_v' [K^2] + rtpthvp ! r_t' th_v' [(kg K)/kg] + + !----------------------- Begin Code ----------------------------- + + ! Use the trapezoidal rule to recompute the variables on the zm level + wpthvp = trapezoid_zm( wpthvp, wpthvp_zt ) + thlpthvp = trapezoid_zm( thlpthvp, thlpthvp_zt ) + rtpthvp = trapezoid_zm( rtpthvp, rtpthvp_zt ) + + return + end subroutine trapezoidal_rule_zm + + !----------------------------------------------------------------------- + pure function trapezoid_zt( variable_zt, variable_zm ) + ! + ! Description: + ! Function which uses the trapezoidal rule from calculus + ! to recompute the values for the variables on the thermo. grid which + ! are output from the first call to pdf_closure in module clubb_core. + ! + ! ldgrant June 2009 + !-------------------------------------------------------------------- + + use grid_class, only: gr ! Variable + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + variable_zt, & ! Variable on the zt grid + variable_zm ! Variable on the zm grid + + ! Result + real( kind = core_rknd ), dimension(gr%nz) :: trapezoid_zt + + ! Local Variable + integer :: k ! Loop index + + !------------ Begin Code -------------- + + ! Boundary condition: trapezoidal rule not valid at zt level 1 + trapezoid_zt(1) = variable_zt(1) + + do k = 2, gr%nz + ! Trapezoidal rule from calculus + trapezoid_zt(k) = 0.5_core_rknd * ( variable_zm(k) + variable_zt(k) ) & + * ( gr%zm(k) - gr%zt(k) ) * gr%invrs_dzt(k) & + + 0.5_core_rknd * ( variable_zt(k) + variable_zm(k-1) ) & + * ( gr%zt(k) - gr%zm(k-1) ) * gr%invrs_dzt(k) + end do ! k = 2, gr%nz + + return + end function trapezoid_zt + + !----------------------------------------------------------------------- + pure function trapezoid_zm( variable_zm, variable_zt ) + ! + ! Description: + ! Function which uses the trapezoidal rule from calculus + ! to recompute the values for the important variables on the momentum + ! grid which are output from pdf_closure in module clubb_core. + ! These momentum variables only include wpthvp, thlpthvp, and rtpthvp. + ! + ! ldgrant Feb. 2010 + !-------------------------------------------------------------------- + + use grid_class, only: gr ! Variable + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + variable_zm, & ! Variable on the zm grid + variable_zt ! Variable on the zt grid + + ! Result + real( kind = core_rknd ), dimension(gr%nz) :: trapezoid_zm + + ! Local Variable + integer :: k ! Loop index + + !------------ Begin Code -------------- + + ! Boundary conditions: trapezoidal rule not valid at top zm level, nzmax. + ! Trapezoidal rule also not used at zm level 1. + trapezoid_zm(1) = variable_zm(1) + trapezoid_zm(gr%nz) = variable_zm(gr%nz) + + do k = 2, gr%nz-1 + ! Trapezoidal rule from calculus + trapezoid_zm(k) = 0.5_core_rknd * ( variable_zt(k+1) + variable_zm(k) ) & + * ( gr%zt(k+1) - gr%zm(k) ) * gr%invrs_dzm(k) & + + 0.5_core_rknd * ( variable_zm(k) + variable_zt(k) ) & + * ( gr%zm(k) - gr%zt(k) ) * gr%invrs_dzm(k) + end do ! k = 2, gr%nz-1 + + return + end function trapezoid_zm + + !----------------------------------------------------------------------- + subroutine compute_cloud_cover & + ( pdf_params, cloud_frac, rcm, & ! intent(in) + cloud_cover, rcm_in_layer ) ! intent(out) + ! + ! Description: + ! Subroutine to compute cloud cover (the amount of sky + ! covered by cloud) and rcm in layer (liquid water mixing ratio in + ! the portion of the grid box filled by cloud). + ! + ! References: + ! Definition of 's' comes from: + ! ``The Gaussian Cloud Model Relations'' G. L. Mellor (1977) + ! JAS, Vol. 34, pp. 356--358. + ! + ! Notes: + ! Added July 2009 + !--------------------------------------------------------------------- + + use constants_clubb, only: & + rc_tol, & ! Variable(s) + fstderr + + use grid_class, only: gr ! Variable + + use pdf_parameter_module, only: & + pdf_parameter ! Derived data type + + use error_code, only: & + clubb_at_least_debug_level ! Procedure + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External functions + intrinsic :: abs, min, max + + ! Input variables + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + cloud_frac, & ! Cloud fraction [-] + rcm ! Liquid water mixing ratio [kg/kg] + + type (pdf_parameter), dimension(gr%nz), intent(in) :: & + pdf_params ! PDF Parameters [units vary] + + ! Output variables + real( kind = core_rknd ), dimension(gr%nz), intent(out) :: & + cloud_cover, & ! Cloud cover [-] + rcm_in_layer ! Liquid water mixing ratio in cloud layer [kg/kg] + + ! Local variables + real( kind = core_rknd ), dimension(gr%nz) :: & + chi_mean, & ! Mean extended cloud water mixing ratio of the + ! two Gaussian distributions + vert_cloud_frac_upper, & ! Fraction of cloud in top half of grid box + vert_cloud_frac_lower, & ! Fraction of cloud in bottom half of grid box + vert_cloud_frac ! Fraction of cloud filling the grid box in the vertical + + integer :: k + + ! ------------ Begin code --------------- + + do k = 1, gr%nz + + chi_mean(k) = pdf_params(k)%mixt_frac * pdf_params(k)%chi_1 + & + (1.0_core_rknd-pdf_params(k)%mixt_frac) * pdf_params(k)%chi_2 + + end do + + do k = 2, gr%nz-1, 1 + + if ( rcm(k) < rc_tol ) then ! No cloud at this level + + cloud_cover(k) = cloud_frac(k) + rcm_in_layer(k) = rcm(k) + + else if ( ( rcm(k+1) >= rc_tol ) .and. ( rcm(k-1) >= rc_tol ) ) then + ! There is cloud above and below, + ! so assume cloud fills grid box from top to bottom + + cloud_cover(k) = cloud_frac(k) + rcm_in_layer(k) = rcm(k) + + else if ( ( rcm(k+1) < rc_tol ) .or. ( rcm(k-1) < rc_tol) ) then + ! Cloud may fail to reach gridbox top or base or both + + ! First let the cloud fill the entire grid box, then overwrite + ! vert_cloud_frac_upper(k) and/or vert_cloud_frac_lower(k) + ! for a cloud top, cloud base, or one-point cloud. + vert_cloud_frac_upper(k) = 0.5_core_rknd + vert_cloud_frac_lower(k) = 0.5_core_rknd + + if ( rcm(k+1) < rc_tol ) then ! Cloud top + + vert_cloud_frac_upper(k) = & + ( ( 0.5_core_rknd / gr%invrs_dzm(k) ) / ( gr%zm(k) - gr%zt(k) ) ) & + * ( rcm(k) / ( rcm(k) + abs( chi_mean(k+1) ) ) ) + + vert_cloud_frac_upper(k) = min( 0.5_core_rknd, vert_cloud_frac_upper(k) ) + + ! Make the transition in cloudiness more gradual than using + ! the above min statement alone. + vert_cloud_frac_upper(k) = vert_cloud_frac_upper(k) + & + ( ( rcm(k+1)/rc_tol )*( 0.5_core_rknd -vert_cloud_frac_upper(k) ) ) + + else + + vert_cloud_frac_upper(k) = 0.5_core_rknd + + end if + + if ( rcm(k-1) < rc_tol ) then ! Cloud base + + vert_cloud_frac_lower(k) = & + ( ( 0.5_core_rknd / gr%invrs_dzm(k-1) ) / ( gr%zt(k) - gr%zm(k-1) ) ) & + * ( rcm(k) / ( rcm(k) + abs( chi_mean(k-1) ) ) ) + + vert_cloud_frac_lower(k) = min( 0.5_core_rknd, vert_cloud_frac_lower(k) ) + + ! Make the transition in cloudiness more gradual than using + ! the above min statement alone. + vert_cloud_frac_lower(k) = vert_cloud_frac_lower(k) + & + ( ( rcm(k-1)/rc_tol )*( 0.5_core_rknd -vert_cloud_frac_lower(k) ) ) + + else + + vert_cloud_frac_lower(k) = 0.5_core_rknd + + end if + + vert_cloud_frac(k) = & + vert_cloud_frac_upper(k) + vert_cloud_frac_lower(k) + + vert_cloud_frac(k) = & + max( cloud_frac(k), min( 1.0_core_rknd, vert_cloud_frac(k) ) ) + + cloud_cover(k) = cloud_frac(k) / vert_cloud_frac(k) + rcm_in_layer(k) = rcm(k) / vert_cloud_frac(k) + + else + + if ( clubb_at_least_debug_level( 1 ) ) then + + write(fstderr,*) & + "Error: Should not arrive here in computation of cloud_cover" + + write(fstderr,*) "At grid level k = ", k + write(fstderr,*) "pdf_params(k)%mixt_frac = ", pdf_params(k)%mixt_frac + write(fstderr,*) "pdf_params(k)%chi_1 = ", pdf_params(k)%chi_1 + write(fstderr,*) "pdf_params(k)%chi_2 = ", pdf_params(k)%chi_2 + write(fstderr,*) "cloud_frac(k) = ", cloud_frac(k) + write(fstderr,*) "rcm(k) = ", rcm(k) + write(fstderr,*) "rcm(k+1) = ", rcm(k+1) + write(fstderr,*) "rcm(k-1) = ", rcm(k-1) + + end if + + return + + end if ! rcm(k) < rc_tol + + end do ! k = 2, gr%nz-1, 1 + + cloud_cover(1) = cloud_frac(1) + cloud_cover(gr%nz) = cloud_frac(gr%nz) + + rcm_in_layer(1) = rcm(1) + rcm_in_layer(gr%nz) = rcm(gr%nz) + + return + end subroutine compute_cloud_cover + !----------------------------------------------------------------------- + subroutine clip_rcm & + ( rtm, message, & ! intent(in) + rcm ) ! intent(inout) + ! + ! Description: + ! Subroutine that reduces cloud water (rcm) whenever + ! it exceeds total water (rtm = vapor + liquid). + ! This avoids negative values of rvm = water vapor mixing ratio. + ! However, it will not ensure that rcm <= rtm if rtm <= 0. + ! + ! References: + ! None + !--------------------------------------------------------------------- + + + use grid_class, only: gr ! Variable + + use error_code, only : & + clubb_at_least_debug_level ! Procedure(s) + + use constants_clubb, only: & + fstderr, & ! Variable(s) + zero_threshold + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External functions + intrinsic :: max, epsilon + + ! Input variables + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + rtm ! Total water mixing ratio [kg/kg] + + character(len= * ), intent(in) :: message + + real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & + rcm ! Cloud water mixing ratio [kg/kg] + + integer :: k + + ! ------------ Begin code --------------- + + ! Vince Larson clipped rcm in order to prevent rvm < 0. 5 Apr 2008. + ! This code won't work unless rtm >= 0 !!! + ! We do not clip rcm_in_layer because rcm_in_layer only influences + ! radiation, and we do not want to bother recomputing it. 6 Aug 2009 + do k = 1, gr%nz + if ( rtm(k) < rcm(k) ) then + + if ( clubb_at_least_debug_level(1) ) then + write(fstderr,*) message, ' at k=', k, 'rcm(k) = ', rcm(k), & + 'rtm(k) = ', rtm(k), '.', ' Clipping rcm.' + + end if ! clubb_at_least_debug_level(1) + + rcm(k) = max( zero_threshold, rtm(k) - epsilon( rtm(k) ) ) + + end if ! rtm(k) < rcm(k) + + end do ! k=1..gr%nz + + return + end subroutine clip_rcm + + !----------------------------------------------------------------------------- + subroutine set_Lscale_max( l_implemented, host_dx, host_dy, & + Lscale_max ) + + ! Description: + ! This subroutine sets the value of Lscale_max, which is the maximum + ! allowable value of Lscale. For standard CLUBB, it is set to a very large + ! value so that Lscale will not be limited. However, when CLUBB is running + ! as part of a host model, the value of Lscale_max is dependent on the size + ! of the host model's horizontal grid spacing. The smaller the host model's + ! horizontal grid spacing, the smaller the value of Lscale_max. When Lscale + ! is limited to a small value, the value of time-scale Tau is reduced, which + ! in turn produces greater damping on CLUBB's turbulent parameters. This + ! is the desired effect on turbulent parameters for a host model with small + ! horizontal grid spacing, for small areas usually contain much less + ! variation in meteorological quantities than large areas. + + ! References: + ! None + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + logical, intent(in) :: & + l_implemented ! Flag to see if CLUBB is running on it's own, + ! or if it's implemented as part of a host model. + + real( kind = core_rknd ), intent(in) :: & + host_dx, & ! Host model's east-west horizontal grid spacing [m] + host_dy ! Host model's north-south horizontal grid spacing [m] + + ! Output Variable + real( kind = core_rknd ), intent(out) :: & + Lscale_max ! Maximum allowable value for Lscale [m] + + ! ---- Begin Code ---- + + ! Determine the maximum allowable value for Lscale (in meters). + if ( l_implemented ) then + Lscale_max = 0.25_core_rknd * min( host_dx, host_dy ) + else + Lscale_max = 1.0e5_core_rknd + end if + + return + end subroutine set_Lscale_max + +!=============================================================================== + pure subroutine calculate_thlp2_rad & + ( nz, rcm_zm, thlprcp, radht_zm, & ! Intent(in) + thlp2_forcing ) ! Intent(inout) + + ! Description: + ! Computes the contribution of radiative cooling to thlp2 + + ! References: + ! See clubb:ticket:632 + !---------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Constant(s) + + use grid_class, only: & + zt2zm ! Procedure + + use constants_clubb, only: & + two, & + rc_tol + + use parameters_tunable, only: & + thlp2_rad_coef ! Variable(s) + + implicit none + + ! Input Variables + integer, intent(in) :: & + nz ! Number of vertical levels [-] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + rcm_zm, & ! Cloud water mixing ratio on momentum grid [kg/kg] + thlprcp, & ! thl'rc' [K kg/kg] + radht_zm ! SW + LW heating rate (on momentum grid) [K/s] + + ! Input/Output Variables + real( kind = core_rknd ), dimension(nz), intent(inout) :: & + thlp2_forcing ! forcing (momentum levels) [K^2/s] + + ! Local Variables + integer :: & + k ! Loop iterator [-] + + !---------------------------------------------------------------------- + + + do k = 1, nz + + if ( rcm_zm(k) > rc_tol ) then + + thlp2_forcing(k) = thlp2_forcing(k) + & + thlp2_rad_coef * ( two ) * radht_zm(k) / rcm_zm(k) * thlprcp(k) + + end if + + end do + + + return + end subroutine calculate_thlp2_rad + + + !----------------------------------------------------------------------- + +end module advance_clubb_core_module diff --git a/models/atm/cam/src/physics/clubb/advance_helper_module.F90 b/models/atm/cam/src/physics/clubb/advance_helper_module.F90 index 0abef8e02291..503877e2d1d7 100644 --- a/models/atm/cam/src/physics/clubb/advance_helper_module.F90 +++ b/models/atm/cam/src/physics/clubb/advance_helper_module.F90 @@ -1,5 +1,6 @@ !------------------------------------------------------------------------- -! $Id: advance_helper_module.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +! $Id: advance_helper_module.F90 7381 2014-11-11 23:59:39Z schemena@uwm.edu $ +!=============================================================================== module advance_helper_module ! Description: @@ -8,7 +9,10 @@ module advance_helper_module implicit none - public :: set_boundary_conditions_lhs, set_boundary_conditions_rhs + public :: & + set_boundary_conditions_lhs, & + set_boundary_conditions_rhs, & + calc_stability_correction private ! Set Default Scope @@ -30,19 +34,25 @@ subroutine set_boundary_conditions_lhs( diag_index, low_bound, high_bound, lhs, implicit none + ! Exernal + intrinsic :: present + + ! Input Variables integer, intent(in) :: & diag_index, low_bound, high_bound ! boundary indexes for the first variable - integer, intent(in), optional :: & - diag_index2, low_bound2, high_bound2 ! boundary indexes for the second variable - + ! Input / Output Variables real( kind = core_rknd ), dimension(:,:), intent(inout) :: & lhs ! left hand side of the LAPACK matrix equation + ! Optional Input Variables + integer, intent(in), optional :: & + diag_index2, low_bound2, high_bound2 ! boundary indexes for the second variable + ! --------------------- BEGIN CODE ---------------------- - if( ( present(low_bound2) .or. present(high_bound2) ) .and. & - ( .not. present(diag_index2) ) ) then + if ( ( present( low_bound2 ) .or. present( high_bound2 ) ) .and. & + ( .not. present( diag_index2 ) ) ) then stop "Boundary index provided without diag_index." @@ -57,7 +67,7 @@ subroutine set_boundary_conditions_lhs( diag_index, low_bound, high_bound, lhs, lhs(diag_index,high_bound) = 1.0_core_rknd ! Set the lower boundaries for the second variable, if it is provided - if( present(low_bound2) ) then + if ( present( low_bound2 ) ) then lhs(:,low_bound2) = 0.0_core_rknd lhs(diag_index2,low_bound2) = 1.0_core_rknd @@ -65,13 +75,14 @@ subroutine set_boundary_conditions_lhs( diag_index, low_bound, high_bound, lhs, end if ! Set the upper boundaries for the second variable, if it is provided - if( present(high_bound2) ) then + if ( present( high_bound2 ) ) then lhs(:,high_bound2) = 0.0_core_rknd lhs(diag_index2,high_bound2) = 1.0_core_rknd end if + return end subroutine set_boundary_conditions_lhs !-------------------------------------------------------------------------- @@ -92,28 +103,38 @@ subroutine set_boundary_conditions_rhs( & implicit none + ! Exernal + intrinsic :: present + + ! Input Variables + ! The values for the first variable real( kind = core_rknd ), intent(in) :: low_value, high_value ! The bounds for the first variable integer, intent(in) :: low_bound, high_bound + ! Input / Output Variables + + ! The right-hand side vector + real( kind = core_rknd ), dimension(:), intent(inout) :: rhs + + ! Optional Input Variables + ! The values for the second variable real( kind = core_rknd ), intent(in), optional :: low_value2, high_value2 ! The bounds for the second variable integer, intent(in), optional :: low_bound2, high_bound2 - ! The right-hand side vector - real( kind = core_rknd ), dimension(:), intent(inout) :: rhs ! -------------------- BEGIN CODE ------------------------ ! Stop execution if a boundary was provided without a value - if( (present(low_bound2) .and. (.not. present(low_value2))) .or. & - (present(high_bound2) .and. (.not. present(high_value2))) ) then + if ( (present( low_bound2 ) .and. (.not. present( low_value2 ))) .or. & + (present( high_bound2 ) .and. (.not. present( high_value2 ))) ) then - stop "Boundary condition provided without value." + stop "Boundary condition provided without value." end if @@ -122,15 +143,75 @@ subroutine set_boundary_conditions_rhs( & rhs(high_bound) = high_value ! If a lower bound was given for the second variable, set it - if( present(low_bound2) ) then + if ( present( low_bound2 ) ) then rhs(low_bound2) = low_value2 end if ! If an upper bound was given for the second variable, set it - if( present(high_bound2) ) then + if ( present( high_bound2 ) ) then rhs(high_bound2) = high_value2 end if + return end subroutine set_boundary_conditions_rhs + !=============================================================================== + function calc_stability_correction( thlm, Lscale, em ) & + result ( stability_correction ) + ! + ! Description: + ! Stability Factor + ! + ! References: + ! + !-------------------------------------------------------------------- + + use parameters_model, only: & + T0 ! Variables(s) + + use constants_clubb, only: & + zero, & ! Constant(s) + grav + + use grid_class, only: & + gr, & ! Variable(s) + zt2zm, & ! Procedure(s) + ddzt + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + Lscale, & ! Turbulent mixing length [m] + em, & ! Turbulent Kinetic Energy (TKE) [m^2/s^2] + thlm ! th_l (thermo. levels) [K] + + ! Result + real( kind = core_rknd ), dimension(gr%nz) :: & + stability_correction + + ! Local Variables + real( kind = core_rknd ) :: & + lambda0_stability_coef ! [] + + real( kind = core_rknd ), dimension(gr%nz) :: & + brunt_vaisala_freq, & ! [] + lambda0_stability + + !------------ Begin Code -------------- + ! lambda0_stability_coef = 0.025_core_rknd + ! changed to 0.030 to provide a simulation similar to track02 simulation + lambda0_stability_coef = 0.030_core_rknd + brunt_vaisala_freq = ( grav / T0 ) * ddzt( thlm ) + lambda0_stability = merge( lambda0_stability_coef, zero, brunt_vaisala_freq > zero ) + + stability_correction = 1.0_core_rknd & + + min( lambda0_stability * brunt_vaisala_freq * zt2zm( Lscale )**2 / em, 3.0_core_rknd ) + + return + end function calc_stability_correction + end module advance_helper_module diff --git a/models/atm/cam/src/physics/clubb/advance_windm_edsclrm_module.F90 b/models/atm/cam/src/physics/clubb/advance_windm_edsclrm_module.F90 index d328ed76c016..90ae4f2c7f3e 100644 --- a/models/atm/cam/src/physics/clubb/advance_windm_edsclrm_module.F90 +++ b/models/atm/cam/src/physics/clubb/advance_windm_edsclrm_module.F90 @@ -1,5 +1,5 @@ !------------------------------------------------------------------------ -! $Id: advance_windm_edsclrm_module.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +! $Id: advance_windm_edsclrm_module.F90 7315 2014-09-30 20:49:54Z schemena@uwm.edu $ !=============================================================================== module advance_windm_edsclrm_module @@ -7,13 +7,13 @@ module advance_windm_edsclrm_module private ! Set Default Scope - public :: advance_windm_edsclrm + public :: advance_windm_edsclrm, xpwp_fnc private :: windm_edsclrm_solve, & compute_uv_tndcy, & windm_edsclrm_lhs, & - windm_edsclrm_rhs, & - xpwp_fnc + windm_edsclrm_rhs + ! Private named constants to avoid string comparisons integer, parameter, private :: & @@ -31,7 +31,7 @@ module advance_windm_edsclrm_module !============================================================================= subroutine advance_windm_edsclrm & - ( dt, wm_zt, Kh_zm, ug, vg, um_ref, vm_ref, & + ( dt, wm_zt, Km_zm, ug, vg, um_ref, vm_ref, & wp2, up2, vp2, um_forcing, vm_forcing, & edsclrm_forcing, & rho_ds_zm, invrs_rho_ds_zt, & @@ -69,10 +69,9 @@ subroutine advance_windm_edsclrm & l_tke_aniso use clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd + core_rknd ! Variable(s) - use stats_type, only: & + use stats_type_utilities, only: & stat_begin_update, & ! Subroutines stat_end_update, & stat_update_var @@ -85,7 +84,7 @@ subroutine advance_windm_edsclrm & ium_ndg, & ivm_ndg, & iwindm_matrix_condt_num, & - zt, & + stats_zt, & l_stats_samp use clip_explicit, only: & @@ -96,8 +95,7 @@ subroutine advance_windm_edsclrm & fatal_error use error_code, only: & - clubb_no_error, & ! Constant(s) - clubb_singular_matrix + clubb_no_error ! Constant(s) use constants_clubb, only: & fstderr, & ! Constant(s) @@ -118,23 +116,23 @@ subroutine advance_windm_edsclrm & dummy_nu ! Used to feed zero values into function calls ! Input Variables - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dt ! Model timestep [s] real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & - wm_zt, & ! w wind component on thermodynamic levels [m/s] - Kh_zm, & ! Eddy diffusivity on momentum levels [m^2/s] - ug, & ! u (west-to-east) geostrophic wind comp. [m/s] - vg, & ! v (south-to-north) geostrophic wind comp. [m/s] - um_ref, & ! Reference u wind component for nudging [m/s] - vm_ref, & ! Reference v wind component for nudging [m/s] - wp2, & ! w'^2 (momentum levels) [m^2/s^2] - up2, & ! u'^2 (momentum levels) [m^2/s^2] - vp2, & ! v'^2 (momentum levels) [m^2/s^2] - um_forcing, & ! u forcing [m/s/s] - vm_forcing, & ! v forcing [m/s/s] - rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] - invrs_rho_ds_zt ! Inv. dry, static density at thermo. levels [m^3/kg] + wm_zt, & ! w wind component on thermodynamic levels [m/s] + Km_zm, & ! Eddy diffusivity of winds on momentum levels [m^2/s] + ug, & ! u (west-to-east) geostrophic wind comp. [m/s] + vg, & ! v (south-to-north) geostrophic wind comp. [m/s] + um_ref, & ! Reference u wind component for nudging [m/s] + vm_ref, & ! Reference v wind component for nudging [m/s] + wp2, & ! w'^2 (momentum levels) [m^2/s^2] + up2, & ! u'^2 (momentum levels) [m^2/s^2] + vp2, & ! v'^2 (momentum levels) [m^2/s^2] + um_forcing, & ! u forcing [m/s/s] + vm_forcing, & ! v forcing [m/s/s] + rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] + invrs_rho_ds_zt ! Inv. dry, static density at thermo. levels [m^3/kg] real( kind = core_rknd ), dimension(gr%nz,edsclr_dim), intent(in) :: & edsclrm_forcing ! Eddy scalar large-scale forcing [{units vary}/s] @@ -192,9 +190,10 @@ subroutine advance_windm_edsclrm & l_imp_sfc_momentum_flux ! Flag for implicit momentum surface fluxes. integer :: & - err_code_windm, err_code_edsclrm ! Error code for each LAPACK solve + err_code_windm, err_code_edsclrm, & ! Error code for each LAPACK solve + nrhs ! Number of right hand side terms - integer :: i ! Array index + integer :: i ! Array index logical :: l_first_clip_ts, l_last_clip_ts ! flags for clip_covar @@ -231,17 +230,19 @@ subroutine advance_windm_edsclrm & ! Compute the explicit portion of the um equation. ! Build the right-hand side vector. - rhs(1:gr%nz,1) = windm_edsclrm_rhs( windm_edsclrm_um, dt, nu10_vert_res_dep, Kh_zm, um, & ! in - um_tndcy, & ! in - rho_ds_zm, invrs_rho_ds_zt, & ! in - l_imp_sfc_momentum_flux, upwp(1) ) ! in + rhs(1:gr%nz,windm_edsclrm_um) & + = windm_edsclrm_rhs( windm_edsclrm_um, dt, nu10_vert_res_dep, Km_zm, um, & ! in + um_tndcy, & ! in + rho_ds_zm, invrs_rho_ds_zt, & ! in + l_imp_sfc_momentum_flux, upwp(1) ) ! in ! Compute the explicit portion of the vm equation. ! Build the right-hand side vector. - rhs(1:gr%nz,2) = windm_edsclrm_rhs( windm_edsclrm_vm, dt, nu10_vert_res_dep, Kh_zm, vm, & ! in - vm_tndcy, & ! in - rho_ds_zm, invrs_rho_ds_zt, & ! in - l_imp_sfc_momentum_flux, vpwp(1) ) ! in + rhs(1:gr%nz,windm_edsclrm_vm) & + = windm_edsclrm_rhs( windm_edsclrm_vm, dt, nu10_vert_res_dep, Km_zm, vm, & ! in + vm_tndcy, & ! in + rho_ds_zm, invrs_rho_ds_zt, & ! in + l_imp_sfc_momentum_flux, vpwp(1) ) ! in ! Store momentum flux (explicit component) @@ -253,12 +254,12 @@ subroutine advance_windm_edsclrm & ! Solve for x'w' at all intermediate model levels. ! A Crank-Nicholson timestep is used. - upwp(2:gr%nz-1) = - 0.5_core_rknd * xpwp_fnc( Kh_zm(2:gr%nz-1)+ & + upwp(2:gr%nz-1) = - 0.5_core_rknd * xpwp_fnc( Km_zm(2:gr%nz-1)+ & nu10_vert_res_dep(2:gr%nz-1), & ! in um(2:gr%nz-1), um(3:gr%nz), & ! in gr%invrs_dzm(2:gr%nz-1) ) - vpwp(2:gr%nz-1) = - 0.5_core_rknd * xpwp_fnc( Kh_zm(2:gr%nz-1)+ & + vpwp(2:gr%nz-1) = - 0.5_core_rknd * xpwp_fnc( Km_zm(2:gr%nz-1)+ & nu10_vert_res_dep(2:gr%nz-1), & ! in vm(2:gr%nz-1), vm(3:gr%nz), & ! in gr%invrs_dzm(2:gr%nz-1) ) @@ -272,25 +273,26 @@ subroutine advance_windm_edsclrm & ! Compute the implicit portion of the um and vm equations. ! Build the left-hand side matrix. - call windm_edsclrm_lhs( dt, nu10_vert_res_dep, wm_zt, Kh_zm, wind_speed, u_star_sqd, & ! in + call windm_edsclrm_lhs( dt, nu10_vert_res_dep, wm_zt, Km_zm, wind_speed, u_star_sqd, & ! in rho_ds_zm, invrs_rho_ds_zt, & ! in l_implemented, l_imp_sfc_momentum_flux, & ! in lhs ) ! out ! Decompose and back substitute for um and vm - call windm_edsclrm_solve( 2, iwindm_matrix_condt_num, & ! in - lhs, rhs, & ! in/out - solution, err_code_windm ) ! out + nrhs = 2 + call windm_edsclrm_solve( nrhs, iwindm_matrix_condt_num, & ! in + lhs, rhs, & ! in/out + solution, err_code_windm ) ! out !---------------------------------------------------------------- ! Update zonal (west-to-east) component of mean wind, um !---------------------------------------------------------------- - um(1:gr%nz) = solution(1:gr%nz,1) + um(1:gr%nz) = solution(1:gr%nz,windm_edsclrm_um) !---------------------------------------------------------------- ! Update meridional (south-to-north) component of mean wind, vm !---------------------------------------------------------------- - vm(1:gr%nz) = solution(1:gr%nz,2) + vm(1:gr%nz) = solution(1:gr%nz,windm_edsclrm_vm) if ( l_stats_samp ) then @@ -313,8 +315,8 @@ subroutine advance_windm_edsclrm & if ( uv_sponge_damp_settings%l_sponge_damping ) then if( l_stats_samp ) then - call stat_begin_update( ium_sdmp, um/real( dt, kind = core_rknd ), zt ) - call stat_begin_update( ivm_sdmp, vm/real( dt, kind = core_rknd ), zt ) + call stat_begin_update( ium_sdmp, um/dt, stats_zt ) + call stat_begin_update( ivm_sdmp, vm/dt, stats_zt ) endif um(1:gr%nz) = sponge_damp_xm( dt, um_ref(1:gr%nz), um(1:gr%nz), & @@ -322,8 +324,8 @@ subroutine advance_windm_edsclrm & vm(1:gr%nz) = sponge_damp_xm( dt, vm_ref(1:gr%nz), vm(1:gr%nz), & uv_sponge_damp_profile ) if( l_stats_samp ) then - call stat_end_update( ium_sdmp, um/real( dt, kind = core_rknd ), zt ) - call stat_end_update( ivm_sdmp, vm/real( dt, kind = core_rknd ), zt ) + call stat_end_update( ium_sdmp, um/dt, stats_zt ) + call stat_end_update( ivm_sdmp, vm/dt, stats_zt ) endif endif @@ -334,11 +336,11 @@ subroutine advance_windm_edsclrm & ! A Crank-Nicholson timestep is used. upwp(2:gr%nz-1) = upwp(2:gr%nz-1) & - - 0.5_core_rknd * xpwp_fnc( Kh_zm(2:gr%nz-1)+nu10_vert_res_dep(2:gr%nz-1), & + - 0.5_core_rknd * xpwp_fnc( Km_zm(2:gr%nz-1)+nu10_vert_res_dep(2:gr%nz-1), & um(2:gr%nz-1), um(3:gr%nz), gr%invrs_dzm(2:gr%nz-1) ) !in vpwp(2:gr%nz-1) = vpwp(2:gr%nz-1) & - - 0.5_core_rknd * xpwp_fnc( Kh_zm(2:gr%nz-1)+nu10_vert_res_dep(2:gr%nz-1), & + - 0.5_core_rknd * xpwp_fnc( Km_zm(2:gr%nz-1)+nu10_vert_res_dep(2:gr%nz-1), & vm(2:gr%nz-1), vm(3:gr%nz), gr%invrs_dzm(2:gr%nz-1) ) !in @@ -347,30 +349,30 @@ subroutine advance_windm_edsclrm & ! Reflect nudging in budget if( l_stats_samp ) then - call stat_begin_update( ium_ndg, um / real( dt, kind = core_rknd ), & ! Intent(in) - zt ) ! Intent(inout) - call stat_begin_update( ivm_ndg, vm / real( dt, kind = core_rknd ), & ! Intent(in) - zt ) ! Intent(inout) + call stat_begin_update( ium_ndg, um / dt, & ! Intent(in) + stats_zt ) ! Intent(inout) + call stat_begin_update( ivm_ndg, vm / dt, & ! Intent(in) + stats_zt ) ! Intent(inout) end if um(1:gr%nz) = um(1:gr%nz) & - - ((um(1:gr%nz) - um_ref(1:gr%nz)) * (real( dt, kind = core_rknd )/ts_nudge)) + - ((um(1:gr%nz) - um_ref(1:gr%nz)) * (dt/ts_nudge)) vm(1:gr%nz) = vm(1:gr%nz) & - - ((vm(1:gr%nz) - vm_ref(1:gr%nz)) * (real( dt, kind = core_rknd )/ts_nudge)) + - ((vm(1:gr%nz) - vm_ref(1:gr%nz)) * (dt/ts_nudge)) endif if( l_stats_samp ) then ! Reflect nudging in budget if ( l_uv_nudge ) then - call stat_end_update( ium_ndg, um / real( dt, kind = core_rknd ), & ! Intent(in) - zt ) ! Intent(inout) - call stat_end_update( ivm_ndg, vm / real( dt, kind = core_rknd ), & ! Intent(in) - zt ) ! Intent(inout) + call stat_end_update( ium_ndg, um / dt, & ! Intent(in) + stats_zt ) ! Intent(inout) + call stat_end_update( ivm_ndg, vm / dt, & ! Intent(in) + stats_zt ) ! Intent(inout) end if - call stat_update_var( ium_ref, um_ref, zt ) - call stat_update_var( ivm_ref, vm_ref, zt ) + call stat_update_var( ium_ref, um_ref, stats_zt ) + call stat_update_var( ivm_ref, vm_ref, stats_zt ) end if if ( l_tke_aniso ) then @@ -444,7 +446,7 @@ subroutine advance_windm_edsclrm & !HPF$ INDEPENDENT do i = 1, edsclr_dim rhs(1:gr%nz,i) & - = windm_edsclrm_rhs( windm_edsclrm_scalar, dt, dummy_nu, Kh_zm, & ! in + = windm_edsclrm_rhs( windm_edsclrm_scalar, dt, dummy_nu, Km_zm, & ! in edsclrm(:,i), edsclrm_forcing, & ! in rho_ds_zm, invrs_rho_ds_zt, & ! in l_imp_sfc_momentum_flux, wpedsclrp(1,i) ) ! in @@ -463,7 +465,7 @@ subroutine advance_windm_edsclrm & !HPF$ INDEPENDENT, REDUCTION(wpedsclrp) forall( i = 1:edsclr_dim ) wpedsclrp(2:gr%nz-1,i) = & - - 0.5_core_rknd * xpwp_fnc( Kh_zm(2:gr%nz-1), edsclrm(2:gr%nz-1,i), & ! in + - 0.5_core_rknd * xpwp_fnc( Km_zm(2:gr%nz-1), edsclrm(2:gr%nz-1,i), & ! in edsclrm(3:gr%nz,i), gr%invrs_dzm(2:gr%nz-1) ) ! in end forall @@ -475,7 +477,7 @@ subroutine advance_windm_edsclrm & ! Compute the implicit portion of the xm (eddy-scalar) equations. ! Build the left-hand side matrix. - call windm_edsclrm_lhs( dt, dummy_nu, wm_zt, Kh_zm, wind_speed, u_star_sqd, & ! in + call windm_edsclrm_lhs( dt, dummy_nu, wm_zt, Km_zm, wind_speed, u_star_sqd, & ! in rho_ds_zm, invrs_rho_ds_zt, & ! in l_implemented, l_imp_sfc_momentum_flux, & ! in lhs ) ! out @@ -504,7 +506,7 @@ subroutine advance_windm_edsclrm & !HPF$ INDEPENDENT, REDUCTION(wpedsclrp) forall( i = 1:edsclr_dim ) wpedsclrp(2:gr%nz-1,i) = wpedsclrp(2:gr%nz-1,i) & - - 0.5_core_rknd * xpwp_fnc( Kh_zm(2:gr%nz-1), edsclrm(2:gr%nz-1,i), & ! in + - 0.5_core_rknd * xpwp_fnc( Km_zm(2:gr%nz-1), edsclrm(2:gr%nz-1,i), & ! in edsclrm(3:gr%nz,i), gr%invrs_dzm(2:gr%nz-1) ) ! in end forall @@ -539,7 +541,7 @@ subroutine advance_windm_edsclrm & write(fstderr,*) "dt = ", dt write(fstderr,*) "wm_zt = ", wm_zt - write(fstderr,*) "Kh_zm = ", Kh_zm + write(fstderr,*) "Km_zm = ", Km_zm write(fstderr,*) "ug = ", ug write(fstderr,*) "vg = ", vg write(fstderr,*) "um_ref = ", um_ref @@ -1082,15 +1084,12 @@ subroutine windm_edsclrm_solve( nrhs, ixm_matrix_condt_num, & tridag_solvex use stats_variables, only: & - sfc, & ! Variable(s) + stats_sfc, & ! Variable(s) l_stats_samp - use stats_type, only: & + use stats_type_utilities, only: & stat_update_var_pt ! Subroutine - use constants_clubb, only: & - fstderr ! Variable(s) - use clubb_precision, only: & core_rknd ! Variable(s) @@ -1106,8 +1105,7 @@ subroutine windm_edsclrm_solve( nrhs, ixm_matrix_condt_num, & ! Input Variables integer, intent(in) :: & - nrhs ! Number of right-hand side (explicit) vectors. - ! Number of solution vectors. + nrhs ! Number of right-hand side (explicit) vectors & Number of solution vectors. integer, intent(in) :: & ixm_matrix_condt_num ! Stats index of the condition numbers @@ -1131,16 +1129,16 @@ subroutine windm_edsclrm_solve( nrhs, ixm_matrix_condt_num, & ! Solve tridiagonal system for xm. if ( l_stats_samp .and. ixm_matrix_condt_num > 0 ) then call tridag_solvex & - ( "windm_edsclrm", gr%nz, nrhs, & ! Intent(in) + ( "windm_edsclrm", gr%nz, nrhs, & ! Intent(in) lhs(kp1_tdiag,:), lhs(k_tdiag,:), lhs(km1_tdiag,:), rhs, & ! Intent(inout) solution, rcond, err_code ) ! Intent(out) ! Est. of the condition number of the variance LHS matrix - call stat_update_var_pt( ixm_matrix_condt_num, 1, 1.0_core_rknd / rcond, & ! Intent(in) - sfc ) ! Intent(inout) + call stat_update_var_pt( ixm_matrix_condt_num, 1, 1.0_core_rknd/rcond, & ! Intent(in) + stats_sfc ) ! Intent(inout) else - call tridag_solve( "windm_edsclrm", gr%nz, nrhs, & ! In + call tridag_solve( "windm_edsclrm", gr%nz, nrhs, & ! In lhs(kp1_tdiag,:), lhs(k_tdiag,:), lhs(km1_tdiag,:), rhs, & ! Inout solution, err_code ) ! Out end if @@ -1169,17 +1167,13 @@ subroutine windm_edsclrm_implicit_stats( solve_type, xm ) ztscr04, & ztscr05, & ztscr06, & - zt + stats_zt - use stats_type, only: & + use stats_type_utilities, only: & stat_end_update_pt, & ! Subroutines stat_update_var_pt - use constants_clubb, only: & - fstderr ! Variable(s) - use clubb_precision, only: & - time_precision, & ! Variable(s) core_rknd use grid_class, only: & @@ -1228,7 +1222,7 @@ subroutine windm_edsclrm_implicit_stats( solve_type, xm ) call stat_update_var_pt( ixm_ma, k, & ztscr01(k) * xm(km1) & + ztscr02(k) * xm(k) & - + ztscr03(k) * xm(kp1), zt ) + + ztscr03(k) * xm(kp1), stats_zt ) ! xm turbulent transport (implicit component) ! xm term ta has both implicit and explicit components; @@ -1236,7 +1230,7 @@ subroutine windm_edsclrm_implicit_stats( solve_type, xm ) call stat_end_update_pt( ixm_ta, k, & ztscr04(k) * xm(km1) & + ztscr05(k) * xm(k) & - + ztscr06(k) * xm(kp1), zt ) + + ztscr06(k) * xm(kp1), stats_zt ) enddo @@ -1249,14 +1243,14 @@ subroutine windm_edsclrm_implicit_stats( solve_type, xm ) ! xm term ma is completely implicit; call stat_update_var_pt. call stat_update_var_pt( ixm_ma, k, & ztscr01(k) * xm(km1) & - + ztscr02(k) * xm(k), zt ) + + ztscr02(k) * xm(k), stats_zt ) ! xm turbulent transport (implicit component) ! xm term ta has both implicit and explicit components; ! call stat_end_update_pt. call stat_end_update_pt( ixm_ta, k, & ztscr04(k) * xm(km1) & - + ztscr05(k) * xm(k), zt ) + + ztscr05(k) * xm(k), stats_zt ) return @@ -1296,7 +1290,7 @@ subroutine compute_uv_tndcy( solve_type, fcor, perp_wind_m, perp_wind_g, xm_forc use grid_class, only: & gr - use stats_type, only: & + use stats_type_utilities, only: & stat_update_var use stats_variables, only: & @@ -1306,7 +1300,7 @@ subroutine compute_uv_tndcy( solve_type, fcor, perp_wind_m, perp_wind_g, xm_forc ivm_cf, & ium_f, & ivm_f, & - zt, & + stats_zt, & l_stats_samp use clubb_precision, only: & @@ -1390,13 +1384,13 @@ subroutine compute_uv_tndcy( solve_type, fcor, perp_wind_m, perp_wind_g, xm_forc if ( l_stats_samp ) then ! xm term gf is completely explicit; call stat_update_var. - call stat_update_var( ixm_gf, xm_gf, zt ) + call stat_update_var( ixm_gf, xm_gf, stats_zt ) ! xm term cf is completely explicit; call stat_update_var. - call stat_update_var( ixm_cf, xm_cf, zt ) + call stat_update_var( ixm_cf, xm_cf, stats_zt ) ! xm term F - call stat_update_var( ixm_f, xm_forcing, zt ) + call stat_update_var( ixm_f, xm_forcing, stats_zt ) endif else ! implemented in a host model. @@ -1410,7 +1404,7 @@ subroutine compute_uv_tndcy( solve_type, fcor, perp_wind_m, perp_wind_g, xm_forc end subroutine compute_uv_tndcy !=============================================================================== - subroutine windm_edsclrm_lhs( dt, nu, wm_zt, Kh_zm, wind_speed, u_star_sqd, & + subroutine windm_edsclrm_lhs( dt, nu, wm_zt, Km_zm, wind_speed, u_star_sqd, & rho_ds_zm, invrs_rho_ds_zt, & l_implemented, l_imp_sfc_momentum_flux, & lhs ) @@ -1428,8 +1422,7 @@ subroutine windm_edsclrm_lhs( dt, nu, wm_zt, Kh_zm, wind_speed, u_star_sqd, & gr ! Variable(s) use clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd + core_rknd ! Variable(s) use diffusion, only: & diffusion_zt_lhs ! Procedure(s) @@ -1459,7 +1452,7 @@ subroutine windm_edsclrm_lhs( dt, nu, wm_zt, Kh_zm, wind_speed, u_star_sqd, & km1_tdiag = 3 ! Thermodynamic subdiagonal index. ! Input Variables - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dt ! Model timestep [s] real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & @@ -1467,7 +1460,7 @@ subroutine windm_edsclrm_lhs( dt, nu, wm_zt, Kh_zm, wind_speed, u_star_sqd, & real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & wm_zt, & ! w wind component on thermodynamic levels [m/s] - Kh_zm, & ! Eddy diffusivity on momentum levels [m^2/s] + Km_zm, & ! Eddy diffusivity on momentum levels [m^2/s] wind_speed, & ! wind speed; sqrt( u^2 + v^2 ) [m/s] rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] invrs_rho_ds_zt ! Inv. dry, static density at thermo. levels [m^3/kg] @@ -1491,7 +1484,7 @@ subroutine windm_edsclrm_lhs( dt, nu, wm_zt, Kh_zm, wind_speed, u_star_sqd, & ! --- Begin Code --- - ! Initialize the LHS array. + ! Initialize the LHS array to zero. lhs = 0.0_core_rknd do k = 2, gr%nz, 1 @@ -1507,7 +1500,7 @@ subroutine windm_edsclrm_lhs( dt, nu, wm_zt, Kh_zm, wind_speed, u_star_sqd, & + term_ma_zt_lhs( wm_zt(k), gr%invrs_dzt(k), k, gr%invrs_dzm(k), gr%invrs_dzm(km1) ) else - + ! The host model is assumed to apply the advection term to the mean elsewhere in this case. lhs(kp1_tdiag:km1_tdiag,k) & = lhs(kp1_tdiag:km1_tdiag,k) + 0.0_core_rknd @@ -1531,18 +1524,19 @@ subroutine windm_edsclrm_lhs( dt, nu, wm_zt, Kh_zm, wind_speed, u_star_sqd, & lhs(kp1_tdiag:km1_tdiag,k) & = lhs(kp1_tdiag:km1_tdiag,k) & + 0.5_core_rknd * invrs_rho_ds_zt(k) & - * diffusion_zt_lhs( rho_ds_zm(k) * Kh_zm(k), & - rho_ds_zm(km1) * Kh_zm(km1), nu, & + * diffusion_zt_lhs( rho_ds_zm(k) * Km_zm(k), & + rho_ds_zm(km1) * Km_zm(km1), nu, & gr%invrs_dzm(km1), gr%invrs_dzm(k), & gr%invrs_dzt(k), diff_k_in ) ! LHS time tendency. lhs(k_tdiag,k) & - = lhs(k_tdiag,k) + 1.0_core_rknd / real( dt, kind = core_rknd ) + = lhs(k_tdiag,k) + 1.0_core_rknd / dt if ( l_stats_samp ) then ! Statistics: implicit contributions for um or vm. + ! Note: we don't track these budgets for the eddy scalar variables if ( ium_ma + ivm_ma > 0 ) then if ( .not. l_implemented ) then @@ -1561,8 +1555,8 @@ subroutine windm_edsclrm_lhs( dt, nu, wm_zt, Kh_zm, wind_speed, u_star_sqd, & if ( ium_ta + ivm_ta > 0 ) then tmp(1:3) & = 0.5_core_rknd * invrs_rho_ds_zt(k) & - * diffusion_zt_lhs( rho_ds_zm(k) * Kh_zm(k), & - rho_ds_zm(km1) * Kh_zm(km1), nu, & + * diffusion_zt_lhs( rho_ds_zm(k) * Km_zm(k), & + rho_ds_zm(km1) * Km_zm(km1), nu, & gr%invrs_dzm(km1), gr%invrs_dzm(k), & gr%invrs_dzt(k), diff_k_in ) ztscr04(k) = -tmp(3) @@ -1625,7 +1619,7 @@ subroutine windm_edsclrm_lhs( dt, nu, wm_zt, Kh_zm, wind_speed, u_star_sqd, & end subroutine windm_edsclrm_lhs !============================================================================= - function windm_edsclrm_rhs( solve_type, dt, nu, Kh_zm, xm, xm_tndcy, & + function windm_edsclrm_rhs( solve_type, dt, nu, Km_zm, xm, xm_tndcy, & rho_ds_zm, invrs_rho_ds_zt, & l_imp_sfc_momentum_flux, xpwp_sfc ) & result( rhs ) @@ -1640,8 +1634,7 @@ function windm_edsclrm_rhs( solve_type, dt, nu, Kh_zm, xm, xm_tndcy, & !----------------------------------------------------------------------- use clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd + core_rknd ! Variable(s) use diffusion, only: & diffusion_zt_lhs ! Procedure(s) @@ -1649,10 +1642,10 @@ function windm_edsclrm_rhs( solve_type, dt, nu, Kh_zm, xm, xm_tndcy, & use stats_variables, only: & ium_ta, & ! Variable(s) ivm_ta, & - zt, & + stats_zt, & l_stats_samp - use stats_type, only: & + use stats_type_utilities, only: & stat_begin_update_pt, & ! Procedure(s) stat_modify_pt @@ -1668,14 +1661,14 @@ function windm_edsclrm_rhs( solve_type, dt, nu, Kh_zm, xm, xm_tndcy, & integer, intent(in) :: & solve_type ! Description of what is being solved for - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dt ! Model timestep [s] real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & nu ! Background constant coef. of eddy diffusivity [m^2/s] real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & - Kh_zm, & ! Eddy diffusivity on momentum levels [m^2/s] + Km_zm, & ! Eddy diffusivity on momentum levels [m^2/s] xm, & ! Eddy-scalar variable, xm (thermo. levels) [units vary] xm_tndcy, & ! The explicit time-tendency acting on xm [units vary] rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] @@ -1738,8 +1731,8 @@ function windm_edsclrm_rhs( solve_type, dt, nu, Kh_zm, xm, xm_tndcy, & endif rhs_diff(1:3) & = 0.5_core_rknd * invrs_rho_ds_zt(k) & - * diffusion_zt_lhs( rho_ds_zm(k) * Kh_zm(k), & - rho_ds_zm(km1) * Kh_zm(km1), nu, & + * diffusion_zt_lhs( rho_ds_zm(k) * Km_zm(k), & + rho_ds_zm(km1) * Km_zm(km1), nu, & gr%invrs_dzm(km1), gr%invrs_dzm(k), & gr%invrs_dzt(k), diff_k_in ) rhs(k) = rhs(k) & @@ -1751,7 +1744,7 @@ function windm_edsclrm_rhs( solve_type, dt, nu, Kh_zm, xm, xm_tndcy, & rhs(k) = rhs(k) + xm_tndcy(k) ! RHS time tendency - rhs(k) = rhs(k) + 1.0_core_rknd / real ( dt, kind = core_rknd ) * xm(k) + rhs(k) = rhs(k) + 1.0_core_rknd / dt * xm(k) if ( l_stats_samp ) then @@ -1765,7 +1758,7 @@ function windm_edsclrm_rhs( solve_type, dt, nu, Kh_zm, xm, xm_tndcy, & call stat_begin_update_pt( ixm_ta, k, & rhs_diff(3) * xm(km1) & + rhs_diff(2) * xm(k) & - + rhs_diff(1) * xm(kp1), zt ) + + rhs_diff(1) * xm(kp1), stats_zt ) endif endif ! l_stats_samp @@ -1811,7 +1804,7 @@ function windm_edsclrm_rhs( solve_type, dt, nu, Kh_zm, xm, xm_tndcy, & + invrs_rho_ds_zt(2) & * gr%invrs_dzt(2) & * rho_ds_zm(1) * xpwp_sfc, & - zt ) + stats_zt ) endif endif ! l_stats_samp @@ -1831,8 +1824,8 @@ function windm_edsclrm_rhs( solve_type, dt, nu, Kh_zm, xm, xm_tndcy, & ! upper boundary. rhs_diff(1:3) & = 0.5_core_rknd * invrs_rho_ds_zt(k) & - * diffusion_zt_lhs( rho_ds_zm(k) * Kh_zm(k), & - rho_ds_zm(km1) * Kh_zm(km1), nu, & + * diffusion_zt_lhs( rho_ds_zm(k) * Km_zm(k), & + rho_ds_zm(km1) * Km_zm(km1), nu, & gr%invrs_dzm(km1), gr%invrs_dzm(k), & gr%invrs_dzt(k), k ) rhs(k) = rhs(k) & @@ -1843,7 +1836,7 @@ function windm_edsclrm_rhs( solve_type, dt, nu, Kh_zm, xm, xm_tndcy, & rhs(k) = rhs(k) + xm_tndcy(k) ! RHS time tendency term at the upper boundary. - rhs(k) = rhs(k) + 1.0_core_rknd / real( dt, kind = core_rknd ) * xm(k) + rhs(k) = rhs(k) + 1.0_core_rknd / dt * xm(k) if ( l_stats_samp ) then @@ -1856,7 +1849,7 @@ function windm_edsclrm_rhs( solve_type, dt, nu, Kh_zm, xm, xm_tndcy, & if ( ixm_ta > 0 ) then call stat_begin_update_pt( ixm_ta, k, & rhs_diff(3) * xm(km1) & - + rhs_diff(2) * xm(k), zt ) + + rhs_diff(2) * xm(k), stats_zt ) endif endif ! l_stats_samp @@ -1866,7 +1859,7 @@ function windm_edsclrm_rhs( solve_type, dt, nu, Kh_zm, xm, xm_tndcy, & end function windm_edsclrm_rhs !=============================================================================== - elemental function xpwp_fnc( Kh_zm, xm, xmp1, invrs_dzm ) + elemental function xpwp_fnc( Km_zm, xm, xmp1, invrs_dzm ) ! Description: ! Compute x'w' from x, x, Kh and invrs_dzm @@ -1882,7 +1875,7 @@ elemental function xpwp_fnc( Kh_zm, xm, xmp1, invrs_dzm ) ! Input variables real( kind = core_rknd ), intent(in) :: & - Kh_zm, & ! Eddy diff. (k momentum level) [m^2/s] + Km_zm, & ! Eddy diff. (k momentum level) [m^2/s] xm, & ! x (k thermo level) [units vary] xmp1, & ! x (k+1 thermo level) [units vary] invrs_dzm ! Inverse of the grid spacing (k thermo level) [1/m] @@ -1895,7 +1888,7 @@ elemental function xpwp_fnc( Kh_zm, xm, xmp1, invrs_dzm ) ! --- Begin Code --- ! Solve for x'w' at all intermediate model levels. - xpwp_fnc = Kh_zm * invrs_dzm * ( xmp1 - xm ) + xpwp_fnc = Km_zm * invrs_dzm * ( xmp1 - xm ) return end function xpwp_fnc diff --git a/models/atm/cam/src/physics/clubb/advance_wp2_wp3_module.F90 b/models/atm/cam/src/physics/clubb/advance_wp2_wp3_module.F90 index 46f5073f332c..2d55d44266c5 100644 --- a/models/atm/cam/src/physics/clubb/advance_wp2_wp3_module.F90 +++ b/models/atm/cam/src/physics/clubb/advance_wp2_wp3_module.F90 @@ -1,5 +1,5 @@ !------------------------------------------------------------------------ -! $Id: advance_wp2_wp3_module.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +! $Id: advance_wp2_wp3_module.F90 7380 2014-11-11 20:34:25Z schemena@uwm.edu $ !=============================================================================== module advance_wp2_wp3_module @@ -41,9 +41,9 @@ module advance_wp2_wp3_module subroutine advance_wp2_wp3( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & a3, a3_zt, wp3_on_wp2, & wpthvp, wp2thvp, um, vm, upwp, vpwp, & - up2, vp2, Kh_zm, Kh_zt, tau_zm, tau_zt, & + up2, vp2, Kh_zm, Kh_zt, tau_zm, tau_zt, tau_C1_zm, & Skw_zm, Skw_zt, rho_ds_zm, rho_ds_zt, & - invrs_rho_ds_zm, invrs_rho_ds_zt, & + invrs_rho_ds_zm, invrs_rho_ds_zt, radf, & thv_ds_zm, thv_ds_zt, mixt_frac, & wp2, wp3, wp3_zm, wp2_zt, err_code ) @@ -76,36 +76,35 @@ subroutine advance_wp2_wp3( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & c_K1, & c_K8 - use stats_type, only: & + use stats_type_utilities, only: & stat_update_var use stats_variables, only: & iC1_Skw_fnc, & iC11_Skw_fnc, & - zm, & - zt, & + stats_zm, & + stats_zt, & l_stats_samp use constants_clubb, only: & fstderr ! Variable(s) - use model_flags, only: & - l_hyper_dfsn ! Variable(s) - use clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd + core_rknd ! Variable(s) use error_code, only: & fatal_error, & ! Procedure(s) clubb_at_least_debug_level + use error_code, only: & + clubb_var_out_of_range ! Constant(s) + implicit none intrinsic :: exp ! Input Variables - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dt ! Model timestep [s] real( kind = core_rknd ), intent(in) :: & @@ -130,12 +129,14 @@ subroutine advance_wp2_wp3( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & Kh_zt, & ! Eddy diffusivity on thermodynamic levels [m^2/s] tau_zm, & ! Time-scale tau on momentum levels [s] tau_zt, & ! Time-scale tau on thermodynamic levels [s] + tau_C1_zm, & ! Tau values used for the C1 (dp1) term in wp2 [s] Skw_zm, & ! Skewness of w on momentum levels [-] Skw_zt, & ! Skewness of w on thermodynamic levels [-] rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] rho_ds_zt, & ! Dry, static density on thermo. levels [kg/m^3] invrs_rho_ds_zm, & ! Inv. dry, static density @ momentum levs. [m^3/kg] invrs_rho_ds_zt, & ! Inv. dry, static density @ thermo. levs. [m^3/kg] + radf, & ! Buoyancy production at the CL top [m^2/s^3] thv_ds_zm, & ! Dry, base-state theta_v on momentum levs. [K] thv_ds_zt, & ! Dry, base-state theta_v on thermo. levs. [K] mixt_frac ! Weight of 1st normal distribution [-] @@ -216,10 +217,6 @@ subroutine advance_wp2_wp3( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & C11_Skw_fnc(1:gr%nz) = C11b end if -#ifdef CLUBB_CAM - C11_Skw_fnc(1:gr%nz) = 0.65_core_rknd -#endif - ! The if..then here is only for computational efficiency -dschanen 2 Sept 08 if ( C1 /= C1b ) then C1_Skw_fnc(1:gr%nz) = & @@ -231,9 +228,18 @@ subroutine advance_wp2_wp3( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & !C11_Skw_fnc = C11 !C1_Skw_fnc = C1 + if ( clubb_at_least_debug_level( 2 ) ) then + ! Assertion check for C11_Skw_fnc + if ( any( C11_Skw_fnc(:) > 1._core_rknd ) .or. any( C11_Skw_fnc(:) < 0._core_rknd ) ) then + write(fstderr,*) "The C11_Skw_fnc is outside the valid range for this variable" + err_code = clubb_var_out_of_range + return + end if + end if + if ( l_stats_samp ) then - call stat_update_var( iC11_Skw_fnc, C11_Skw_fnc, zt ) - call stat_update_var( iC1_Skw_fnc, C1_Skw_fnc, zm ) + call stat_update_var( iC11_Skw_fnc, C11_Skw_fnc, stats_zt ) + call stat_update_var( iC1_Skw_fnc, C1_Skw_fnc, stats_zm ) endif ! Define the Coefficent of Eddy Diffusivity for the wp2 and wp3. @@ -252,26 +258,19 @@ subroutine advance_wp2_wp3( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & enddo - ! Declare the number of subdiagonals and superdiagonals in the LHS matrix. - if ( l_hyper_dfsn ) then - ! There are nine overall diagonals (including four subdiagonals - ! and four superdiagonals). - nsub = 4 - nsup = 4 - else - ! There are five overall diagonals (including two subdiagonals - ! and two superdiagonals). - nsub = 2 - nsup = 2 - endif + ! There are five overall diagonals (including two subdiagonals + ! and two superdiagonals). + nsub = 2 + nsup = 2 + ! Solve semi-implicitly call wp23_solve( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & ! Intent(in) a3, a3_zt, wp3_on_wp2, & ! Intent(in) wpthvp, wp2thvp, um, vm, upwp, vpwp, & ! Intent(in) - up2, vp2, Kw1, Kw8, Kh_zt, Skw_zt, tau_zm, tauw3t, & ! Intent(in) + up2, vp2, Kw1, Kw8, Kh_zt, Skw_zt, tau_zm, tauw3t, tau_C1_zm, & ! Intent(in) C1_Skw_fnc, C11_Skw_fnc, rho_ds_zm, rho_ds_zt, & ! Intent(in) - invrs_rho_ds_zm, invrs_rho_ds_zt, thv_ds_zm, & ! Intent(in) + invrs_rho_ds_zm, invrs_rho_ds_zt, radf, thv_ds_zm, & ! Intent(in) thv_ds_zt, nsub, nsup, & ! Intent(in) wp2, wp3, wp3_zm, wp2_zt, wp2_wp3_err_code ) ! Intent(inout) @@ -324,9 +323,9 @@ end subroutine advance_wp2_wp3 subroutine wp23_solve( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & a3, a3_zt, wp3_on_wp2, & wpthvp, wp2thvp, um, vm, upwp, vpwp, & - up2, vp2, Kw1, Kw8, Kh_zt, Skw_zt, tau1m, tauw3t, & + up2, vp2, Kw1, Kw8, Kh_zt, Skw_zt, tau1m, tauw3t, tau_C1_zm, & C1_Skw_fnc, C11_Skw_fnc, rho_ds_zm, rho_ds_zt, & - invrs_rho_ds_zm, invrs_rho_ds_zt, thv_ds_zm, & + invrs_rho_ds_zm, invrs_rho_ds_zt, radf, thv_ds_zm, & thv_ds_zt, nsub, nsup, & wp2, wp3, wp3_zm, wp2_zt, err_code ) @@ -347,41 +346,37 @@ subroutine wp23_solve( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & use constants_clubb, only: & w_tol_sqd, & ! Variables(s) - eps, & - zero_threshold, & - fstderr + zero_threshold use model_flags, only: & l_tke_aniso, & ! Variable(s) - l_hyper_dfsn, & l_hole_fill, & l_gmres use clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd + core_rknd ! Variable(s) use lapack_wrap, only: & band_solve, & ! Procedure(s) band_solvex use fill_holes, only: & - fill_holes_driver + fill_holes_vertical use clip_explicit, only: & clip_variance, & ! Procedure(s) clip_skewness - use stats_type, only: & + use stats_type_utilities, only: & stat_begin_update, & ! Procedure(s) stat_update_var_pt, & stat_end_update, & stat_end_update_pt use stats_variables, only: & - zm, & ! Variable(s) - zt, & - sfc, & + stats_zm, & ! Variable(s) + stats_zt, & + stats_sfc, & l_stats_samp, & iwp2_ta, & iwp2_ma, & @@ -391,7 +386,6 @@ subroutine wp23_solve( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & iwp2_dp2, & iwp2_pr1, & iwp2_pr2, & - iwp2_4hd, & iwp3_ta, & iwp3_ma, & iwp3_tp, & @@ -399,7 +393,6 @@ subroutine wp23_solve( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & iwp3_dp1, & iwp3_pr1, & iwp3_pr2, & - iwp3_4hd, & iwp23_matrix_condt_num use stats_variables, only: & @@ -415,13 +408,10 @@ subroutine wp23_solve( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & zmscr10, & zmscr11, & zmscr12, & - zmscr13, & - zmscr14, & - zmscr15, & - zmscr16, & - zmscr17, & ztscr01, & - ztscr02, & + ztscr02 + + use stats_variables, only: & ztscr03, & ztscr04, & ztscr05, & @@ -435,12 +425,7 @@ subroutine wp23_solve( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & ztscr13, & ztscr14, & ztscr15, & - ztscr16, & - ztscr17, & - ztscr18, & - ztscr19, & - ztscr20, & - ztscr21 + ztscr16 implicit none @@ -452,7 +437,7 @@ subroutine wp23_solve( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & nrhs = 1 ! Number of RHS vectors ! Input Variables - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dt ! Timestep [s] real( kind = core_rknd ), intent(in) :: & @@ -479,12 +464,14 @@ subroutine wp23_solve( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & Skw_zt, & ! Skewness of w on thermodynamic levels [-] tau1m, & ! Time-scale tau on momentum levels [s] tauw3t, & ! Time-scale tau on thermodynamic levels [s] + tau_C1_zm, & ! Tau values used for the C1 (dp1) term in wp2 [s] C1_Skw_fnc, & ! C_1 parameter with Sk_w applied [-] C11_Skw_fnc, & ! C_11 parameter with Sk_w applied [-] rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] rho_ds_zt, & ! Dry, static density on thermo. levels [kg/m^3] invrs_rho_ds_zm, & ! Inv. dry, static density @ momentum levs. [m^3/kg] invrs_rho_ds_zt, & ! Inv. dry, static density @ thermo. levs. [m^3/kg] + radf, & ! Buoyancy production at CL top [m^2/s^3] thv_ds_zm, & ! Dry, base-state theta_v on momentum levs. [K] thv_ds_zt ! Dry, base-state theta_v on thermo. levs. [K] @@ -525,7 +512,7 @@ subroutine wp23_solve( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & rcond ! Est. of the reciprocal of the condition # ! Array indices - integer :: k, km1, km2, kp1, kp2, k_wp2, k_wp3 + integer :: k, km1, kp1, k_wp2, k_wp3 ! Set logical to true for Crank-Nicholson diffusion scheme ! or to false for completely implicit diffusion scheme. @@ -552,15 +539,15 @@ subroutine wp23_solve( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & call wp23_rhs( dt, wp2, wp3, a1, a1_zt, & a3, a3_zt, wp3_on_wp2, wpthvp, wp2thvp, um, vm, & upwp, vpwp, up2, vp2, Kw1, Kw8, Kh_zt, & - Skw_zt, tau1m, tauw3t, C1_Skw_fnc, & - C11_Skw_fnc, rho_ds_zm, invrs_rho_ds_zt, & + Skw_zt, tau1m, tauw3t, tau_C1_zm, C1_Skw_fnc, & + C11_Skw_fnc, rho_ds_zm, invrs_rho_ds_zt, radf, & thv_ds_zm, thv_ds_zt, l_crank_nich_diff, & rhs ) if (l_gmres) then call wp23_gmres( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & wp3_on_wp2, & - Kw1, Kw8, Skw_zt, tau1m, tauw3t, C1_Skw_fnc, & + Kw1, Kw8, Skw_zt, tau1m, tauw3t, tau_C1_zm, C1_Skw_fnc, & C11_Skw_fnc, rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & invrs_rho_ds_zt, l_crank_nich_diff, nsup, nsub, nrhs, & rhs, & @@ -570,7 +557,7 @@ subroutine wp23_solve( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & ! Build the left-hand side matrix. call wp23_lhs( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & wp3_on_wp2, & - Kw1, Kw8, Skw_zt, tau1m, tauw3t, C1_Skw_fnc, & + Kw1, Kw8, Skw_zt, tau1m, tauw3t, tau_C1_zm, C1_Skw_fnc, & C11_Skw_fnc, rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & invrs_rho_ds_zt, l_crank_nich_diff, nsub, nsup, & lhs ) @@ -584,7 +571,7 @@ subroutine wp23_solve( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & lhs, rhs, solut, rcond, err_code ) ! Est. of the condition number of the w'^2/w^3 LHS matrix - call stat_update_var_pt( iwp23_matrix_condt_num, 1, 1.0_core_rknd / rcond, sfc ) + call stat_update_var_pt( iwp23_matrix_condt_num, 1, 1.0_core_rknd / rcond, stats_sfc ) else ! Perform LU decomp and solve system (LAPACK) @@ -611,21 +598,19 @@ subroutine wp23_solve( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & end do - if (l_stats_samp) then + if ( l_stats_samp ) then ! Finalize implicit contributions for wp2 do k = 2, gr%nz-1 km1 = max( k-1, 1 ) - km2 = max( k-2, 1 ) kp1 = min( k+1, gr%nz ) - kp2 = min( k+2, gr%nz ) ! w'^2 term dp1 has both implicit and explicit components; ! call stat_end_update_pt. call stat_end_update_pt( iwp2_dp1, k, & - zmscr01(k) * wp2(k), zm ) + zmscr01(k) * wp2(k), stats_zm ) ! w'^2 term dp2 has both implicit and explicit components (if the ! Crank-Nicholson scheme is selected); call stat_end_update_pt. @@ -635,50 +620,41 @@ subroutine wp23_solve( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & call stat_end_update_pt( iwp2_dp2, k, & zmscr02(k) * wp2(km1) & + zmscr03(k) * wp2(k) & - + zmscr04(k) * wp2(kp1), zm ) + + zmscr04(k) * wp2(kp1), stats_zm ) else call stat_update_var_pt( iwp2_dp2, k, & zmscr02(k) * wp2(km1) & + zmscr03(k) * wp2(k) & - + zmscr04(k) * wp2(kp1), zm ) + + zmscr04(k) * wp2(kp1), stats_zm ) endif ! w'^2 term ta is completely implicit; call stat_update_var_pt. call stat_update_var_pt( iwp2_ta, k, & zmscr05(k) * wp3(k) & - + zmscr06(k) * wp3(kp1), zm ) + + zmscr06(k) * wp3(kp1), stats_zm ) ! w'^2 term ma is completely implicit; call stat_update_var_pt. call stat_update_var_pt( iwp2_ma, k, & zmscr07(k) * wp2(km1) & + zmscr08(k) * wp2(k) & - + zmscr09(k) * wp2(kp1), zm ) + + zmscr09(k) * wp2(kp1), stats_zm ) ! w'^2 term ac is completely implicit; call stat_update_var_pt. call stat_update_var_pt( iwp2_ac, k, & - zmscr10(k) * wp2(k), zm ) + zmscr10(k) * wp2(k), stats_zm ) ! w'^2 term pr1 has both implicit and explicit components; ! call stat_end_update_pt. if ( l_tke_aniso ) then call stat_end_update_pt( iwp2_pr1, k, & - zmscr12(k) * wp2(k), zm ) + zmscr12(k) * wp2(k), stats_zm ) endif ! w'^2 term pr2 has both implicit and explicit components; ! call stat_end_update_pt. call stat_end_update_pt( iwp2_pr2, k, & - zmscr11(k) * wp2(k), zm ) - - ! w'^2 term 4hd is completely implicit; call stat_update_var_pt. - if ( l_hyper_dfsn ) then - call stat_update_var_pt( iwp2_4hd, k, & - zmscr13(k) * wp2(km2) & - + zmscr14(k) * wp2(km1) & - + zmscr15(k) * wp2(k) & - + zmscr16(k) * wp2(kp1) & - + zmscr17(k) * wp2(kp2), zm ) - endif + zmscr11(k) * wp2(k), stats_zm ) + enddo ! Finalize implicit contributions for wp3 @@ -686,14 +662,12 @@ subroutine wp23_solve( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & do k = 2, gr%nz-1, 1 km1 = max( k-1, 1 ) - km2 = max( k-2, 1 ) kp1 = min( k+1, gr%nz ) - kp2 = min( k+2, gr%nz ) ! w'^3 term pr1 has both implicit and explicit components; ! call stat_end_update_pt. call stat_end_update_pt( iwp3_pr1, k, & - ztscr01(k) * wp3(k), zt ) + ztscr01(k) * wp3(k), stats_zt ) ! w'^3 term dp1 has both implicit and explicit components (if the ! Crank-Nicholson scheme is selected); call stat_end_update_pt. @@ -703,12 +677,12 @@ subroutine wp23_solve( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & call stat_end_update_pt( iwp3_dp1, k, & ztscr02(k) * wp3(km1) & + ztscr03(k) * wp3(k) & - + ztscr04(k) * wp3(kp1), zt ) + + ztscr04(k) * wp3(kp1), stats_zt ) else call stat_update_var_pt( iwp3_dp1, k, & ztscr02(k) * wp3(km1) & + ztscr03(k) * wp3(k) & - + ztscr04(k) * wp3(kp1), zt ) + + ztscr04(k) * wp3(kp1), stats_zt ) endif ! w'^3 term ta has both implicit and explicit components; @@ -718,38 +692,29 @@ subroutine wp23_solve( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & + ztscr06(k) * wp2(km1) & + ztscr07(k) * wp3(k) & + ztscr08(k) * wp2(k) & - + ztscr09(k) * wp3(kp1), zt ) + + ztscr09(k) * wp3(kp1), stats_zt ) ! w'^3 term tp has both implicit and explicit components; ! call stat_end_update_pt. call stat_end_update_pt( iwp3_tp, k, & ztscr10(k) * wp2(km1) & - + ztscr11(k) * wp2(k), zt ) + + ztscr11(k) * wp2(k), stats_zt ) ! w'^3 term ma is completely implicit; call stat_update_var_pt. call stat_update_var_pt( iwp3_ma, k, & ztscr12(k) * wp3(km1) & + ztscr13(k) * wp3(k) & - + ztscr14(k) * wp3(kp1), zt ) + + ztscr14(k) * wp3(kp1), stats_zt ) ! w'^3 term ac is completely implicit; call stat_update_var_pt. call stat_update_var_pt( iwp3_ac, k, & - ztscr15(k) * wp3(k), zt ) + ztscr15(k) * wp3(k), stats_zt ) ! w'^3 term pr2 has both implicit and explicit components; ! call stat_end_update_pt. call stat_end_update_pt( iwp3_pr2, k, & - ztscr16(k) * wp3(k), zt ) - - ! w'^3 term 4hd is completely implicit; call stat_update_var_pt. - if ( l_hyper_dfsn ) then - call stat_update_var_pt( iwp3_4hd, k, & - ztscr17(k) * wp3(km2) & - + ztscr18(k) * wp3(km1) & - + ztscr19(k) * wp3(k) & - + ztscr20(k) * wp3(kp1) & - + ztscr21(k) * wp3(kp2), zt ) - endif + ztscr16(k) * wp3(k), stats_zt ) + enddo endif ! l_stats_samp @@ -757,15 +722,15 @@ subroutine wp23_solve( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & if ( l_stats_samp ) then ! Store previous value for effect of the positive definite scheme - call stat_begin_update( iwp2_pd, wp2 / real( dt, kind = core_rknd ), zm ) + call stat_begin_update( iwp2_pd, wp2 / dt, stats_zm ) endif if ( l_hole_fill .and. any( wp2 < w_tol_sqd ) ) then ! Use a simple hole filling algorithm - call fill_holes_driver( 2, w_tol_sqd, "zm", & - rho_ds_zt, rho_ds_zm, & - wp2 ) + call fill_holes_vertical( 2, w_tol_sqd, "zm", & + rho_ds_zt, rho_ds_zm, & + wp2 ) endif ! wp2 @@ -777,7 +742,7 @@ subroutine wp23_solve( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & if ( l_stats_samp ) then ! Store updated value for effect of the positive definite scheme - call stat_end_update( iwp2_pd, wp2 / real( dt, kind = core_rknd ), zm ) + call stat_end_update( iwp2_pd, wp2 / dt, stats_zm ) endif @@ -800,7 +765,7 @@ end subroutine wp23_solve subroutine wp23_gmres( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & wp3_on_wp2, & - Kw1, Kw8, Skw_zt, tau1m, tauw3t, C1_Skw_fnc, & + Kw1, Kw8, Skw_zt, tau1m, tauw3t, tau_C1_zm, C1_Skw_fnc, & C11_Skw_fnc, rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & invrs_rho_ds_zt, l_crank_nich_diff, nsup, nsub, nrhs, & rhs, & @@ -817,8 +782,7 @@ subroutine wp23_gmres( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & gr ! Variable(s) use clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd + core_rknd ! Variable(s) #ifdef MKL use error_code, only: & @@ -827,7 +791,7 @@ subroutine wp23_gmres( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & use stats_variables, only: & iwp23_matrix_condt_num, & ! Variable(s) l_stats_samp, & - sfc + stats_sfc use constants_clubb, only: & fstderr ! Variable(s) @@ -836,10 +800,10 @@ subroutine wp23_gmres( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & band_solve, & ! Procedure(s) band_solvex - use stats_type, only: & + use stats_type_utilities, only: & stat_update_var_pt ! Procedure(s) - use csr_matrix_class, only: & + use csr_matrix_module, only: & csr_intlc_5b_5b_ia, & ! Variables csr_intlc_5b_5b_ja, & intlc_5d_5d_ja_size @@ -860,7 +824,7 @@ subroutine wp23_gmres( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & implicit none ! Input Variables - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dt ! Timestep [s] real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & @@ -879,6 +843,7 @@ subroutine wp23_gmres( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & Skw_zt, & ! Skewness of w on thermodynamic levels [-] tau1m, & ! Time-scale tau on momentum levels [s] tauw3t, & ! Time-scale tau on thermodynamic levels [s] + tau_C1_zm, & ! Tau values used for the C1 (dp1) term in wp2 [s] C1_Skw_fnc, & ! C_1 parameter with Sk_w applied [-] C11_Skw_fnc, & ! C_11 parameter with Sk_w applied [-] rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] @@ -922,14 +887,9 @@ subroutine wp23_gmres( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & ! Begin code - if (nsup > 2) then - write (fstderr, *) "WARNING: CSR-format solvers currently do not", & - "support solving with hyper diffusion", & - "at this time. l_hyper_dfsn ignored." - end if call wp23_lhs_csr( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & wp3_on_wp2, & - Kw1, Kw8, Skw_zt, tau1m, tauw3t, C1_Skw_fnc, & + Kw1, Kw8, Skw_zt, tau1m, tauw3t, tau_C1_zm, C1_Skw_fnc, & C11_Skw_fnc, rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & invrs_rho_ds_zt, l_crank_nich_diff, & lhs_a_csr ) @@ -937,7 +897,7 @@ subroutine wp23_gmres( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & if ( .not. l_gmres_soln_ok(gmres_idx_wp2wp3) ) then call wp23_lhs( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & wp3_on_wp2, & - Kw1, Kw8, Skw_zt, tau1m, tauw3t, C1_Skw_fnc, & + Kw1, Kw8, Skw_zt, tau1m, tauw3t, tau_C1_zm, C1_Skw_fnc, & C11_Skw_fnc, rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & invrs_rho_ds_zt, l_crank_nich_diff, nsub, nsup, & lhs ) @@ -969,7 +929,7 @@ subroutine wp23_gmres( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & ! Generate the LHS in LAPACK format call wp23_lhs( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & wp3_on_wp2, & - Kw1, Kw8, Skw_zt, tau1m, tauw3t, C1_Skw_fnc, & + Kw1, Kw8, Skw_zt, tau1m, tauw3t, tau_C1_zm, C1_Skw_fnc, & C11_Skw_fnc, rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & invrs_rho_ds_zt, l_crank_nich_diff, nsub, nsup, & lhs ) @@ -985,7 +945,7 @@ subroutine wp23_gmres( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & lhs, rhs, solut, rcond, err_code ) ! Est. of the condition number of the w'^2/w^3 LHS matrix - call stat_update_var_pt( iwp23_matrix_condt_num, 1, 1.0_core_rknd / rcond, sfc ) + call stat_update_var_pt( iwp23_matrix_condt_num, 1, 1.0_core_rknd / rcond, stats_sfc ) else ! Perform LU decomp and solve system (LAPACK) @@ -1016,6 +976,7 @@ subroutine wp23_gmres( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & solut(1:gr%nz) = Skw_zt solut(1:gr%nz) = tau1m solut(1:gr%nz) = tauw3t + solut(1:gr%nz) = tau_C1_zm solut(1:gr%nz) = wm_zt solut(1:gr%nz) = wm_zm solut(1:gr%nz) = wp2 @@ -1032,7 +993,7 @@ end subroutine wp23_gmres !============================================================================= subroutine wp23_lhs( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & wp3_on_wp2, & - Kw1, Kw8, Skw_zt, tau1m, tauw3t, C1_Skw_fnc, & + Kw1, Kw8, Skw_zt, tau1m, tauw3t, tau_C1_zm, C1_Skw_fnc, & C11_Skw_fnc, rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & invrs_rho_ds_zt, l_crank_nich_diff, nsub, nsup, & lhs ) @@ -1059,17 +1020,14 @@ subroutine wp23_lhs( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & C8b, & C12, & nu1_vert_res_dep, & - nu8_vert_res_dep, & - nu_hd_vert_res_dep + nu8_vert_res_dep use constants_clubb, only: & - eps, & ! Variable(s) three_halves, & gamma_over_implicit_ts use model_flags, only: & - l_tke_aniso, & ! Variable(s) - l_hyper_dfsn + l_tke_aniso ! Variable(s) use diffusion, only: & diffusion_zm_lhs, & ! Procedures @@ -1079,12 +1037,7 @@ subroutine wp23_lhs( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & term_ma_zm_lhs, & ! Procedures term_ma_zt_lhs - use hyper_diffusion_4th_ord, only: & - hyper_dfsn_4th_ord_zm_lhs, & - hyper_dfsn_4th_ord_zt_lhs - use clubb_precision, only: & - time_precision, & core_rknd use stats_variables, only: & @@ -1100,13 +1053,10 @@ subroutine wp23_lhs( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & zmscr11, & zmscr10, & zmscr12, & - zmscr13, & - zmscr14, & - zmscr15, & - zmscr16, & - zmscr17, & ztscr01, & - ztscr02, & + ztscr02 + + use stats_variables, only: & ztscr03, & ztscr04, & ztscr05, & @@ -1120,12 +1070,7 @@ subroutine wp23_lhs( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & ztscr13, & ztscr14, & ztscr15, & - ztscr16, & - ztscr17, & - ztscr18, & - ztscr19, & - ztscr20, & - ztscr21 + ztscr16 use stats_variables, only: & l_stats_samp, & @@ -1136,15 +1081,13 @@ subroutine wp23_lhs( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & iwp2_ac, & iwp2_pr2, & iwp2_pr1, & - iwp2_4hd, & iwp3_ta, & iwp3_tp, & iwp3_ma, & iwp3_ac, & iwp3_pr2, & iwp3_pr1, & - iwp3_dp1, & - iwp3_4hd + iwp3_dp1 use advance_helper_module, only: set_boundary_conditions_lhs ! Procedure(s) @@ -1154,31 +1097,27 @@ subroutine wp23_lhs( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & ! Left-hand side matrix diagonal identifiers for ! momentum-level variable, w'^2. integer, parameter :: & - m_kp2_mdiag = 1, & ! Momentum super-super diagonal index for w'^2. !m_kp2_tdiag = 2, & ! Thermodynamic super-super diagonal index for w'^2. m_kp1_mdiag = 3, & ! Momentum super diagonal index for w'^2. m_kp1_tdiag = 4, & ! Thermodynamic super diagonal index for w'^2. m_k_mdiag = 5, & ! Momentum main diagonal index for w'^2. m_k_tdiag = 6, & ! Thermodynamic sub diagonal index for w'^2. - m_km1_mdiag = 7, & ! Momentum sub diagonal index for w'^2. + m_km1_mdiag = 7 ! Momentum sub diagonal index for w'^2. !m_km1_tdiag = 8, & ! Thermodynamic sub-sub diagonal index for w'^2. - m_km2_mdiag = 9 ! Momentum sub-sub diagonal index for w'^2. ! Left-hand side matrix diagonal identifiers for ! thermodynamic-level variable, w'^3. integer, parameter :: & - t_kp2_tdiag = 1, & ! Thermodynamic super-super diagonal index for w'^3. !t_kp1_mdiag = 2, & ! Momentum super-super diagonal index for w'^3. t_kp1_tdiag = 3, & ! Thermodynamic super diagonal index for w'^3. !t_k_mdiag = 4, & ! Momentum super diagonal index for w'^3. t_k_tdiag = 5, & ! Thermodynamic main diagonal index for w'^3. !t_km1_mdiag = 6, & ! Momentum sub diagonal index for w'^3. - t_km1_tdiag = 7, & ! Thermodynamic sub diagonal index for w'^3. + t_km1_tdiag = 7 ! Thermodynamic sub diagonal index for w'^3. !t_km2_mdiag = 8, & ! Momentum sub-sub diagonal index for w'^3. - t_km2_tdiag = 9 ! Thermodynamic sub-sub diagonal index for w'^3. ! Input Variables - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dt ! Timestep length [s] real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & @@ -1195,6 +1134,7 @@ subroutine wp23_lhs( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & Skw_zt, & ! Skewness of w on thermodynamic levels [-] tau1m, & ! Time-scale tau on momentum levels [s] tauw3t, & ! Time-scale tau on thermodynamic levels [s] + tau_C1_zm, & ! Tau values used for the C1 (dp1) term in wp2 [s] C1_Skw_fnc, & ! C_1 parameter with Sk_w applied [-] C11_Skw_fnc, & ! C_11 parameter with Sk_w applied [-] rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] @@ -1208,7 +1148,6 @@ subroutine wp23_lhs( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & integer, intent(in) :: & nsub, & ! Number of subdiagonals in the LHS matrix. nsup ! Number of superdiagonals in the LHS matrix. - ! Output Variable real( kind = core_rknd ), dimension(5-nsup:5+nsub,2*gr%nz), intent(out) :: & lhs ! Implicit contributions to wp2/wp3 (band diag. matrix) @@ -1216,7 +1155,7 @@ subroutine wp23_lhs( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & ! Local Variables ! Array indices - integer :: k, km1, km2, kp1, kp2, k_wp2, k_wp3, k_wp2_low, k_wp2_high, & + integer :: k, km1, kp1, k_wp2, k_wp3, k_wp2_low, k_wp2_high, & k_wp3_low, k_wp3_high real( kind = core_rknd ), dimension(5) :: tmp @@ -1230,9 +1169,7 @@ subroutine wp23_lhs( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & ! Define indices km1 = max( k-1, 1 ) - km2 = max( k-2, 1 ) kp1 = min( k+1, gr%nz ) - kp2 = min( k+2, gr%nz ) k_wp3 = 2*k - 1 k_wp2 = 2*k @@ -1260,10 +1197,9 @@ subroutine wp23_lhs( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & ! [ x wp3(k+2,) ] ! Momentum super-super diagonal (lhs index: m_kp2_mdiag) ! [ x wp2(k+2,) ] - ! LHS time tendency. lhs(m_k_mdiag,k_wp2) & - = + 1.0_core_rknd / real( dt, kind = core_rknd ) + = + 1.0_core_rknd / dt ! LHS mean advection (ma) term. lhs((/m_kp1_mdiag,m_k_mdiag,m_km1_mdiag/),k_wp2) & @@ -1289,7 +1225,7 @@ subroutine wp23_lhs( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & lhs(m_k_mdiag,k_wp2) & = lhs(m_k_mdiag,k_wp2) & + gamma_over_implicit_ts & - * wp2_term_dp1_lhs( C1_Skw_fnc(k), tau1m(k) ) + * wp2_term_dp1_lhs( C1_Skw_fnc(k), tau_C1_zm(k) ) ! LHS eddy diffusion term: dissipation term 2 (dp2). if ( l_crank_nich_diff ) then @@ -1322,19 +1258,6 @@ subroutine wp23_lhs( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & * wp2_term_pr1_lhs( C4, tau1m(k) ) endif - ! LHS 4th-order hyper-diffusion (4hd). - if ( l_hyper_dfsn ) then - ! Note: w'^2 uses fixed-point boundary conditions. - lhs( (/m_kp2_mdiag,m_kp1_mdiag,m_k_mdiag,m_km1_mdiag,m_km2_mdiag/), & - k_wp2 ) & - = lhs( (/m_kp2_mdiag,m_kp1_mdiag,m_k_mdiag,m_km1_mdiag,m_km2_mdiag/), & - k_wp2 ) & - + hyper_dfsn_4th_ord_zm_lhs( 'fixed-point', nu_hd_vert_res_dep, gr%invrs_dzm(k), & - gr%invrs_dzt(kp1), gr%invrs_dzt(k), & - gr%invrs_dzm(kp1), gr%invrs_dzm(km1), & - gr%invrs_dzt(kp2), gr%invrs_dzt(km1), k ) - endif - if ( l_stats_samp ) then ! Statistics: implicit contributions for wp2. @@ -1346,7 +1269,7 @@ subroutine wp23_lhs( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & if ( iwp2_dp1 > 0 ) then zmscr01(k) & = - gamma_over_implicit_ts & - * wp2_term_dp1_lhs( C1_Skw_fnc(k), tau1m(k) ) + * wp2_term_dp1_lhs( C1_Skw_fnc(k), tau_C1_zm(k) ) endif if ( iwp2_dp2 > 0 ) then @@ -1412,19 +1335,6 @@ subroutine wp23_lhs( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & * wp2_term_pr1_lhs( C4, tau1m(k) ) endif - if ( iwp2_4hd > 0 .and. l_hyper_dfsn ) then - tmp(1:5) = & - hyper_dfsn_4th_ord_zm_lhs( 'fixed-point', nu_hd_vert_res_dep, gr%invrs_dzm(k), & - gr%invrs_dzt(kp1), gr%invrs_dzt(k), & - gr%invrs_dzm(kp1), gr%invrs_dzm(km1), & - gr%invrs_dzt(kp2), gr%invrs_dzt(km1), k ) - zmscr13(k) = -tmp(5) - zmscr14(k) = -tmp(4) - zmscr15(k) = -tmp(3) - zmscr16(k) = -tmp(2) - zmscr17(k) = -tmp(1) - endif - endif @@ -1454,7 +1364,7 @@ subroutine wp23_lhs( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & ! LHS time tendency. lhs(t_k_tdiag,k_wp3) & - = + 1.0_core_rknd / real( dt, kind = core_rknd ) + = + 1.0_core_rknd / dt ! LHS mean advection (ma) term. lhs((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/),k_wp3) & @@ -1520,19 +1430,6 @@ subroutine wp23_lhs( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & gr%invrs_dzt(k), k ) endif - ! LHS 4th-order hyper-diffusion (4hd). - if ( l_hyper_dfsn ) then - ! Note: w'^3 uses fixed-point boundary conditions. - lhs( (/t_kp2_tdiag,t_kp1_tdiag,t_k_tdiag,t_km1_tdiag,t_km2_tdiag/), & - k_wp3 ) & - = lhs( (/t_kp2_tdiag,t_kp1_tdiag,t_k_tdiag,t_km1_tdiag,t_km2_tdiag/), & - k_wp3 ) & - + hyper_dfsn_4th_ord_zt_lhs( 'fixed-point', nu_hd_vert_res_dep, gr%invrs_dzt(k), & - gr%invrs_dzm(k), gr%invrs_dzm(km1), & - gr%invrs_dzt(kp1), gr%invrs_dzt(km1), & - gr%invrs_dzm(kp1), gr%invrs_dzm(km2), k ) - endif - if ( l_stats_samp ) then ! Statistics: implicit contributions for wp3. @@ -1643,19 +1540,6 @@ subroutine wp23_lhs( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & endif - if ( iwp3_4hd > 0 .and. l_hyper_dfsn ) then - tmp(1:5) = & - hyper_dfsn_4th_ord_zt_lhs( 'fixed-point', nu_hd_vert_res_dep, gr%invrs_dzt(k), & - gr%invrs_dzm(k), gr%invrs_dzm(km1), & - gr%invrs_dzt(kp1), gr%invrs_dzt(km1), & - gr%invrs_dzm(kp1), gr%invrs_dzm(km2), k ) - ztscr17(k) = -tmp(5) - ztscr18(k) = -tmp(4) - ztscr19(k) = -tmp(3) - ztscr20(k) = -tmp(2) - ztscr21(k) = -tmp(1) - endif - endif enddo ! k = 2, gr%nz-1, 1 @@ -1701,7 +1585,7 @@ end subroutine wp23_lhs !============================================================================= subroutine wp23_lhs_csr( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & wp3_on_wp2, & - Kw1, Kw8, Skw_zt, tau1m, tauw3t, C1_Skw_fnc, & + Kw1, Kw8, Skw_zt, tau1m, tauw3t, tau_C1_zm, C1_Skw_fnc, & C11_Skw_fnc, rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & invrs_rho_ds_zt, l_crank_nich_diff, & lhs_a_csr ) @@ -1730,8 +1614,7 @@ subroutine wp23_lhs_csr( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & C8b, & C12, & nu1_vert_res_dep, & - nu8_vert_res_dep, & - nu_hd_vert_res_dep + nu8_vert_res_dep use constants_clubb, only: & eps, & ! Variable(s) @@ -1739,8 +1622,7 @@ subroutine wp23_lhs_csr( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & gamma_over_implicit_ts use model_flags, only: & - l_tke_aniso, & ! Variable(s) - l_hyper_dfsn + l_tke_aniso ! Variable(s) use diffusion, only: & diffusion_zm_lhs, & ! Procedures @@ -1750,12 +1632,7 @@ subroutine wp23_lhs_csr( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & term_ma_zm_lhs, & ! Procedures term_ma_zt_lhs - use hyper_diffusion_4th_ord, only: & - hyper_dfsn_4th_ord_zm_lhs, & - hyper_dfsn_4th_ord_zt_lhs - use clubb_precision, only: & - time_precision, & core_rknd use stats_variables, only: & @@ -1771,13 +1648,10 @@ subroutine wp23_lhs_csr( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & zmscr11, & zmscr10, & zmscr12, & - zmscr13, & - zmscr14, & - zmscr15, & - zmscr16, & - zmscr17, & ztscr01, & - ztscr02, & + ztscr02 + + use stats_variables, only: & ztscr03, & ztscr04, & ztscr05, & @@ -1791,12 +1665,7 @@ subroutine wp23_lhs_csr( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & ztscr13, & ztscr14, & ztscr15, & - ztscr16, & - ztscr17, & - ztscr18, & - ztscr19, & - ztscr20, & - ztscr21 + ztscr16 use stats_variables, only: & l_stats_samp, & @@ -1807,17 +1676,15 @@ subroutine wp23_lhs_csr( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & iwp2_ac, & iwp2_pr2, & iwp2_pr1, & - iwp2_4hd, & iwp3_ta, & iwp3_tp, & iwp3_ma, & iwp3_ac, & iwp3_pr2, & iwp3_pr1, & - iwp3_dp1, & - iwp3_4hd + iwp3_dp1 - use csr_matrix_class, only: & + use csr_matrix_module, only: & intlc_5d_5d_ja_size ! Variable implicit none @@ -1853,7 +1720,7 @@ subroutine wp23_lhs_csr( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & !t_km2_tdiag ! Thermodynamic sub-sub diagonal index for w'^3. ! Input Variables - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dt ! Timestep length [s] real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & @@ -1870,6 +1737,7 @@ subroutine wp23_lhs_csr( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & Skw_zt, & ! Skewness of w on thermodynamic levels [-] tau1m, & ! Time-scale tau on momentum levels [s] tauw3t, & ! Time-scale tau on thermodynamic levels [s] + tau_C1_zm, & ! Tau values used for the C1 (dp1) term in wp2 [s] C1_Skw_fnc, & ! C_1 parameter with Sk_w applied [-] C11_Skw_fnc, & ! C_11 parameter with Sk_w applied [-] rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] @@ -1891,7 +1759,7 @@ subroutine wp23_lhs_csr( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & ! Local Variables ! Array indices - integer :: k, km1, km2, kp1, kp2, k_wp2, k_wp3, wp2_cur_row, wp3_cur_row + integer :: k, km1, kp1, k_wp2, k_wp3, wp2_cur_row, wp3_cur_row real( kind = core_rknd ), dimension(5) :: tmp @@ -1904,9 +1772,7 @@ subroutine wp23_lhs_csr( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & ! Define indices km1 = max( k-1, 1 ) - km2 = max( k-2, 1 ) kp1 = min( k+1, gr%nz ) - kp2 = min( k+2, gr%nz ) k_wp3 = 2*k - 1 k_wp2 = 2*k @@ -1996,7 +1862,7 @@ subroutine wp23_lhs_csr( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & lhs_a_csr(m_k_mdiag) & = lhs_a_csr(m_k_mdiag) & + gamma_over_implicit_ts & - * wp2_term_dp1_lhs( C1_Skw_fnc(k), tau1m(k) ) + * wp2_term_dp1_lhs( C1_Skw_fnc(k), tau_C1_zm(k) ) ! LHS eddy diffusion term: dissipation term 2 (dp2). if ( l_crank_nich_diff ) then @@ -2029,21 +1895,6 @@ subroutine wp23_lhs_csr( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & * wp2_term_pr1_lhs( C4, tau1m(k) ) endif - ! LHS 4th-order hyper-diffusion (4hd). - ! NOTE: 4th-order hyper-diffusion is not yet supported in CSR-format. - ! As such, this needs to remain commented out. - !if ( l_hyper_dfsn ) then - ! ! Note: w'^2 uses fixed-point boundary conditions. - ! lhs( (/m_kp2_mdiag,m_kp1_mdiag,m_k_mdiag,m_km1_mdiag,m_km2_mdiag/), & - ! k_wp2) & - ! = lhs( (/m_kp2_mdiag,m_kp1_mdiag,m_k_mdiag,m_km1_mdiag,m_km2_mdiag/), & - ! k_wp2) & - ! + hyper_dfsn_4th_ord_zm_lhs( 'fixed-point', nu_hd_vert_res_dep, gr%invrs_dzm(k), & - ! gr%invrs_dzt(kp1), gr%invrs_dzt(k), & - ! gr%invrs_dzm(kp1), gr%invrs_dzm(km1), & - ! gr%invrs_dzt(kp2), gr%invrs_dzt(km1), k ) - !endif - if ( l_stats_samp ) then ! Statistics: implicit contributions for wp2. @@ -2055,7 +1906,7 @@ subroutine wp23_lhs_csr( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & if ( iwp2_dp1 > 0 ) then zmscr01(k) & = - gamma_over_implicit_ts & - * wp2_term_dp1_lhs( C1_Skw_fnc(k), tau1m(k) ) + * wp2_term_dp1_lhs( C1_Skw_fnc(k), tau_C1_zm(k) ) endif if ( iwp2_dp2 > 0 ) then @@ -2121,19 +1972,6 @@ subroutine wp23_lhs_csr( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & * wp2_term_pr1_lhs( C4, tau1m(k) ) endif - if ( iwp2_4hd > 0 .and. l_hyper_dfsn ) then - tmp(1:5) = & - hyper_dfsn_4th_ord_zm_lhs( 'fixed-point', nu_hd_vert_res_dep, gr%invrs_dzm(k), & - gr%invrs_dzt(kp1), gr%invrs_dzt(k), & - gr%invrs_dzm(kp1), gr%invrs_dzm(km1), & - gr%invrs_dzt(kp2), gr%invrs_dzt(km1), k ) - zmscr13(k) = -tmp(5) - zmscr14(k) = -tmp(4) - zmscr15(k) = -tmp(3) - zmscr16(k) = -tmp(2) - zmscr17(k) = -tmp(1) - endif - endif @@ -2260,20 +2098,6 @@ subroutine wp23_lhs_csr( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & gr%invrs_dzt(k), k ) endif - ! LHS 4th-order hyper-diffusion (4hd). - ! NOTE: 4th-order hyper-diffusion is not yet supported in CSR-format. - ! As such, this needs to remain commented out. - !if ( l_hyper_dfsn ) then - ! ! Note: w'^3 uses fixed-point boundary conditions. - ! lhs( (/t_kp2_tdiag,t_kp1_tdiag,t_k_tdiag,t_km1_tdiag,t_km2_tdiag/), & - ! k_wp3) & - ! = lhs( (/t_kp2_tdiag,t_kp1_tdiag,t_k_tdiag,t_km1_tdiag,t_km2_tdiag/), & - ! k_wp3) & - ! + hyper_dfsn_4th_ord_zt_lhs( 'fixed-point', nu_hd_vert_res_dep, gr%invrs_dzt(k), & - ! gr%invrs_dzm(k), gr%invrs_dzm(km1), & - ! gr%invrs_dzt(kp1), gr%invrs_dzt(km1), & - ! gr%invrs_dzm(kp1), gr%invrs_dzm(km2), k ) - !endif if (l_stats_samp) then @@ -2385,19 +2209,6 @@ subroutine wp23_lhs_csr( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & endif - if ( iwp3_4hd > 0 .and. l_hyper_dfsn ) then - tmp(1:5) = & - hyper_dfsn_4th_ord_zt_lhs( 'fixed-point', nu_hd_vert_res_dep, gr%invrs_dzt(k), & - gr%invrs_dzm(k), gr%invrs_dzm(km1), & - gr%invrs_dzt(kp1), gr%invrs_dzt(km1), & - gr%invrs_dzm(kp1), gr%invrs_dzm(km2), k ) - ztscr17(k) = -tmp(5) - ztscr18(k) = -tmp(4) - ztscr19(k) = -tmp(3) - ztscr20(k) = -tmp(2) - ztscr21(k) = -tmp(1) - endif - endif enddo ! k = 2, gr%nz-1, 1 @@ -2472,8 +2283,8 @@ end subroutine wp23_lhs_csr subroutine wp23_rhs( dt, wp2, wp3, a1, a1_zt, & a3, a3_zt, wp3_on_wp2, wpthvp, wp2thvp, um, vm, & upwp, vpwp, up2, vp2, Kw1, Kw8, Kh_zt, & - Skw_zt, tau1m, tauw3t, C1_Skw_fnc, & - C11_Skw_fnc, rho_ds_zm, invrs_rho_ds_zt, & + Skw_zt, tau1m, tauw3t, tau_C1_zm, C1_Skw_fnc, & + C11_Skw_fnc, rho_ds_zm, invrs_rho_ds_zt, radf, & thv_ds_zm, thv_ds_zt, l_crank_nich_diff, & rhs ) @@ -2503,7 +2314,6 @@ subroutine wp23_rhs( dt, wp2, wp3, a1, a1_zt, & use constants_clubb, only: & w_tol_sqd, & ! Variable(s) - eps, & three_halves, & gamma_over_implicit_ts @@ -2515,15 +2325,14 @@ subroutine wp23_rhs( dt, wp2, wp3, a1, a1_zt, & diffusion_zt_lhs use clubb_precision, only: & - time_precision, & ! Variable - core_rknd + core_rknd ! Variable use stats_variables, only: & - l_stats_samp, iwp2_dp1, iwp2_dp2, zm, iwp2_bp, & ! Variable(s) - iwp2_pr1, iwp2_pr2, iwp2_pr3, iwp3_ta, zt, & + l_stats_samp, iwp2_dp1, iwp2_dp2, stats_zm, iwp2_bp, & ! Variable(s) + iwp2_pr1, iwp2_pr2, iwp2_pr3, iwp3_ta, stats_zt, & iwp3_tp, iwp3_bp1, iwp3_pr2, iwp3_pr1, iwp3_dp1, iwp3_bp2 - use stats_type, only: & + use stats_type_utilities, only: & stat_update_var_pt, & ! Procedure(s) stat_begin_update_pt, & stat_modify_pt @@ -2538,7 +2347,7 @@ subroutine wp23_rhs( dt, wp2, wp3, a1, a1_zt, & l_wp3_2nd_buoyancy_term = .true. ! Input Variables - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dt ! Timestep length [s] real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & @@ -2563,10 +2372,12 @@ subroutine wp23_rhs( dt, wp2, wp3, a1, a1_zt, & Skw_zt, & ! Skewness of w on thermodynamic levels [-] tau1m, & ! Time-scale tau on momentum levels [s] tauw3t, & ! Time-scale tau on thermodynamic levels [s] + tau_C1_zm, & ! Tau values used for the C1 (dp1) term in wp2 [s] C1_Skw_fnc, & ! C_1 parameter with Sk_w applied [-] C11_Skw_fnc, & ! C_11 parameter with Sk_w applied [-] rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] invrs_rho_ds_zt, & ! Inv. dry, static density @ thermo. levs. [m^3/kg] + radf, & ! Buoyancy production at the CL top [m^2/s^3] thv_ds_zm, & ! Dry, base-state theta_v on momentum levs. [K] thv_ds_zt ! Dry, base-state theta_v on thermo. levs. [K] @@ -2630,13 +2441,16 @@ subroutine wp23_rhs( dt, wp2, wp3, a1, a1_zt, & ! RHS time tendency. rhs(k_wp2) & - = + ( 1.0_core_rknd / real( dt, kind = core_rknd ) ) * wp2(k) + = + ( 1.0_core_rknd / dt ) * wp2(k) ! RHS buoyancy production (bp) term and pressure term 2 (pr2). rhs(k_wp2) & = rhs(k_wp2) & + wp2_terms_bp_pr2_rhs( C5, thv_ds_zm(k), wpthvp(k) ) + ! RHS buoyancy production at CL top due to LW radiative cooling + rhs(k_wp2) = rhs(k_wp2) + radf(k) + ! RHS pressure term 3 (pr3). rhs(k_wp2) & = rhs(k_wp2) & @@ -2646,7 +2460,7 @@ subroutine wp23_rhs( dt, wp2, wp3, a1, a1_zt, & ! RHS dissipation term 1 (dp1). rhs(k_wp2) & = rhs(k_wp2) & - + wp2_term_dp1_rhs( C1_Skw_fnc(k), tau1m(k), w_tol_sqd ) + + wp2_term_dp1_rhs( C1_Skw_fnc(k), tau_C1_zm(k), w_tol_sqd ) ! RHS contribution from "over-implicit" weighted time step ! for LHS dissipation term 1 (dp1). @@ -2656,7 +2470,7 @@ subroutine wp23_rhs( dt, wp2, wp3, a1, a1_zt, & ! more numerically stable (see note below for w'^3 RHS turbulent ! advection (ta) and turbulent production (tp) terms). lhs_fnc_output(1) & - = wp2_term_dp1_lhs( C1_Skw_fnc(k), tau1m(k) ) + = wp2_term_dp1_lhs( C1_Skw_fnc(k), tau_C1_zm(k) ) rhs(k_wp2) & = rhs(k_wp2) & + ( 1.0_core_rknd - gamma_over_implicit_ts ) & @@ -2714,21 +2528,21 @@ subroutine wp23_rhs( dt, wp2, wp3, a1, a1_zt, & call stat_begin_update_pt( iwp2_dp2, k, & rhs_diff(3) * wp2(km1) & + rhs_diff(2) * wp2(k) & - + rhs_diff(1) * wp2(kp1), zm ) + + rhs_diff(1) * wp2(kp1), stats_zm ) endif ! w'^2 term bp is completely explicit; call stat_update_var_pt. ! Note: To find the contribution of w'^2 term bp, substitute 0 for the ! C_5 input to function wp2_terms_bp_pr2_rhs. call stat_update_var_pt( iwp2_bp, k, & - wp2_terms_bp_pr2_rhs( 0.0_core_rknd, thv_ds_zm(k), wpthvp(k) ), zm ) + wp2_terms_bp_pr2_rhs( 0.0_core_rknd, thv_ds_zm(k), wpthvp(k) ), stats_zm ) ! w'^2 term pr1 has both implicit and explicit components; call ! stat_begin_update_pt. Since stat_begin_update_pt automatically ! subtracts the value sent in, reverse the sign on wp2_term_pr1_rhs. if ( l_tke_aniso ) then call stat_begin_update_pt( iwp2_pr1, k, & - -wp2_term_pr1_rhs( C4, up2(k), vp2(k), tau1m(k) ), zm ) + -wp2_term_pr1_rhs( C4, up2(k), vp2(k), tau1m(k) ), stats_zm ) ! Note: An "over-implicit" weighted time step is applied to this ! term. A weighting factor of greater than 1 may be used to @@ -2739,7 +2553,7 @@ subroutine wp23_rhs( dt, wp2, wp3, a1, a1_zt, & = wp2_term_pr1_lhs( C4, tau1m(k) ) call stat_modify_pt( iwp2_pr1, k, & + ( 1.0_core_rknd - gamma_over_implicit_ts ) & - * ( - lhs_fnc_output(1) * wp2(k) ), zm ) + * ( - lhs_fnc_output(1) * wp2(k) ), stats_zm ) endif ! w'^2 term pr2 has both implicit and explicit components; call @@ -2748,29 +2562,29 @@ subroutine wp23_rhs( dt, wp2, wp3, a1, a1_zt, & ! Note: To find the contribution of w'^2 term pr2, add 1 to the ! C_5 input to function wp2_terms_bp_pr2_rhs. call stat_begin_update_pt( iwp2_pr2, k, & - -wp2_terms_bp_pr2_rhs( (1.0_core_rknd+C5), thv_ds_zm(k), wpthvp(k) ), zm ) + -wp2_terms_bp_pr2_rhs( (1.0_core_rknd+C5), thv_ds_zm(k), wpthvp(k) ), stats_zm ) ! w'^2 term dp1 has both implicit and explicit components; call ! stat_begin_update_pt. Since stat_begin_update_pt automatically ! subtracts the value sent in, reverse the sign on wp2_term_dp1_rhs. call stat_begin_update_pt( iwp2_dp1, k, & - -wp2_term_dp1_rhs( C1_Skw_fnc(k), tau1m(k), w_tol_sqd ), zm ) + -wp2_term_dp1_rhs( C1_Skw_fnc(k), tau_C1_zm(k), w_tol_sqd ), stats_zm ) ! Note: An "over-implicit" weighted time step is applied to this term. ! A weighting factor of greater than 1 may be used to make the ! term more numerically stable (see note below for w'^3 RHS ! turbulent advection (ta) and turbulent production (tp) terms). lhs_fnc_output(1) & - = wp2_term_dp1_lhs( C1_Skw_fnc(k), tau1m(k) ) + = wp2_term_dp1_lhs( C1_Skw_fnc(k), tau_C1_zm(k) ) call stat_modify_pt( iwp2_dp1, k, & + ( 1.0_core_rknd - gamma_over_implicit_ts ) & - * ( - lhs_fnc_output(1) * wp2(k) ), zm ) + * ( - lhs_fnc_output(1) * wp2(k) ), stats_zm ) ! w'^2 term pr3 is completely explicit; call stat_update_var_pt. call stat_update_var_pt( iwp2_pr3, k, & wp2_term_pr3_rhs( C5, thv_ds_zm(k), wpthvp(k), upwp(k), um(kp1), & um(k), vpwp(k), vm(kp1), vm(k), gr%invrs_dzm(k) ), & - zm ) + stats_zm ) endif @@ -2782,7 +2596,7 @@ subroutine wp23_rhs( dt, wp2, wp3, a1, a1_zt, & ! RHS time tendency. rhs(k_wp3) = & - + ( 1.0_core_rknd / real( dt, kind = core_rknd ) * wp3(k) ) + + ( 1.0_core_rknd / dt * wp3(k) ) ! RHS turbulent advection (ta) and turbulent production (tp) terms. ! rhs(k_wp3) & @@ -2896,8 +2710,8 @@ subroutine wp23_rhs( dt, wp2, wp3, a1, a1_zt, & ! invrs_rho_ds_zt(k), & ! 0.0_core_rknd, & ! gr%invrs_dzt(k) ), & -! zt ) - call stat_begin_update_pt( iwp3_ta, k, 0.0_core_rknd, zt ) +! stats_zt ) + call stat_begin_update_pt( iwp3_ta, k, 0.0_core_rknd, stats_zt ) ! Note: An "over-implicit" weighted time step is applied to this term. ! A weighting factor of greater than 1 may be used to make the @@ -2919,7 +2733,7 @@ subroutine wp23_rhs( dt, wp2, wp3, a1, a1_zt, & - lhs_fnc_output(2) * wp2(k) & - lhs_fnc_output(3) * wp3(k) & - lhs_fnc_output(4) * wp2(km1) & - - lhs_fnc_output(5) * wp3(km1) ), zt ) + - lhs_fnc_output(5) * wp3(km1) ), stats_zt ) ! w'^3 term tp has both implicit and explicit components; call ! stat_begin_update_pt. Since stat_begin_update_pt automatically @@ -2938,8 +2752,8 @@ subroutine wp23_rhs( dt, wp2, wp3, a1, a1_zt, & ! invrs_rho_ds_zt(k), & ! three_halves, & ! gr%invrs_dzt(k) ), & -! zt ) - call stat_begin_update_pt( iwp3_tp, k, 0.0_core_rknd, zt ) +! stats_zt ) + call stat_begin_update_pt( iwp3_tp, k, 0.0_core_rknd, stats_zt ) ! Note: An "over-implicit" weighted time step is applied to this term. ! A weighting factor of greater than 1 may be used to make the @@ -2958,13 +2772,13 @@ subroutine wp23_rhs( dt, wp2, wp3, a1, a1_zt, & call stat_modify_pt( iwp3_tp, k, & + ( 1.0_core_rknd - gamma_over_implicit_ts ) & * ( - lhs_fnc_output(2) * wp2(k) & - - lhs_fnc_output(4) * wp2(km1) ), zt ) + - lhs_fnc_output(4) * wp2(km1) ), stats_zt ) ! w'^3 term bp is completely explicit; call stat_update_var_pt. ! Note: To find the contribution of w'^3 term bp, substitute 0 for the ! C_11 skewness function input to function wp3_terms_bp1_pr2_rhs. call stat_update_var_pt( iwp3_bp1, k, & - wp3_terms_bp1_pr2_rhs( 0.0_core_rknd, thv_ds_zt(k), wp2thvp(k) ), zt ) + wp3_terms_bp1_pr2_rhs( 0.0_core_rknd, thv_ds_zt(k), wp2thvp(k) ), stats_zt ) ! w'^3 term pr2 has both implicit and explicit components; call ! stat_begin_update_pt. Since stat_begin_update_pt automatically @@ -2974,14 +2788,14 @@ subroutine wp23_rhs( dt, wp2, wp3, a1, a1_zt, & call stat_begin_update_pt( iwp3_pr2, k, & -wp3_terms_bp1_pr2_rhs( (1.0_core_rknd+C11_Skw_fnc(k)), thv_ds_zt(k), & wp2thvp(k) ), & - zt ) + stats_zt ) ! w'^3 term pr1 has both implicit and explicit components; call ! stat_begin_update_pt. Since stat_begin_update_pt automatically ! subtracts the value sent in, reverse the sign on wp3_term_pr1_rhs. call stat_begin_update_pt( iwp3_pr1, k, & -wp3_term_pr1_rhs( C8, C8b, tauw3t(k), Skw_zt(k), wp3(k) ), & - zt ) + stats_zt ) ! Note: An "over-implicit" weighted time step is applied to this term. ! A weighting factor of greater than 1 may be used to make the @@ -2991,7 +2805,7 @@ subroutine wp23_rhs( dt, wp2, wp3, a1, a1_zt, & = wp3_term_pr1_lhs( C8, C8b, tauw3t(k), Skw_zt(k) ) call stat_modify_pt( iwp3_pr1, k, & + ( 1.0_core_rknd - gamma_over_implicit_ts ) & - * ( - lhs_fnc_output(1) * wp3(k) ), zt ) + * ( - lhs_fnc_output(1) * wp3(k) ), stats_zt ) ! w'^3 term dp1 has both implicit and explicit components (if the ! Crank-Nicholson scheme is selected); call stat_begin_update_pt. @@ -3003,7 +2817,7 @@ subroutine wp23_rhs( dt, wp2, wp3, a1, a1_zt, & call stat_begin_update_pt( iwp3_dp1, k, & rhs_diff(3) * wp3(km1) & + rhs_diff(2) * wp3(k) & - + rhs_diff(1) * wp3(kp1), zt ) + + rhs_diff(1) * wp3(kp1), stats_zt ) endif if ( l_wp3_2nd_buoyancy_term ) then @@ -3011,7 +2825,7 @@ subroutine wp23_rhs( dt, wp2, wp3, a1, a1_zt, & dum_dz(k), dum_dz(km1), dvm_dz(k), dvm_dz(km1), & upwp(k), upwp(km1), vpwp(k), vpwp(km1), & thv_ds_zt(k), gr%invrs_dzt(k) ) - call stat_update_var_pt( iwp3_bp2, k, temp, zt ) + call stat_update_var_pt( iwp3_bp2, k, temp, stats_zt ) end if endif ! l_stats_samp @@ -3694,9 +3508,6 @@ pure function wp3_terms_ta_tp_lhs( wp2, wp2m1, & use grid_class, only: & gr ! Variable gr%weights_zt2zm - use constants_clubb, only: & - w_tol_sqd - use model_flags, only: & l_standard_term_ta diff --git a/models/atm/cam/src/physics/clubb/advance_xm_wpxp_module.F90 b/models/atm/cam/src/physics/clubb/advance_xm_wpxp_module.F90 index a8b70f8a43a3..838fbbad8e5c 100644 --- a/models/atm/cam/src/physics/clubb/advance_xm_wpxp_module.F90 +++ b/models/atm/cam/src/physics/clubb/advance_xm_wpxp_module.F90 @@ -1,5 +1,5 @@ !----------------------------------------------------------------------- -! $Id: advance_xm_wpxp_module.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +! $Id: advance_xm_wpxp_module.F90 7373 2014-11-08 00:44:20Z dschanen@uwm.edu $ !=============================================================================== module advance_xm_wpxp_module @@ -41,12 +41,14 @@ module advance_xm_wpxp_module !============================================================================= subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & - Lscale, wp3_on_wp2, wp3_on_wp2_zt, & - Kh_zt, tau_zm, Skw_zm, rtpthvp, rtm_forcing, & - thlpthvp, rtm_ref, thlm_ref, thlm_forcing, & + Lscale, wp3_on_wp2, wp3_on_wp2_zt, Kh_zt, Kh_zm, & + tau_C6_zm, Skw_zm, rtpthvp, rtm_forcing, & + wprtp_forcing, rtm_ref, thlpthvp, & + thlm_forcing, wpthlp_forcing, thlm_ref, & rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & invrs_rho_ds_zt, thv_ds_zm, rtp2, thlp2, & - pdf_params, l_implemented, & + w_1_zm, w_2_zm, varnce_w_1_zm, varnce_w_2_zm, & + mixt_frac_zm, l_implemented, em, & sclrpthvp, sclrm_forcing, sclrp2, & rtm, wprtp, thlm, wpthlp, & err_code, & @@ -89,6 +91,9 @@ subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & thl_tol_mfl, & rt_tol_mfl, & max_mag_correlation, & + one, & + one_half, & + zero, & zero_threshold use parameters_model, only: & @@ -98,9 +103,9 @@ subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & use grid_class, only: & gr ! Variable(s) - use grid_class, only: & - zm2zt, & ! Procedure(s) - zt2zm + use grid_class, only: & + zm2zt, & ! Procedure(s) + zt2zm use model_flags, only: & l_clip_semi_implicit ! Variable(s) @@ -108,26 +113,25 @@ subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & use mono_flux_limiter, only: & calc_turb_adv_range ! Procedure(s) - use pdf_parameter_module, only: & - pdf_parameter ! Type - use clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd + core_rknd ! Variable(s) + + use error_code, only: & + clubb_at_least_debug_level, & ! Procedure(s) + report_error, & + fatal_error use error_code, only: & - clubb_at_least_debug_level, & ! Procedure(s) - reportError, & - fatal_error + clubb_var_out_of_range ! Constant(s) - use stats_type, only: & + use stats_type_utilities, only: & stat_begin_update, & ! Procedure(s) stat_end_update, & stat_update_var use stats_variables, only: & - zt, & - zm, & + stats_zt, & + stats_zm, & irtm_matrix_condt_num, & ! Variables ithlm_matrix_condt_num, & irtm_sdmp, ithlm_sdmp, & @@ -138,11 +142,11 @@ subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & l_stats_samp use sponge_layer_damping, only: & - rtm_sponge_damp_settings, & - thlm_sponge_damp_settings, & - rtm_sponge_damp_profile, & - thlm_sponge_damp_profile, & - sponge_damp_xm ! Procedure(s) + rtm_sponge_damp_settings, & + thlm_sponge_damp_settings, & + rtm_sponge_damp_profile, & + thlm_sponge_damp_profile, & + sponge_damp_xm ! Procedure(s) implicit none @@ -154,7 +158,7 @@ subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & l_iter = .true. ! True when the means and fluxes are prognosed ! Input Variables - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dt ! Timestep [s] real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & @@ -163,17 +167,21 @@ subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & wm_zt, & ! w wind component on thermodynamic levels [m/s] wp2, & ! w'^2 (momentum levels) [m^2/s^2] Lscale, & ! Turbulent mixing length [m] + em, & ! Turbulent Kinetic Energy (TKE) [m^2/s^2] wp3_on_wp2, & ! Smoothed wp3 / wp2 on momentum levels [m/s] wp3_on_wp2_zt, & ! Smoothed wp3 / wp2 on thermo. levels [m/s] Kh_zt, & ! Eddy diffusivity on thermodynamic levels [m^2/s] - tau_zm, & ! Time-scale tau on momentum levels [s] + Kh_zm, & ! Eddy diffusivity on momentum levels + tau_C6_zm, & ! Time-scale tau on momentum levels applied to C6 term [s] Skw_zm, & ! Skewness of w on momentum levels [-] rtpthvp, & ! r_t'th_v' (momentum levels) [(kg/kg) K] - rtm_ref, & ! rtm for nudging - thlm_ref, & ! thlm for nudging rtm_forcing, & ! r_t forcing (thermodynamic levels) [(kg/kg)/s] + wprtp_forcing, & ! forcing (momentum levels) [(kg/kg)/s^2] + rtm_ref, & ! rtm for nudging [kg/kg] thlpthvp, & ! th_l'th_v' (momentum levels) [K^2] thlm_forcing, & ! th_l forcing (thermodynamic levels) [K/s] + wpthlp_forcing, & ! forcing (momentum levels) [K/s^2] + thlm_ref, & ! thlm for nudging [K] rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] rho_ds_zt, & ! Dry, static density on thermo. levels [kg/m^3] invrs_rho_ds_zm, & ! Inv. dry, static density @ moment. levs. [m^3/kg] @@ -181,11 +189,13 @@ subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & thv_ds_zm, & ! Dry, base-state theta_v on moment. levs. [K] ! Added for clipping by Vince Larson 29 Sep 2007 rtp2, & ! r_t'^2 (momentum levels) [(kg/kg)^2] - thlp2 ! th_l'^2 (momentum levels) [K^2] + thlp2, & ! th_l'^2 (momentum levels) [K^2] ! End of Vince Larson's addition. - - type(pdf_parameter), dimension(gr%nz), intent(in) :: & - pdf_params ! PDF parameters [units vary] + w_1_zm, & ! Mean w (1st PDF component) [m/s] + w_2_zm, & ! Mean w (2nd PDF component) [m/s] + varnce_w_1_zm, & ! Variance of w (1st PDF component) [m^2/s^2] + varnce_w_2_zm, & ! Variance of w (2nd PDF component) [m^2/s^2] + mixt_frac_zm ! Weight of 1st PDF component (Sk_w dependent) [-] logical, intent(in) :: & l_implemented ! Flag for CLUBB being implemented in a larger model. @@ -270,25 +280,29 @@ subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & allocate( rhs(2*gr%nz,nrhs) ) allocate( solution(2*gr%nz,nrhs) ) + ! This is initialized solely for the purpose of avoiding a compiler + ! warning about uninitialized variables. + dummy_1d = zero + ! Compute C6 and C7 as a function of Skw ! The if...then is just here to save compute time if ( C6rt /= C6rtb ) then C6rt_Skw_fnc(1:gr%nz) = C6rtb + (C6rt-C6rtb) & - *EXP( -0.5_core_rknd * (Skw_zm(1:gr%nz)/C6rtc)**2 ) + *EXP( -one_half * (Skw_zm(1:gr%nz)/C6rtc)**2 ) else C6rt_Skw_fnc(1:gr%nz) = C6rtb endif if ( C6thl /= C6thlb ) then C6thl_Skw_fnc(1:gr%nz) = C6thlb + (C6thl-C6thlb) & - *EXP( -0.5_core_rknd * (Skw_zm(1:gr%nz)/C6thlc)**2 ) + *EXP( -one_half * (Skw_zm(1:gr%nz)/C6thlc)**2 ) else C6thl_Skw_fnc(1:gr%nz) = C6thlb endif if ( C7 /= C7b ) then C7_Skw_fnc(1:gr%nz) = C7b + (C7-C7b) & - *EXP( -0.5_core_rknd * (Skw_zm(1:gr%nz)/C7c)**2 ) + *EXP( -one_half * (Skw_zm(1:gr%nz)/C7c)**2 ) else C7_Skw_fnc(1:gr%nz) = C7b endif @@ -307,11 +321,20 @@ subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & if ( l_stats_samp ) then - call stat_update_var( iC7_Skw_fnc, C7_Skw_fnc, zm ) - call stat_update_var( iC6rt_Skw_fnc, C6rt_Skw_fnc, zm ) - call stat_update_var( iC6thl_Skw_fnc, C6thl_Skw_fnc, zm ) + call stat_update_var( iC7_Skw_fnc, C7_Skw_fnc, stats_zm ) + call stat_update_var( iC6rt_Skw_fnc, C6rt_Skw_fnc, stats_zm ) + call stat_update_var( iC6thl_Skw_fnc, C6thl_Skw_fnc, stats_zm ) - endif + end if + + if ( clubb_at_least_debug_level( 2 ) ) then + ! Assertion check for C7_Skw_fnc + if ( any( C7_Skw_fnc(:) > one ) .or. any( C7_Skw_fnc(:) < zero ) ) then + write(fstderr,*) "The C7_Skw_fnc variable is outside the valid range" + err_code = clubb_var_out_of_range + return + end if + end if ! Define the Coefficent of Eddy Diffusivity for the wpthlp and wprtp. ! Kw6 is used for wpthlp and wprtp, which are located on momentum levels. @@ -324,14 +347,15 @@ subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & ! have an effect on the central thermodynamic level during the course of ! one time step due to turbulent advection. This is used as part of the ! monotonic turbulent advection scheme. - call calc_turb_adv_range( dt, pdf_params, & - low_lev_effect, high_lev_effect ) + call calc_turb_adv_range( dt, w_1_zm, w_2_zm, varnce_w_1_zm, varnce_w_2_zm, & ! In + mixt_frac_zm, & ! In + low_lev_effect, high_lev_effect ) ! Out ! Define a_1 (located on momentum levels). ! It is a variable that is a function of sigma_sqd_w (where sigma_sqd_w is ! located on momentum levels). - a1(1:gr%nz) = 1.0_core_rknd / ( 1.0_core_rknd - sigma_sqd_w(1:gr%nz) ) + a1(1:gr%nz) = one / ( one - sigma_sqd_w(1:gr%nz) ) ! Interpolate a_1 from momentum levels to thermodynamic levels. This will ! be used for the w'x' turbulent advection (ta) term. @@ -352,23 +376,24 @@ subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & ! Compute the implicit portion of the r_t and w'r_t' equations. ! Build the left-hand side matrix. - call xm_wpxp_lhs( l_iter, dt, wprtp, a1, a1_zt, wm_zm, wm_zt, & ! Intent(in) + call xm_wpxp_lhs( l_iter, dt, Kh_zm, wprtp, a1, a1_zt, wm_zm, wm_zt, & ! Intent(in) wp2, wp3_on_wp2, wp3_on_wp2_zt, & ! Intent(in) - Kw6, tau_zm, C7_Skw_fnc, & ! Intent(in) + Kw6, tau_C6_zm, C7_Skw_fnc, & ! Intent(in) C6rt_Skw_fnc, rho_ds_zm, rho_ds_zt, & ! Intent(in) invrs_rho_ds_zm, invrs_rho_ds_zt, & ! Intent(in) wpxp_upper_lim, wpxp_lower_lim, l_implemented, & ! Intent(in) + em, Lscale, thlm, & ! Intent(in) lhs ) ! Intent(out) ! Compute the explicit portion of the r_t and w'r_t' equations. ! Build the right-hand side vector. - call xm_wpxp_rhs( xm_wpxp_rtm, l_iter, dt, rtm, wprtp, & ! Intent(in) - rtm_forcing, C7_Skw_fnc, rtpthvp, & ! Intent(in) - C6rt_Skw_fnc, tau_zm, a1, a1_zt, & ! Intent(in) - wp3_on_wp2, wp3_on_wp2_zt, & ! Intent(in) - rho_ds_zt, rho_ds_zm, invrs_rho_ds_zm, & ! Intent(in) - thv_ds_zm, wpxp_upper_lim, wpxp_lower_lim, & ! Intent(in) - rhs(:,1) ) ! Intent(out) + call xm_wpxp_rhs( xm_wpxp_rtm, l_iter, dt, rtm, wprtp, & ! Intent(in) + rtm_forcing, wprtp_forcing, C7_Skw_fnc, & ! Intent(in) + rtpthvp, C6rt_Skw_fnc, tau_C6_zm, a1, a1_zt, & ! Intent(in) + wp3_on_wp2, wp3_on_wp2_zt, rho_ds_zt, & ! Intent(in) + rho_ds_zm, invrs_rho_ds_zm, thv_ds_zm, & ! Intent(in) + wpxp_upper_lim, wpxp_lower_lim, & ! Intent(in) + rhs(:,1) ) ! Intent(out) ! Solve r_t / w'r_t' if ( l_stats_samp .and. irtm_matrix_condt_num > 0 ) then @@ -384,7 +409,7 @@ subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & if ( fatal_error( err_code_xm_wpxp ) ) then if ( clubb_at_least_debug_level( 1 ) ) then write(fstderr,'(a)') "Mean total water & total water flux LU decomp. failed" - call reportError( err_code_xm_wpxp ) + call report_error( err_code_xm_wpxp ) end if ! Overwrite the current error status with the new fatal error @@ -405,7 +430,7 @@ subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & if ( fatal_error( err_code_xm_wpxp ) ) then if ( clubb_at_least_debug_level( 1 ) ) then write(fstderr,'(a)') "rtm monotonic flux limiter: tridag failed" - call reportError( err_code_xm_wpxp ) + call report_error( err_code_xm_wpxp ) end if ! Overwrite the current error status with the new fatal error @@ -425,23 +450,24 @@ subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & ! Compute the implicit portion of the th_l and w'th_l' equations. ! Build the left-hand side matrix. - call xm_wpxp_lhs( l_iter, dt, wpthlp, a1, a1_zt, wm_zm, wm_zt, & ! Intent(in) + call xm_wpxp_lhs( l_iter, dt, Kh_zm, wpthlp, a1, a1_zt, wm_zm, wm_zt, & ! Intent(in) wp2, wp3_on_wp2, wp3_on_wp2_zt, & ! Intent(in) - Kw6, tau_zm, C7_Skw_fnc, & ! Intent(in) + Kw6, tau_C6_zm, C7_Skw_fnc, & ! Intent(in) C6thl_Skw_fnc, rho_ds_zm, rho_ds_zt, & ! Intent(in) invrs_rho_ds_zm, invrs_rho_ds_zt, & ! Intent(in) wpxp_upper_lim, wpxp_lower_lim, l_implemented, & ! Intent(in) + em, Lscale, thlm, & ! Intent(in) lhs ) ! Intent(out) ! Compute the explicit portion of the th_l and w'th_l' equations. ! Build the right-hand side vector. - call xm_wpxp_rhs( xm_wpxp_thlm, l_iter, dt, thlm, wpthlp, & ! Intent(in) - thlm_forcing, C7_Skw_fnc, thlpthvp, & ! Intent(in) - C6thl_Skw_fnc, tau_zm, a1, a1_zt, & ! Intent(in) - wp3_on_wp2, wp3_on_wp2_zt, & ! Intent(in) - rho_ds_zt, rho_ds_zm, invrs_rho_ds_zm, & ! Intent(in) - thv_ds_zm, wpxp_upper_lim, wpxp_lower_lim, & ! Intent(in) - rhs(:,1) ) ! Intent(out) + call xm_wpxp_rhs( xm_wpxp_thlm, l_iter, dt, thlm, wpthlp, & ! Intent(in) + thlm_forcing, wpthlp_forcing, C7_Skw_fnc, & ! Intent(in) + thlpthvp, C6thl_Skw_fnc, tau_C6_zm, a1, a1_zt, & ! Intent(in) + wp3_on_wp2, wp3_on_wp2_zt, rho_ds_zt, & ! Intent(in) + rho_ds_zm, invrs_rho_ds_zm, thv_ds_zm, & ! Intent(in) + wpxp_upper_lim, wpxp_lower_lim, & ! Intent(in) + rhs(:,1) ) ! Intent(out) ! Solve for th_l / w'th_l' if ( l_stats_samp .and. ithlm_matrix_condt_num > 0 ) then @@ -457,7 +483,7 @@ subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & if ( fatal_error( err_code_xm_wpxp ) ) then if ( clubb_at_least_debug_level( 1 ) ) then write(fstderr,'(a)') "Liquid pot. temp & thetal flux LU decomp. failed" - call reportError( err_code_xm_wpxp ) + call report_error( err_code_xm_wpxp ) end if ! Overwrite the current error status with the new fatal error @@ -478,7 +504,7 @@ subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & if ( fatal_error( err_code_xm_wpxp ) ) then if ( clubb_at_least_debug_level( 1 ) ) then write(fstderr,'(a)') "thlm monotonic flux limiter: tridag failed" - call reportError( err_code_xm_wpxp ) + call report_error( err_code_xm_wpxp ) end if ! Overwrite the current error status with the new fatal error @@ -509,23 +535,24 @@ subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & ! Compute the implicit portion of the sclr and w'sclr' equations. ! Build the left-hand side matrix. - call xm_wpxp_lhs( l_iter, dt, wpsclrp(:,i), a1, a1_zt, wm_zm, wm_zt, & ! Intent(in) + call xm_wpxp_lhs( l_iter, dt, Kh_zm, wpsclrp(:,i), a1, a1_zt, wm_zm, wm_zt, & ! Intent(in) wp2, wp3_on_wp2, wp3_on_wp2_zt, & ! Intent(in) - Kw6, tau_zm, C7_Skw_fnc, & ! Intent(in) + Kw6, tau_C6_zm, C7_Skw_fnc, & ! Intent(in) C6rt_Skw_fnc, rho_ds_zm, rho_ds_zt, & ! Intent(in) invrs_rho_ds_zm, invrs_rho_ds_zt, & ! Intent(in) wpxp_upper_lim, wpxp_lower_lim, l_implemented, & ! Intent(in) + em, Lscale, thlm, & ! Intent(in) lhs ) ! Intent(out) ! Compute the explicit portion of the sclrm and w'sclr' equations. ! Build the right-hand side vector. call xm_wpxp_rhs( xm_wpxp_scalar, l_iter, dt, sclrm(:,i), wpsclrp(:,i), & ! Intent(in) - sclrm_forcing(:,i), C7_Skw_fnc, sclrpthvp(:,i), & ! Intent(in) - C6rt_Skw_fnc, tau_zm, a1, a1_zt, & ! Intent(in) - wp3_on_wp2, wp3_on_wp2_zt, & ! Intent(in) - rho_ds_zt, rho_ds_zm, invrs_rho_ds_zm, & ! Intent(in) - thv_ds_zm, wpxp_upper_lim, wpxp_lower_lim, & ! Intent(in) - rhs(:,1) ) ! Intent(out) + sclrm_forcing(:,i), dummy_1d, C7_Skw_fnc, & ! Intent(in) + sclrpthvp(:,i), C6rt_Skw_fnc, tau_C6_zm, a1, a1_zt, & ! Intent(in) + wp3_on_wp2, wp3_on_wp2_zt, rho_ds_zt, & ! Intent(in) + rho_ds_zm, invrs_rho_ds_zm, thv_ds_zm, & ! Intent(in) + wpxp_upper_lim, wpxp_lower_lim, & ! Intent(in) + rhs(:,1) ) ! Intent(out) ! Solve for sclrm / w'sclr' call xm_wpxp_solve( nrhs, & ! Intent(in) @@ -535,7 +562,7 @@ subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & if ( fatal_error( err_code_xm_wpxp ) ) then if ( clubb_at_least_debug_level( 1 ) ) then write(fstderr,*) "Passive scalar # ", i, " LU decomp. failed." - call reportError( err_code_xm_wpxp ) + call report_error( err_code_xm_wpxp ) end if ! Overwrite the current error status with the new fatal error @@ -557,7 +584,7 @@ subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & if ( fatal_error( err_code_xm_wpxp ) ) then if ( clubb_at_least_debug_level( 1 ) ) then write(fstderr,*) "sclrm # ", i, "monotonic flux limiter: tridag failed" - call reportError( err_code_xm_wpxp ) + call report_error( err_code_xm_wpxp ) end if ! Overwrite the current error status with the new fatal error @@ -569,38 +596,35 @@ subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & else ! Simple case, where l_clip_semi_implicit is false - ! This is initialized solely for the purpose of avoiding a compiler - ! warning about uninitialized variables. - dummy_1d = 0._core_rknd - ! Create the lhs once - call xm_wpxp_lhs( l_iter, dt, dummy_1d, a1, a1_zt, wm_zm, wm_zt, & ! Intent(in) + call xm_wpxp_lhs( l_iter, dt, Kh_zm, dummy_1d, a1, a1_zt, wm_zm, wm_zt, & ! Intent(in) wp2, wp3_on_wp2, wp3_on_wp2_zt, & ! Intent(in) - Kw6, tau_zm, C7_Skw_fnc, & ! Intent(in) + Kw6, tau_C6_zm, C7_Skw_fnc, & ! Intent(in) C6rt_Skw_fnc, rho_ds_zm, rho_ds_zt, & ! Intent(in) invrs_rho_ds_zm, invrs_rho_ds_zt, & ! Intent(in) dummy_1d, dummy_1d, l_implemented, & ! Intent(in) + em, Lscale, thlm, & ! Intent(in) lhs ) ! Intent(out) ! Compute the explicit portion of the r_t and w'r_t' equations. ! Build the right-hand side vector. - call xm_wpxp_rhs( xm_wpxp_rtm, l_iter, dt, rtm, wprtp, & ! Intent(in) - rtm_forcing, C7_Skw_fnc, rtpthvp, & ! Intent(in) - C6rt_Skw_fnc, tau_zm, a1, a1_zt, & ! Intent(in) - wp3_on_wp2, wp3_on_wp2_zt, & ! Intent(in) - rho_ds_zt, rho_ds_zm, invrs_rho_ds_zm, & ! Intent(in) - thv_ds_zm, wpxp_upper_lim, wpxp_lower_lim, & ! Intent(in) - rhs(:,1) ) ! Intent(out) + call xm_wpxp_rhs( xm_wpxp_rtm, l_iter, dt, rtm, wprtp, & ! Intent(in) + rtm_forcing, wprtp_forcing, C7_Skw_fnc, & ! Intent(in) + rtpthvp, C6rt_Skw_fnc, tau_C6_zm, a1, a1_zt, & ! Intent(in) + wp3_on_wp2, wp3_on_wp2_zt, rho_ds_zt, & ! Intent(in) + rho_ds_zm, invrs_rho_ds_zm, thv_ds_zm, & ! Intent(in) + wpxp_upper_lim, wpxp_lower_lim, & ! Intent(in) + rhs(:,1) ) ! Intent(out) ! Compute the explicit portion of the th_l and w'th_l' equations. ! Build the right-hand side vector. - call xm_wpxp_rhs( xm_wpxp_thlm, l_iter, dt, thlm, wpthlp, & ! Intent(in) - thlm_forcing, C7_Skw_fnc, thlpthvp, & ! Intent(in) - C6thl_Skw_fnc, tau_zm, a1, a1_zt, & ! Intent(in) - wp3_on_wp2, wp3_on_wp2_zt, & ! Intent(in) - rho_ds_zt, rho_ds_zm, invrs_rho_ds_zm, & ! Intent(in) - thv_ds_zm, wpxp_upper_lim, wpxp_lower_lim, & ! Intent(in) - rhs(:,2) ) ! Intent(out) + call xm_wpxp_rhs( xm_wpxp_thlm, l_iter, dt, thlm, wpthlp, & ! Intent(in) + thlm_forcing, wpthlp_forcing, C7_Skw_fnc, & ! Intent(in) + thlpthvp, C6thl_Skw_fnc, tau_C6_zm, a1, a1_zt, & ! Intent(in) + wp3_on_wp2, wp3_on_wp2_zt, rho_ds_zt, & ! Intent(in) + rho_ds_zm, invrs_rho_ds_zm, thv_ds_zm, & ! Intent(in) + wpxp_upper_lim, wpxp_lower_lim, & ! Intent(in) + rhs(:,2) ) ! Intent(out) ! ---> h1g, 2010-06-15 ! scalar transport, e.g, droplet and ice number concentration @@ -613,12 +637,13 @@ subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & ! <--- h1g, 2010-06-15 call xm_wpxp_rhs( xm_wpxp_scalar, l_iter, dt, sclrm(:,i), wpsclrp(:,i), & ! Intent(in) - sclrm_forcing(:,i), C7_Skw_fnc, sclrpthvp(:,i), & ! Intent(in) - C6rt_Skw_fnc, tau_zm, a1, a1_zt, & ! Intent(in) - wp3_on_wp2, wp3_on_wp2_zt, & ! Intent(in) - rho_ds_zt, rho_ds_zm, invrs_rho_ds_zm, & ! Intent(in) - thv_ds_zm, wpxp_upper_lim, wpxp_lower_lim, & ! Intent(in) - rhs(:,2+i) ) ! Intent(out) + sclrm_forcing(:,i), dummy_1d, C7_Skw_fnc, & ! Intent(in) + sclrpthvp(:,i), C6rt_Skw_fnc, tau_C6_zm, a1, a1_zt, & ! Intent(in) + wp3_on_wp2, wp3_on_wp2_zt, rho_ds_zt, & ! Intent(in) + rho_ds_zm, invrs_rho_ds_zm, thv_ds_zm, & ! Intent(in) + wpxp_upper_lim, wpxp_lower_lim, & ! Intent(in) + rhs(:,2+i) ) ! Intent(out) + enddo ! Solve for all fields @@ -635,7 +660,7 @@ subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & if ( fatal_error( err_code_xm_wpxp ) ) then if ( clubb_at_least_debug_level( 1 ) ) then write(fstderr,'(a)') "xm_wpxp matrix LU decomp. failed" - call reportError( err_code_xm_wpxp ) + call report_error( err_code_xm_wpxp ) end if ! Overwrite the current error status with the new fatal error @@ -656,7 +681,7 @@ subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & if ( fatal_error( err_code_xm_wpxp ) ) then if ( clubb_at_least_debug_level( 1 ) ) then write(fstderr,'(a)') "rtm monotonic flux limiter: tridag failed" - call reportError( err_code_xm_wpxp ) + call report_error( err_code_xm_wpxp ) end if ! Overwrite the current error status with the new fatal error @@ -677,7 +702,7 @@ subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & if ( fatal_error( err_code_xm_wpxp ) ) then if ( clubb_at_least_debug_level( 1 ) ) then write(fstderr,'(a)') "thlm monotonic flux limiter: tridag failed" - call reportError( err_code_xm_wpxp ) + call report_error( err_code_xm_wpxp ) end if ! Overwrite the current error status with the new fatal error @@ -709,7 +734,7 @@ subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & if ( fatal_error( err_code_xm_wpxp ) ) then if ( clubb_at_least_debug_level( 1 ) ) then write(fstderr,*) "sclrm # ", i, "monotonic flux limiter: tridag failed" - call reportError( err_code_xm_wpxp ) + call report_error( err_code_xm_wpxp ) end if ! Overwrite the current error status with the new fatal error @@ -740,14 +765,16 @@ subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & write(fstderr,*) "wp3_on_wp2 = ", wp3_on_wp2 write(fstderr,*) "wp3_on_wp2_zt = ", wp3_on_wp2_zt write(fstderr,*) "Kh_zt = ", Kh_zt - write(fstderr,*) "tau_zm = ", tau_zm + write(fstderr,*) "tau_C6_zm = ", tau_C6_zm write(fstderr,*) "Skw_zm = ", Skw_zm write(fstderr,*) "rtpthvp = ", rtpthvp - write(fstderr,*) "rtm_ref = ", rtm_ref - write(fstderr,*) "thlm_ref = ", thlm_ref write(fstderr,*) "rtm_forcing = ", rtm_forcing + write(fstderr,*) "wprtp_forcing = ", wprtp_forcing + write(fstderr,*) "rtm_ref = ", rtm_ref write(fstderr,*) "thlpthvp = ", thlpthvp write(fstderr,*) "thlm_forcing = ", thlm_forcing + write(fstderr,*) "wpthlp_forcing = ", wpthlp_forcing + write(fstderr,*) "thlm_ref = ", thlm_ref write(fstderr,*) "rho_ds_zm = ", rho_ds_zm write(fstderr,*) "rho_ds_zt = ", rho_ds_zt write(fstderr,*) "invrs_rho_ds_zm = ", invrs_rho_ds_zm @@ -755,11 +782,11 @@ subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & write(fstderr,*) "thv_ds_zm = ", thv_ds_zm write(fstderr,*) "rtp2 = ", rtp2 write(fstderr,*) "thlp2 = ", thlp2 - write(fstderr,*) "pdf_params%w1 = ", pdf_params%w1 - write(fstderr,*) "pdf_params%w2 = ", pdf_params%w2 - write(fstderr,*) "pdf_params%sw1 = ", pdf_params%varnce_w1 - write(fstderr,*) "pdf_params%sw2 = ", pdf_params%varnce_w2 - write(fstderr,*) "pdf_params%mixt_frac = ", pdf_params%mixt_frac + write(fstderr,*) "w_1_zm = ", w_1_zm + write(fstderr,*) "w_2_zm = ", w_2_zm + write(fstderr,*) "varnce_w_1_zm = ", varnce_w_1_zm + write(fstderr,*) "varnce_w_2_zm = ", varnce_w_2_zm + write(fstderr,*) "mixt_frac_zm = ", mixt_frac_zm write(fstderr,*) "l_implemented = ", l_implemented if ( sclr_dim > 0 ) then @@ -784,24 +811,24 @@ subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & if ( rtm_sponge_damp_settings%l_sponge_damping ) then if( l_stats_samp ) then - call stat_begin_update( irtm_sdmp, rtm / real( dt, kind = core_rknd ), zt ) + call stat_begin_update( irtm_sdmp, rtm / dt, stats_zt ) end if rtm(1:gr%nz) = sponge_damp_xm( dt, rtm_ref(1:gr%nz), rtm(1:gr%nz), & rtm_sponge_damp_profile ) if( l_stats_samp ) then - call stat_end_update( irtm_sdmp, rtm / real( dt, kind = core_rknd ), zt ) + call stat_end_update( irtm_sdmp, rtm / dt, stats_zt ) end if endif if ( thlm_sponge_damp_settings%l_sponge_damping ) then if( l_stats_samp ) then - call stat_begin_update( ithlm_sdmp, thlm / real( dt, kind = core_rknd ), zt ) + call stat_begin_update( ithlm_sdmp, thlm / dt, stats_zt ) end if thlm(1:gr%nz) = sponge_damp_xm( dt, thlm_ref(1:gr%nz), thlm(1:gr%nz), & thlm_sponge_damp_profile ) if( l_stats_samp ) then - call stat_end_update( ithlm_sdmp, thlm / real( dt, kind = core_rknd ), zt ) + call stat_end_update( ithlm_sdmp, thlm / dt, stats_zt ) end if endif @@ -810,12 +837,13 @@ subroutine advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & end subroutine advance_xm_wpxp !============================================================================= - subroutine xm_wpxp_lhs( l_iter, dt, wpxp, a1, a1_zt, wm_zm, wm_zt, & + subroutine xm_wpxp_lhs( l_iter, dt, Kh_zm, wpxp, a1, a1_zt, wm_zm, wm_zt, & wp2, wp3_on_wp2, wp3_on_wp2_zt, & - Kw6, tau_zm, C7_Skw_fnc, & + Kw6, tau_C6_zm, C7_Skw_fnc, & C6x_Skw_fnc, rho_ds_zm, rho_ds_zt, & invrs_rho_ds_zm, invrs_rho_ds_zt, & wpxp_upper_lim, wpxp_lower_lim, l_implemented, & + em, Lscale, thlm, & lhs ) ! Description: @@ -832,21 +860,26 @@ subroutine xm_wpxp_lhs( l_iter, dt, wpxp, a1, a1_zt, wm_zm, wm_zt, & use grid_class, only: & gr, & ! Variable(s) - zm2zt ! Procedure(s) + zm2zt, & ! Procedure(s) + ddzt use constants_clubb, only: & - gamma_over_implicit_ts ! Variable(s) + gamma_over_implicit_ts, & ! Constant(s) + one, & + zero use model_flags, only: & l_clip_semi_implicit, & ! Variable(s) - l_upwind_wpxp_ta + l_upwind_wpxp_ta, & + l_diffuse_rtm_and_thlm, & + l_stability_correct_Kh_N2_zm use clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd + core_rknd ! Variable(s) use diffusion, only: & - diffusion_zm_lhs ! Procedure(s) + diffusion_zt_lhs, &! Procedure(s) + diffusion_zm_lhs use mean_adv, only: & term_ma_zt_lhs, & ! Procedure(s) @@ -900,8 +933,9 @@ subroutine xm_wpxp_lhs( l_iter, dt, wpxp, a1, a1_zt, wm_zm, wm_zt, & iwprtp_dp1, & iwprtp_sicl - use advance_helper_module, only: set_boundary_conditions_lhs ! Procedure(s) - + use advance_helper_module, only: & + set_boundary_conditions_lhs, & ! Procedure(s) + calc_stability_correction implicit none @@ -930,20 +964,24 @@ subroutine xm_wpxp_lhs( l_iter, dt, wpxp, a1, a1_zt, wm_zm, wm_zt, & ! Input variables logical, intent(in) :: l_iter - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dt ! Timestep [s] real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & wpxp, & ! w'x' (momentum levels) at timestep (t) [{xm units} m/s] + Kh_zm, & ! Eddy diffusivity on momentum levels [m^2/s] a1, & ! a_1 (momentum levels) [-] a1_zt, & ! a_1 interpolated to thermodynamic levels [-] + Lscale, & ! Turbulent mixing length [m] + em, & ! Turbulent Kinetic Energy (TKE) [m^2/s^2] + thlm, & ! th_l (thermo. levels) [K] wm_zm, & ! w wind component on momentum levels [m/s] wm_zt, & ! w wind component on thermodynamic levels [m/s] wp2, & ! w'^2 (momentum levels) [m^2/s^2] wp3_on_wp2, & ! Smoothed wp3 / wp2 on momentum levels [m/s] wp3_on_wp2_zt, & ! Smoothed wp3 / wp2 on thermo. levels [m/s] Kw6, & ! Coefficient of eddy diffusivity for w'x' [m^2/s] - tau_zm, & ! Time-scale tau on momentum levels [s] + tau_C6_zm, & ! Time-scale tau on momentum levels applied to the C6 term [s] C7_Skw_fnc, & ! C_7 parameter with Sk_w applied [-] C6x_Skw_fnc, & ! C_6x parameter with Sk_w applied [-] rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] @@ -971,9 +1009,28 @@ subroutine xm_wpxp_lhs( l_iter, dt, wpxp, a1, a1_zt, wm_zm, wm_zt, & logical :: l_upper_thresh, l_lower_thresh ! flags for clip_semi_imp_lhs + ! These variables are used to change the amount + ! of diffusion applied towards rtm and thlm. They are only used when + ! l_diffuse_rtm_and_thlm = .true. + real (kind = core_rknd), dimension(gr%nz) :: & + zero_nu, & + Kh_N2_zm + + real (kind = core_rknd) :: & + constant_nu ! controls the magnitude of diffusion + + ! Setting up variables used for diffusion + zero_nu = 0.0_core_rknd + constant_nu = 0.1_core_rknd + + if ( l_stability_correct_Kh_N2_zm ) then + Kh_N2_zm = Kh_zm / calc_stability_correction( thlm, Lscale, em) + else + Kh_N2_zm = Kh_zm + end if ! Initialize the left-hand side matrix to 0. - lhs = 0.0_core_rknd + lhs = zero ! The xm loop runs between k = 2 and k = gr%nz. The value of xm at ! level k = 1, which is below the model surface, is simply set equal to the @@ -987,7 +1044,15 @@ subroutine xm_wpxp_lhs( l_iter, dt, wpxp, a1, a1_zt, wm_zm, wm_zt, & k_xm = 2*k - 1 ! k_wpxp is 2*k - + + if ( l_diffuse_rtm_and_thlm ) then + lhs((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/),k) & + = lhs((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/),k) & + + invrs_rho_ds_zt(k) & + * diffusion_zt_lhs( rho_ds_zm(k) * ( Kh_N2_zm(k) + constant_nu ), & + rho_ds_zm(km1) * ( Kh_N2_zm(km1) + constant_nu ), zero_nu, & + gr%invrs_dzm(km1), gr%invrs_dzm(k), gr%invrs_dzt(k), k ) + end if !!!!!***** xm *****!!!!! @@ -1014,7 +1079,7 @@ subroutine xm_wpxp_lhs( l_iter, dt, wpxp, a1, a1_zt, wm_zm, wm_zt, & else lhs((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/),k_xm) & - = lhs((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/),k_xm) + 0.0_core_rknd + = lhs((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/),k_xm) + zero endif @@ -1026,7 +1091,7 @@ subroutine xm_wpxp_lhs( l_iter, dt, wpxp, a1, a1_zt, wm_zm, wm_zt, & ! LHS time tendency. lhs(t_k_tdiag,k_xm) & - = lhs(t_k_tdiag,k_xm) + 1.0_core_rknd / real( dt, kind = core_rknd ) + = lhs(t_k_tdiag,k_xm) + one / dt if (l_stats_samp) then @@ -1040,9 +1105,9 @@ subroutine xm_wpxp_lhs( l_iter, dt, wpxp, a1, a1_zt, wm_zm, wm_zt, & ztscr02(k) = - tmp(2) ztscr03(k) = - tmp(1) else - ztscr01(k) = 0.0_core_rknd - ztscr02(k) = 0.0_core_rknd - ztscr03(k) = 0.0_core_rknd + ztscr01(k) = zero + ztscr02(k) = zero + ztscr03(k) = zero endif endif @@ -1143,7 +1208,7 @@ subroutine xm_wpxp_lhs( l_iter, dt, wpxp, a1, a1_zt, wm_zm, wm_zt, & lhs(m_k_mdiag,k_wpxp) & = lhs(m_k_mdiag,k_wpxp) & + gamma_over_implicit_ts & - * wpxp_term_pr1_lhs( C6x_Skw_fnc(k), tau_zm(k) ) + * wpxp_term_pr1_lhs( C6x_Skw_fnc(k), tau_C6_zm(k) ) ! LHS eddy diffusion term: dissipation term 1 (dp1). lhs((/m_kp1_mdiag,m_k_mdiag,m_km1_mdiag/),k_wpxp) & @@ -1154,8 +1219,9 @@ subroutine xm_wpxp_lhs( l_iter, dt, wpxp, a1, a1_zt, wm_zm, wm_zt, & ! LHS time tendency. if ( l_iter ) then - lhs(m_k_mdiag,k_wpxp) = lhs(m_k_mdiag,k_wpxp) + 1.0_core_rknd / real(dt, kind = core_rknd) - end if + lhs(m_k_mdiag,k_wpxp) & + = lhs(m_k_mdiag,k_wpxp) + one / dt + endif ! LHS portion of semi-implicit clipping term. if ( l_clip_semi_implicit ) then @@ -1221,7 +1287,7 @@ subroutine xm_wpxp_lhs( l_iter, dt, wpxp, a1, a1_zt, wm_zm, wm_zt, & ! C_7 skewness function input to function wpxp_terms_ac_pr2_lhs. if ( iwprtp_ac > 0 .or. iwpthlp_ac > 0 ) then zmscr09(k) = & - - wpxp_terms_ac_pr2_lhs( 0.0_core_rknd, & + - wpxp_terms_ac_pr2_lhs( zero, & wm_zt(kp1), wm_zt(k), gr%invrs_dzm(k) ) endif @@ -1232,14 +1298,14 @@ subroutine xm_wpxp_lhs( l_iter, dt, wpxp, a1, a1_zt, wm_zm, wm_zt, & if ( iwprtp_pr1 > 0 .or. iwpthlp_pr1 > 0 ) then zmscr10(k) & = - gamma_over_implicit_ts & - * wpxp_term_pr1_lhs( C6x_Skw_fnc(k), tau_zm(k) ) + * wpxp_term_pr1_lhs( C6x_Skw_fnc(k), tau_C6_zm(k) ) endif ! Note: To find the contribution of w'x' term pr2, add 1 to the ! C_7 skewness function input to function wpxp_terms_ac_pr2_lhs. if ( iwprtp_pr2 > 0 .or. iwpthlp_pr2 > 0 ) then zmscr11(k) = & - - wpxp_terms_ac_pr2_lhs( (1.0_core_rknd+C7_Skw_fnc(k)), & + - wpxp_terms_ac_pr2_lhs( (one+C7_Skw_fnc(k)), & wm_zt(kp1), wm_zt(k), gr%invrs_dzm(k) ) endif @@ -1293,11 +1359,44 @@ subroutine xm_wpxp_lhs( l_iter, dt, wpxp, a1, a1_zt, wm_zm, wm_zt, & k_xm = 2*k - 1 k_wpxp_low = 2*k + if ( l_diffuse_rtm_and_thlm ) then + ! xm + lhs(:,k_xm) = 0.0_core_rknd + lhs(t_k_tdiag,k_xm) = 1.0_core_rknd + ! w'x' + lhs(:,k_wpxp) = 0.0_core_rknd + lhs(m_k_mdiag,k_wpxp) = 1.0_core_rknd + + km1 = max( k-1, 1 ) + + lhs((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/),k) & + = lhs((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/),k) & + + invrs_rho_ds_zt(k) & + * diffusion_zt_lhs( rho_ds_zm(k) * ( Kh_N2_zm(k) + constant_nu ), & + rho_ds_zm(km1) * ( Kh_N2_zm(km1) + constant_nu ), zero_nu, & + gr%invrs_dzm(km1), gr%invrs_dzm(k), gr%invrs_dzt(k), k ) + end if + ! Upper boundary k = gr%nz !k_xm is 2*k - 1 k_wpxp_high = 2*k + if ( l_diffuse_rtm_and_thlm ) then + ! w'x' + lhs(:,k_wpxp) = 0.0_core_rknd + lhs(m_k_mdiag,k_wpxp) = 1.0_core_rknd + + km1 = max( k-1, 1 ) + + lhs((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/),k) & + = lhs((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/),k) & + + invrs_rho_ds_zt(k) & + * diffusion_zt_lhs( rho_ds_zm(k) * ( Kh_N2_zm(k) + constant_nu ), & + rho_ds_zm(km1) * ( Kh_N2_zm(km1) + constant_nu ), zero_nu, & + gr%invrs_dzm(km1), gr%invrs_dzm(k), gr%invrs_dzt(k), k ) + end if + call set_boundary_conditions_lhs( m_k_mdiag, k_wpxp_low, k_wpxp_high, lhs, & t_k_tdiag, k_xm) @@ -1307,12 +1406,13 @@ end subroutine xm_wpxp_lhs !============================================================================= subroutine xm_wpxp_rhs( solve_type, l_iter, dt, xm, wpxp, & - xm_forcing, C7_Skw_fnc, xpthvp, & - C6x_Skw_fnc, tau_zm, a1, a1_zt, & - wp3_on_wp2, wp3_on_wp2_zt, & - rho_ds_zt, rho_ds_zm, invrs_rho_ds_zm, & - thv_ds_zm, wpxp_upper_lim, wpxp_lower_lim, & + xm_forcing, wpxp_forcing, C7_Skw_fnc, & + xpthvp, C6x_Skw_fnc, tau_C6_zm, a1, a1_zt, & + wp3_on_wp2, wp3_on_wp2_zt, rho_ds_zt, & + rho_ds_zm, invrs_rho_ds_zm, thv_ds_zm, & + wpxp_upper_lim, wpxp_lower_lim, & rhs ) + ! Description: ! Compute RHS vector for xm and w'x'. ! This subroutine computes the explicit portion of @@ -1325,38 +1425,41 @@ subroutine xm_wpxp_rhs( solve_type, l_iter, dt, xm, wpxp, & gr ! Variable(s) use constants_clubb, only: & - gamma_over_implicit_ts ! Variable(s) + gamma_over_implicit_ts, & ! Constant(s) + one, & + zero use model_flags, only: & l_clip_semi_implicit, & ! Variable(s) l_upwind_wpxp_ta use clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd + core_rknd ! Variable(s) use clip_semi_implicit, only: & clip_semi_imp_rhs ! Procedure(s) - use stats_type, only: & + use stats_type_utilities, only: & stat_update_var_pt, & stat_begin_update_pt use stats_variables, only: & - zt, & ! Variable(s) - zm, & + stats_zt, & ! Variable(s) + stats_zm, & irtm_forcing, & ithlm_forcing, & iwprtp_bp, & - iwprtp_pr3, & + iwprtp_pr3, & iwprtp_sicl, & iwprtp_ta, & iwprtp_pr1, & + iwprtp_forcing, & iwpthlp_bp, & iwpthlp_pr3, & iwpthlp_sicl, & iwpthlp_ta, & iwpthlp_pr1, & + iwpthlp_forcing, & l_stats_samp use advance_helper_module, only: set_boundary_conditions_rhs @@ -1369,17 +1472,18 @@ subroutine xm_wpxp_rhs( solve_type, l_iter, dt, xm, wpxp, & logical, intent(in) :: l_iter - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dt ! Timestep [s] real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & xm, & ! xm (thermodynamic levels) [{xm units}] - wpxp, & ! w'x' (momentum levels) [{xm units} m/s] + wpxp, & ! (momentum levels) [{xm units} m/s] xm_forcing, & ! xm forcings (thermodynamic levels) [{xm units}/s] + wpxp_forcing, & ! forcing (momentum levels) [{xm units} m/s^2] C7_Skw_fnc, & ! C_7 parameter with Sk_w applied [-] xpthvp, & ! x'th_v' (momentum levels) [{xm units} K] C6x_Skw_fnc, & ! C_6x parameter with Sk_w applied [-] - tau_zm, & ! Time-scale tau on momentum levels [s] + tau_C6_zm, & ! Time-scale tau on momentum levels applied to the C6 term [s] a1_zt, & ! a_1 interpolated to thermodynamic levels [-] a1, & ! a_1 [-] wp3_on_wp2, & ! Smoothed wp3 / wp2 on moment. levels [m/s] @@ -1413,7 +1517,8 @@ subroutine xm_wpxp_rhs( solve_type, l_iter, dt, xm, wpxp, & integer :: & ixm_f, & iwpxp_bp, & - iwpxp_pr3, & + iwpxp_pr3, & + iwpxp_f, & iwpxp_sicl, & iwpxp_ta, & iwpxp_pr1 @@ -1427,6 +1532,7 @@ subroutine xm_wpxp_rhs( solve_type, l_iter, dt, xm, wpxp, & ixm_f = irtm_forcing iwpxp_bp = iwprtp_bp iwpxp_pr3 = iwprtp_pr3 + iwpxp_f = iwprtp_forcing iwpxp_sicl = iwprtp_sicl iwpxp_ta = iwprtp_ta iwpxp_pr1 = iwprtp_pr1 @@ -1434,6 +1540,7 @@ subroutine xm_wpxp_rhs( solve_type, l_iter, dt, xm, wpxp, & ixm_f = ithlm_forcing iwpxp_bp = iwpthlp_bp iwpxp_pr3 = iwpthlp_pr3 + iwpxp_f = iwpthlp_forcing iwpxp_sicl = iwpthlp_sicl iwpxp_ta = iwpthlp_ta iwpxp_pr1 = iwpthlp_pr1 @@ -1441,6 +1548,7 @@ subroutine xm_wpxp_rhs( solve_type, l_iter, dt, xm, wpxp, & ixm_f = 0 iwpxp_bp = 0 iwpxp_pr3 = 0 + iwpxp_f = 0 iwpxp_sicl = 0 iwpxp_ta = 0 iwpxp_pr1 = 0 @@ -1448,7 +1556,7 @@ subroutine xm_wpxp_rhs( solve_type, l_iter, dt, xm, wpxp, & ! Initialize the right-hand side vector to 0. - rhs = 0.0_core_rknd + rhs = zero ! The xm loop runs between k = 2 and k = gr%nz. The value of xm at ! level k = 1, which is below the model surface, is simply set equal to the @@ -1467,7 +1575,7 @@ subroutine xm_wpxp_rhs( solve_type, l_iter, dt, xm, wpxp, & ! xm: Right-hand side (explicit xm portion of the code). ! RHS time tendency. - rhs(k_xm) = rhs(k_xm) + xm(k) / real( dt, kind = core_rknd ) + rhs(k_xm) = rhs(k_xm) + xm(k) / dt ! RHS xm forcings. ! Note: xm forcings include the effects of microphysics, @@ -1481,7 +1589,7 @@ subroutine xm_wpxp_rhs( solve_type, l_iter, dt, xm, wpxp, & ! (including microphysics/radiation). ! xm forcings term is completely explicit; call stat_update_var_pt. - call stat_update_var_pt( ixm_f, k, xm_forcing(k), zt ) + call stat_update_var_pt( ixm_f, k, xm_forcing(k), stats_zt ) endif ! l_stats_samp @@ -1514,9 +1622,13 @@ subroutine xm_wpxp_rhs( solve_type, l_iter, dt, xm, wpxp, & ! RHS time tendency. if ( l_iter ) then - rhs(k_wpxp) = rhs(k_wpxp) + wpxp(k) / real( dt, kind = core_rknd ) + rhs(k_wpxp) = rhs(k_wpxp) + wpxp(k) / dt end if + ! RHS forcing. + ! Note: forcing includes the effects of microphysics on . + rhs(k_wpxp) = rhs(k_wpxp) + wpxp_forcing(k) + ! RHS portion of semi-implicit clipping (sicl) term. if ( l_clip_semi_implicit ) then l_upper_thresh = .true. @@ -1564,7 +1676,7 @@ subroutine xm_wpxp_rhs( solve_type, l_iter, dt, xm, wpxp, & rhs(k_wpxp) & = rhs(k_wpxp) & - + ( 1.0_core_rknd - gamma_over_implicit_ts ) & + + ( one - gamma_over_implicit_ts ) & * ( - lhs_fnc_output(1) * wpxp(kp1) & - lhs_fnc_output(2) * wpxp(k) & - lhs_fnc_output(3) * wpxp(km1) ) @@ -1574,10 +1686,10 @@ subroutine xm_wpxp_rhs( solve_type, l_iter, dt, xm, wpxp, & ! ! Note: An "over-implicit" weighted time step is applied to this term. lhs_fnc_output(1) & - = wpxp_term_pr1_lhs( C6x_Skw_fnc(k), tau_zm(k) ) + = wpxp_term_pr1_lhs( C6x_Skw_fnc(k), tau_C6_zm(k) ) rhs(k_wpxp) & = rhs(k_wpxp) & - + ( 1.0_core_rknd - gamma_over_implicit_ts ) & + + ( one - gamma_over_implicit_ts ) & * ( - lhs_fnc_output(1) * wpxp(k) ) @@ -1589,15 +1701,18 @@ subroutine xm_wpxp_rhs( solve_type, l_iter, dt, xm, wpxp, & ! Note: To find the contribution of w'x' term bp, substitute 0 for the ! C_7 skewness function input to function wpxp_terms_bp_pr3_rhs. call stat_update_var_pt( iwpxp_bp, k, & - wpxp_terms_bp_pr3_rhs( 0.0_core_rknd, thv_ds_zm(k), xpthvp(k) ), zm ) + wpxp_terms_bp_pr3_rhs( zero, thv_ds_zm(k), xpthvp(k) ), stats_zm ) ! w'x' term pr3 is completely explicit; call stat_update_var_pt. ! Note: To find the contribution of w'x' term pr3, add 1 to the ! C_7 skewness function input to function wpxp_terms_bp_pr2_rhs. call stat_update_var_pt( iwpxp_pr3, k, & - wpxp_terms_bp_pr3_rhs( (1.0_core_rknd+C7_Skw_fnc(k)), thv_ds_zm(k), & + wpxp_terms_bp_pr3_rhs( (one+C7_Skw_fnc(k)), thv_ds_zm(k), & xpthvp(k) ), & - zm ) + stats_zm ) + + ! w'x' forcing term is completely explicit; call stat_update_var_pt. + call stat_update_var_pt( iwpxp_f, k, wpxp_forcing(k), stats_zm ) ! w'x' term sicl has both implicit and explicit components; call ! stat_begin_update_pt. Since stat_begin_update_pt automatically @@ -1608,7 +1723,7 @@ subroutine xm_wpxp_rhs( solve_type, l_iter, dt, xm, wpxp, & call stat_begin_update_pt( iwpxp_sicl, k, & -clip_semi_imp_rhs( dt, wpxp(k), & l_upper_thresh, wpxp_upper_lim(k), & - l_lower_thresh, wpxp_lower_lim(k) ), zm ) + l_lower_thresh, wpxp_lower_lim(k) ), stats_zm ) endif if ( l_upwind_wpxp_ta ) then ! Use upwind differencing @@ -1638,10 +1753,10 @@ subroutine xm_wpxp_rhs( solve_type, l_iter, dt, xm, wpxp, & endif call stat_begin_update_pt( iwpxp_ta, k, & - - ( 1.0_core_rknd - gamma_over_implicit_ts ) & + - ( one - gamma_over_implicit_ts ) & * ( - lhs_fnc_output(1) * wpxp(kp1) & - lhs_fnc_output(2) * wpxp(k) & - - lhs_fnc_output(3) * wpxp(km1) ), zm ) + - lhs_fnc_output(3) * wpxp(km1) ), stats_zm ) ! w'x' term pr1 is normally completely implicit. However, there is a ! RHS contribution from the "over-implicit" weighted time step. A @@ -1653,10 +1768,10 @@ subroutine xm_wpxp_rhs( solve_type, l_iter, dt, xm, wpxp, & ! automatically subtracts the value sent in, reverse the sign on the ! input value. lhs_fnc_output(1) & - = wpxp_term_pr1_lhs( C6x_Skw_fnc(k), tau_zm(k) ) + = wpxp_term_pr1_lhs( C6x_Skw_fnc(k), tau_C6_zm(k) ) call stat_begin_update_pt( iwpxp_pr1, k, & - - ( 1.0_core_rknd - gamma_over_implicit_ts ) & - * ( - lhs_fnc_output(1) * wpxp(k) ), zm ) + - ( one - gamma_over_implicit_ts ) & + * ( - lhs_fnc_output(1) * wpxp(k) ), stats_zm ) endif ! l_stats_samp @@ -1698,7 +1813,7 @@ subroutine xm_wpxp_rhs( solve_type, l_iter, dt, xm, wpxp, & ! The value of w'x' at the upper boundary will be 0. call set_boundary_conditions_rhs( & - wpxp(1), k_wpxp_low, 0.0_core_rknd, k_wpxp_high, & + wpxp(1), k_wpxp_low, zero, k_wpxp_high, & rhs, & xm(1), k_xm_low ) @@ -1792,8 +1907,7 @@ subroutine xm_wpxp_clipping_and_stats & l_clip_semi_implicit ! Variable(s) use clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd + core_rknd ! Variable(s) use mono_flux_limiter, only: & monotonic_turbulent_flux_limit ! Procedure(s) @@ -1808,21 +1922,23 @@ subroutine xm_wpxp_clipping_and_stats & clip_wpsclrp use model_flags, only: & - l_pos_def, & ! Logical for whether to apply the positive definite scheme to rtm - l_hole_fill, & ! Logical for whether to apply the hole filling scheme to thlm/rtm - l_clip_turb_adv ! Logical for whether to clip xm when wpxp is clipped + l_pos_def, & ! Logical for whether to apply the positive definite scheme to rtm + l_hole_fill, & ! Logical for whether to apply the hole filling scheme to thlm/rtm + l_clip_turb_adv ! Logical for whether to clip xm when wpxp is clipped use constants_clubb, only: & - fstderr ! Standard error i/o unit + fstderr, & ! Constant(s) + one, & + zero use fill_holes, only: & - fill_holes_driver ! Procedure + fill_holes_vertical ! Procedure use error_code, only: & clubb_at_least_debug_level, & ! Procedure(s) clubb_no_error ! Constant - use stats_type, only: & + use stats_type_utilities, only: & stat_begin_update, & ! Procedure(s) stat_update_var_pt, & stat_end_update_pt, & @@ -1831,9 +1947,9 @@ subroutine xm_wpxp_clipping_and_stats & stat_modify use stats_variables, only: & - zt, & ! Variable(s) - zm, & - sfc, & + stats_zt, & ! Variable(s) + stats_zm, & + stats_sfc, & irtm_ta, & irtm_ma, & irtm_matrix_condt_num, & @@ -1849,7 +1965,9 @@ subroutine xm_wpxp_clipping_and_stats & iwprtp_dp1, & iwprtp_pd, & iwprtp_sicl, & - ithlm_ta, & + ithlm_ta + + use stats_variables, only: & ithlm_ma, & ithlm_cl, & ithlm_matrix_condt_num, & @@ -1899,7 +2017,7 @@ subroutine xm_wpxp_clipping_and_stats & integer, intent(in) :: & solve_type ! Variables being solved for. - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dt ! Timestep [s] real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & @@ -2063,7 +2181,7 @@ subroutine xm_wpxp_clipping_and_stats & if ( ixm_matrix_condt_num > 0 ) then ! Est. of the condition number of the mean/flux LHS matrix - call stat_update_var_pt( ixm_matrix_condt_num, 1, 1.0_core_rknd / rcond, sfc ) + call stat_update_var_pt( ixm_matrix_condt_num, 1, one / rcond, stats_sfc ) end if @@ -2083,12 +2201,12 @@ subroutine xm_wpxp_clipping_and_stats & call stat_update_var_pt( ixm_ma, k, & ztscr01(k) * xm(km1) & + ztscr02(k) * xm(k) & - + ztscr03(k) * xm(kp1), zt ) + + ztscr03(k) * xm(kp1), stats_zt ) ! xm term ta is completely implicit; call stat_update_var_pt. call stat_update_var_pt( ixm_ta, k, & ztscr04(k) * wpxp(km1) & - + ztscr05(k) * wpxp(k), zt ) + + ztscr05(k) * wpxp(k), stats_zt ) enddo ! xm loop: 2..gr%nz @@ -2109,7 +2227,7 @@ subroutine xm_wpxp_clipping_and_stats & call stat_update_var_pt( iwpxp_ma, k, & zmscr01(k) * wpxp(km1) & + zmscr02(k) * wpxp(k) & - + zmscr03(k) * wpxp(kp1), zm ) + + zmscr03(k) * wpxp(kp1), stats_zm ) ! if( .not. l_upwind_wpxp_ta ) then ! w'x' term ta is normally completely implicit. However, due to the @@ -2119,40 +2237,40 @@ subroutine xm_wpxp_clipping_and_stats & call stat_end_update_pt( iwpxp_ta, k, & zmscr04(k) * wpxp(km1) & + zmscr05(k) * wpxp(k) & - + zmscr06(k) * wpxp(kp1), zm ) + + zmscr06(k) * wpxp(kp1), stats_zm ) ! endif ! w'x' term tp is completely implicit; call stat_update_var_pt. call stat_update_var_pt( iwpxp_tp, k, & zmscr07(k) * xm(k) & - + zmscr08(k) * xm(kp1), zm ) + + zmscr08(k) * xm(kp1), stats_zm ) ! w'x' term ac is completely implicit; call stat_update_var_pt. call stat_update_var_pt( iwpxp_ac, k, & - zmscr09(k) * wpxp(k), zm ) + zmscr09(k) * wpxp(k), stats_zm ) ! w'x' term pr1 is normally completely implicit. However, due to the ! RHS contribution from the "over-implicit" weighted time step, ! w'x' term pr1 has both implicit and explicit components; ! call stat_end_update_pt. call stat_end_update_pt( iwpxp_pr1, k, & - zmscr10(k) * wpxp(k), zm ) + zmscr10(k) * wpxp(k), stats_zm ) ! w'x' term pr2 is completely implicit; call stat_update_var_pt. call stat_update_var_pt( iwpxp_pr2, k, & - zmscr11(k) * wpxp(k), zm ) + zmscr11(k) * wpxp(k), stats_zm ) ! w'x' term dp1 is completely implicit; call stat_update_var_pt. call stat_update_var_pt( iwpxp_dp1, k, & zmscr12(k) * wpxp(km1) & + zmscr13(k) * wpxp(k) & - + zmscr14(k) * wpxp(kp1), zm ) + + zmscr14(k) * wpxp(kp1), stats_zm ) ! w'x' term sicl has both implicit and explicit components; ! call stat_end_update_pt. if ( l_clip_semi_implicit ) then call stat_end_update_pt( iwpxp_sicl, k, & - zmscr15(k) * wpxp(k), zm ) + zmscr15(k) * wpxp(k), stats_zm ) endif enddo ! wpxp loop: 2..gr%nz-1 @@ -2174,30 +2292,30 @@ subroutine xm_wpxp_clipping_and_stats & ! Apply a flux limiting positive definite scheme if the solution ! for the mean field is negative and we're determining total water - if ( solve_type == xm_wpxp_rtm .and. l_pos_def .and. any( xm < 0.0_core_rknd ) ) then + if ( solve_type == xm_wpxp_rtm .and. l_pos_def .and. any( xm < zero ) ) then call pos_definite_adj( dt, "zt", xm, wpxp, & xm_n, xm_pd, wpxp_pd ) else ! For stats purposes - xm_pd = 0.0_core_rknd - wpxp_pd = 0.0_core_rknd + xm_pd = zero + wpxp_pd = zero end if ! l_pos_def and solve_type == "rtm" and rtm less than 0 if ( l_stats_samp ) then - call stat_update_var( iwpxp_pd, wpxp_pd(1:gr%nz), zm ) + call stat_update_var( iwpxp_pd, wpxp_pd(1:gr%nz), stats_zm ) - call stat_update_var( ixm_pd, xm_pd(1:gr%nz), zt ) + call stat_update_var( ixm_pd, xm_pd(1:gr%nz), stats_zt ) end if ! Computed value before clipping if ( l_stats_samp ) then - call stat_begin_update( ixm_cl, xm / real( dt, kind = core_rknd ), & ! Intent(in) - zt ) ! Intent(inout) + call stat_begin_update( ixm_cl, xm / dt, & ! Intent(in) + stats_zt ) ! Intent(inout) end if if ( any( xm < xm_threshold ) .and. l_hole_fill ) then @@ -2213,22 +2331,22 @@ subroutine xm_wpxp_clipping_and_stats & if ( clubb_at_least_debug_level( 1 ) ) then do k = 1, gr%nz - if ( xm(k) < 0.0_core_rknd ) then + if ( xm(k) < zero ) then write(fstderr,*) solve_type_str//" < ", xm_threshold, & " in advance_xm_wpxp_module at k= ", k end if end do end if - call fill_holes_driver( 2, xm_threshold, "zt", & - rho_ds_zt, rho_ds_zm, & - xm ) + call fill_holes_vertical( 2, xm_threshold, "zt", & + rho_ds_zt, rho_ds_zm, & + xm ) end if ! any( xm < xm_threshold ) .and. l_hole_fill if ( l_stats_samp ) then - call stat_end_update( ixm_cl, xm / real( dt, kind = core_rknd ), & ! Intent(in) - zt ) ! Intent(inout) + call stat_end_update( ixm_cl, xm / dt, & ! Intent(in) + stats_zt ) ! Intent(inout) end if ! Use solve_type to find solve_type_cl, which is used @@ -2279,7 +2397,7 @@ subroutine xm_wpxp_clipping_and_stats & wpxp, wpxp_chnge ) ! In/Out ! Adjusting xm based on clipping for w'x'. - if ( any( wpxp_chnge /= 0.0_core_rknd ) .and. l_clip_turb_adv ) then + if ( any( wpxp_chnge /= zero ) .and. l_clip_turb_adv ) then call xm_correction_wpxp_cl( solve_type, dt, wpxp_chnge, gr%invrs_dzt, & xm ) endif @@ -2287,7 +2405,7 @@ subroutine xm_wpxp_clipping_and_stats & if ( l_stats_samp ) then ! wpxp time tendency - call stat_modify( iwpxp_bt, wpxp / real( dt, kind = core_rknd ), zm ) + call stat_modify( iwpxp_bt, wpxp / dt, stats_zm ) ! Brian Griffin; July 5, 2008. endif @@ -2346,7 +2464,7 @@ pure function xm_term_ta_lhs( rho_ds_zm, rho_ds_zmm1, & !----------------------------------------------------------------------- use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) implicit none @@ -2365,6 +2483,7 @@ pure function xm_term_ta_lhs( rho_ds_zm, rho_ds_zmm1, & ! Return Variable real( kind = core_rknd ), dimension(2) :: lhs + ! Momentum superdiagonal [ x wpxp(k,) ] lhs(k_mdiag) & = + invrs_rho_ds_zt * invrs_dzt * rho_ds_zm @@ -2373,6 +2492,7 @@ pure function xm_term_ta_lhs( rho_ds_zm, rho_ds_zmm1, & lhs(km1_mdiag) & = - invrs_rho_ds_zt * invrs_dzt * rho_ds_zmm1 + return end function xm_term_ta_lhs @@ -2453,7 +2573,7 @@ pure function wpxp_term_ta_lhs( wp3_on_wp2_ztp1, wp3_on_wp2_zt, & !----------------------------------------------------------------------- use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) use grid_class, only: & gr ! Variable; gr%weights_zm2zt @@ -2512,6 +2632,7 @@ pure function wpxp_term_ta_lhs( wp3_on_wp2_ztp1, wp3_on_wp2_zt, & ! sclr'^2 (found in advance_xp2_xpyp_module.F90). Brian. ! if ( l_standard_term_ta ) then + ! Always use the standard discretization for the w'x' turbulent advection ! term. Brian. @@ -2550,6 +2671,7 @@ pure function wpxp_term_ta_lhs( wp3_on_wp2_ztp1, wp3_on_wp2_zt, & * gr%weights_zm2zt(m_below,tk) ! else + ! This discretization very similar to what Brian did for the xp2_ta terms ! and is intended to stabilize the simulation by pulling a1 out of the ! derivative. It didn't seem to work very well. -dschanen 17 Jan 2010 @@ -2582,7 +2704,8 @@ pure function wpxp_term_ta_lhs( wp3_on_wp2_ztp1, wp3_on_wp2_zt, & ! * wp3_on_wp2_zt & ! * gr%weights_zm2zt(m_below,tk) -! end if ! l_standard_term_ta +! endif ! l_standard_term_ta + return end function wpxp_term_ta_lhs @@ -2600,8 +2723,11 @@ pure function wpxp_term_ta_lhs_upwind( a1_zm, a1_zm_p1, a1_zm_m1, & ! References: !----------------------------------------------------------------------- + use constants_clubb, only: & + zero ! Constant(s) + use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) implicit none @@ -2629,28 +2755,34 @@ pure function wpxp_term_ta_lhs_upwind( a1_zm, a1_zm_p1, a1_zm_m1, & ! Return Variable real( kind = core_rknd ), dimension(3) :: lhs - if ( wp3_on_wp2 > 0._core_rknd ) then ! "Wind" is blowing upwards (a1_zm > 0 and wp2 > 0 always) - lhs(kp1_mdiag) = 0.0_core_rknd + + if ( wp3_on_wp2 > zero ) then + + ! "Wind" is blowing upwards (a1_zm > 0 and wp2 > 0 always) + lhs(kp1_mdiag) = zero lhs(k_mdiag) & = + invrs_dzt * invrs_rho_ds_zm & - * rho_ds_zm * a1_zm * wp3_on_wp2 + * rho_ds_zm * a1_zm * wp3_on_wp2 lhs(km1_mdiag) & = - invrs_dzt * invrs_rho_ds_zm & - * rho_ds_zmm1 * a1_zm_m1 * wp3_on_wp2_m1 + * rho_ds_zmm1 * a1_zm_m1 * wp3_on_wp2_m1 else ! "Wind" is blowing downward + lhs(kp1_mdiag) & = + invrs_dztkp1 * invrs_rho_ds_zm & - * rho_ds_zmp1 * a1_zm_p1 * wp3_on_wp2_p1 + * rho_ds_zmp1 * a1_zm_p1 * wp3_on_wp2_p1 lhs(k_mdiag) & = - invrs_dztkp1 * invrs_rho_ds_zm & - * rho_ds_zm * a1_zm * wp3_on_wp2 + * rho_ds_zm * a1_zm * wp3_on_wp2 + + lhs(km1_mdiag) = zero + + endif - lhs(km1_mdiag) = 0.0_core_rknd - end if return end function wpxp_term_ta_lhs_upwind @@ -2701,7 +2833,7 @@ pure function wpxp_term_tp_lhs( wp2, invrs_dzm ) & !----------------------------------------------------------------------- use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) implicit none @@ -2718,6 +2850,7 @@ pure function wpxp_term_tp_lhs( wp2, invrs_dzm ) & ! Return Variable real( kind = core_rknd ), dimension(2) :: lhs + ! Thermodynamic superdiagonal [ x xm(k+1,) ] lhs(kp1_tdiag) & = + wp2 * invrs_dzm @@ -2726,6 +2859,7 @@ pure function wpxp_term_tp_lhs( wp2, invrs_dzm ) & lhs(k_tdiag) & = - wp2 * invrs_dzm + return end function wpxp_term_tp_lhs @@ -2784,8 +2918,11 @@ pure function wpxp_terms_ac_pr2_lhs( C7_Skw_fnc, & ! References: !----------------------------------------------------------------------- + use constants_clubb, only: & + one ! Constant(s) + use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) implicit none @@ -2800,15 +2937,16 @@ pure function wpxp_terms_ac_pr2_lhs( C7_Skw_fnc, & ! Return Variable real( kind = core_rknd ) :: lhs + ! Momentum main diagonal: [ x wpxp(k,) ] - lhs & - = + ( 1.0_core_rknd - C7_Skw_fnc ) * invrs_dzm * ( wm_ztp1 - wm_zt ) + lhs = ( one - C7_Skw_fnc ) * invrs_dzm * ( wm_ztp1 - wm_zt ) + return end function wpxp_terms_ac_pr2_lhs !============================================================================= - pure function wpxp_term_pr1_lhs( C6x_Skw_fnc, tau_zm ) & + pure function wpxp_term_pr1_lhs( C6x_Skw_fnc, tau_C6_zm ) & result( lhs ) ! Description @@ -2838,21 +2976,22 @@ pure function wpxp_term_pr1_lhs( C6x_Skw_fnc, tau_zm ) & !----------------------------------------------------------------------- use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) implicit none ! Input Variables real( kind = core_rknd ), intent(in) :: & - C6x_Skw_fnc, & ! C_6x parameter with Sk_w applied (k) [-] - tau_zm ! Time-scale tau at momentum level (k) [s] + C6x_Skw_fnc, & ! C_6x parameter with Sk_w applied (k) [-] + tau_C6_zm ! Time-scale tau at momentum level (k) applied to C6 term [s] ! Return Variable real( kind = core_rknd ) :: lhs + ! Momentum main diagonal: [ x wpxp(k,) ] - lhs & - = + C6x_Skw_fnc / tau_zm + lhs = C6x_Skw_fnc / tau_C6_zm + return end function wpxp_term_pr1_lhs @@ -2883,10 +3022,11 @@ pure function wpxp_terms_bp_pr3_rhs( C7_Skw_fnc, thv_ds_zm, xpthvp ) & !----------------------------------------------------------------------- use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) - use constants_clubb, only: & ! Variable(s) - grav ! Gravitational acceleration [m/s^2] + use constants_clubb, only: & ! Constants(s) + grav, & ! Gravitational acceleration [m/s^2] + one implicit none @@ -2899,8 +3039,9 @@ pure function wpxp_terms_bp_pr3_rhs( C7_Skw_fnc, thv_ds_zm, xpthvp ) & ! Return Variable real( kind = core_rknd ) :: rhs - rhs & - = ( grav / thv_ds_zm ) * ( 1.0_core_rknd - C7_Skw_fnc ) * xpthvp + + rhs = ( grav / thv_ds_zm ) * ( one - C7_Skw_fnc ) * xpthvp + return end function wpxp_terms_bp_pr3_rhs @@ -3023,15 +3164,14 @@ subroutine xm_correction_wpxp_cl( solve_type, dt, wpxp_chnge, invrs_dzt, & gr ! Variable(s); gr%nz only. use clubb_precision, only: & - time_precision, & - core_rknd + core_rknd ! Variable(s) - use stats_type, only: & + use stats_type_utilities, only: & stat_update_var ! Procedure(s) use stats_variables, only: & l_stats_samp, & ! Variable(s) - zt, & + stats_zt, & ithlm_tacl, & irtm_tacl @@ -3041,7 +3181,7 @@ subroutine xm_correction_wpxp_cl( solve_type, dt, wpxp_chnge, invrs_dzt, & integer, intent(in) :: & solve_type ! Variable that is being solved for. - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dt ! Model timestep [s] real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & @@ -3075,13 +3215,13 @@ subroutine xm_correction_wpxp_cl( solve_type, dt, wpxp_chnge, invrs_dzt, & ! highest. do k = 2, gr%nz, 1 xm_tndcy_wpxp_cl(k) = - invrs_dzt(k) * ( wpxp_chnge(k) - wpxp_chnge(k-1) ) - xm(k) = xm(k) + xm_tndcy_wpxp_cl(k) * real( dt, kind = core_rknd ) + xm(k) = xm(k) + xm_tndcy_wpxp_cl(k) * dt enddo if ( l_stats_samp ) then ! The adjustment to xm due to turbulent advection term clipping ! (xm term tacl) is completely explicit; call stat_update_var. - call stat_update_var( ixm_tacl, xm_tndcy_wpxp_cl, zt ) + call stat_update_var( ixm_tacl, xm_tndcy_wpxp_cl, stats_zt ) endif @@ -3091,16 +3231,19 @@ end subroutine xm_correction_wpxp_cl !============================================================================= - - pure function damp_coefficient( coefficient, Cx_Skw_fnc, max_coeff_value, threshold, Lscale ) & + pure function damp_coefficient( coefficient, Cx_Skw_fnc, max_coeff_value, & + threshold, Lscale ) & result( damped_value ) ! Description: ! Damps a given coefficient linearly based on the value of Lscale. ! For additional information see CLUBB ticket #431. + use constants_clubb, only: & + one_hundred ! Constant(s) + use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) use grid_class, only: & gr ! Variable(s) @@ -3112,6 +3255,7 @@ pure function damp_coefficient( coefficient, Cx_Skw_fnc, max_coeff_value, thresh coefficient, & ! The coefficient to be damped max_coeff_value, & ! Maximum value the damped coefficient should have threshold ! Value of Lscale below which the damping should occur + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & Lscale, & ! Current value of Lscale Cx_Skw_fnc ! Initial skewness function before damping @@ -3119,7 +3263,7 @@ pure function damp_coefficient( coefficient, Cx_Skw_fnc, max_coeff_value, thresh ! Local variables real( kind = core_rknd ), parameter :: & ! Added to prevent large damping at low altitudes where Lscale is small - altitude_threshold = 100.0_core_rknd ! Altitude above which damping should occur + altitude_threshold = one_hundred ! Altitude above which damping should occur ! Return Variable real( kind = core_rknd ), dimension(gr%nz) :: damped_value @@ -3127,7 +3271,9 @@ pure function damp_coefficient( coefficient, Cx_Skw_fnc, max_coeff_value, thresh damped_value = Cx_Skw_fnc where( Lscale < threshold .and. gr%zt > altitude_threshold) - damped_value = max_coeff_value + ( ( coefficient - max_coeff_value ) / threshold ) * Lscale + damped_value = max_coeff_value & + + ( ( coefficient - max_coeff_value ) / threshold ) & + * Lscale end where return diff --git a/models/atm/cam/src/physics/clubb/advance_xp2_xpyp_module.F90 b/models/atm/cam/src/physics/clubb/advance_xp2_xpyp_module.F90 index 90e239ae73bb..e32312ab6f05 100644 --- a/models/atm/cam/src/physics/clubb/advance_xp2_xpyp_module.F90 +++ b/models/atm/cam/src/physics/clubb/advance_xp2_xpyp_module.F90 @@ -1,5 +1,5 @@ !----------------------------------------------------------------------- -! $Id: advance_xp2_xpyp_module.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +! $Id: advance_xp2_xpyp_module.F90 7315 2014-09-30 20:49:54Z schemena@uwm.edu $ !=============================================================================== module advance_xp2_xpyp_module @@ -9,7 +9,8 @@ module advance_xp2_xpyp_module implicit none - public :: advance_xp2_xpyp + public :: advance_xp2_xpyp, & + update_xp2_mc private :: xp2_xpyp_lhs, & xp2_xpyp_solve, & @@ -43,17 +44,16 @@ module advance_xp2_xpyp_module contains !============================================================================= - subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & - thlm, wpthlp, wpthvp, um, vm, & - wp2, wp2_zt, wp3, upwp, vpwp, & - sigma_sqd_w, Skw_zm, Kh_zt, & - rho_ds_zm, rho_ds_zt, & + subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, thlm, & + wpthlp, wpthvp, um, vm, wp2, wp2_zt, & + wp3, upwp, vpwp, sigma_sqd_w, Skw_zm, & + Kh_zt, rtp2_forcing, thlp2_forcing, & + rtpthlp_forcing, rho_ds_zm, rho_ds_zt, & invrs_rho_ds_zm, thv_ds_zm, & Lscale, wp3_on_wp2, wp3_on_wp2_zt, & l_iter, dt, & sclrm, wpsclrp, & - rtp2, thlp2, rtpthlp, & - up2, vp2, & + rtp2, thlp2, rtpthlp, up2, vp2, & err_code, & sclrp2, sclrprtp, sclrpthlp ) @@ -72,11 +72,16 @@ subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & !----------------------------------------------------------------------- use constants_clubb, only: & - w_tol_sqd, & ! Variable(s) + w_tol_sqd, & ! Constant(s) rt_tol, & thl_tol, & w_tol_sqd, & fstderr, & + one, & + two_thirds, & + one_half, & + one_third, & + zero, & zero_threshold use model_flags, only: & @@ -108,26 +113,21 @@ subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & zm2zt ! Procedure(s) use clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd + core_rknd ! Variable(s) use clip_explicit, only: & clip_covar, & ! Procedure(s) clip_variance, & - clip_rtp2, & ! Variable(s) - clip_thlp2, & - clip_rtpthlp, & - clip_up2, & - clip_vp2, & clip_sclrp2, & clip_sclrprtp, & clip_sclrpthlp - use stats_type, only: & + use stats_type_utilities, only: & stat_modify use error_code, only: & clubb_no_error, & ! Variable(s) + clubb_var_out_of_range, & clubb_singular_matrix use error_code, only: & @@ -135,7 +135,7 @@ subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & clubb_at_least_debug_level use stats_variables, only: & - zm, & + stats_zm, & irtp2_cl, & l_stats_samp @@ -154,38 +154,41 @@ subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & l_clip_large_rtp2 = .true. ! Clip rtp2 to be < rtm^2 * coef real( kind = core_rknd ), parameter :: & - rtp2_clip_coef = 0.5_core_rknd ! Coefficient appled the clipping threshold on rtp2 [-] + rtp2_clip_coef = one_half ! Coefficient appled the clipping threshold on rtp2 [-] ! Input variables real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & tau_zm, & ! Time-scale tau on momentum levels [s] wm_zm, & ! w-wind component on momentum levels [m/s] rtm, & ! Total water mixing ratio (t-levs) [kg/kg] - wprtp, & ! w' r_t' (momentum levels) [(m/s)(kg/kg)] + wprtp, & ! (momentum levels) [(m/s)(kg/kg)] thlm, & ! Liquid potential temp. (t-levs) [K] - wpthlp, & ! w' th_l' (momentum levels) [(m K)/s] - wpthvp, & ! w' th_v' (momentum levels) [(m K)/s] + wpthlp, & ! (momentum levels) [(m K)/s] + wpthvp, & ! (momentum levels) [(m K)/s] um, & ! u wind (thermodynamic levels) [m/s] vm, & ! v wind (thermodynamic levels) [m/s] - wp2, & ! w'^2 (momentum levels) [m^2/s^2] - wp2_zt, & ! w'^2 interpolated to thermo. levels [m^2/s^2] - wp3, & ! w'^3 (thermodynamic levels) [m^3/s^3] - upwp, & ! u'w' (momentum levels) [m^2/s^2] - vpwp, & ! v'w' (momentum levels) [m^2/s^2] + wp2, & ! (momentum levels) [m^2/s^2] + wp2_zt, & ! interpolated to thermo. levels [m^2/s^2] + wp3, & ! (thermodynamic levels) [m^3/s^3] + upwp, & ! (momentum levels) [m^2/s^2] + vpwp, & ! (momentum levels) [m^2/s^2] sigma_sqd_w, & ! sigma_sqd_w (momentum levels) [-] Skw_zm, & ! Skewness of w on momentum levels [-] Kh_zt, & ! Eddy diffusivity on thermo. levels [m^2/s] + rtp2_forcing, & ! forcing (momentum levels) [(kg/kg)^2/s] + thlp2_forcing, & ! forcing (momentum levels) [K^2/s] + rtpthlp_forcing, & ! forcing (momentum levels) [(kg/kg)K/s] rho_ds_zm, & ! Dry, static density on momentum levs. [kg/m^3] rho_ds_zt, & ! Dry, static density on thermo. levels [kg/m^3] invrs_rho_ds_zm, & ! Inv. dry, static density @ mom. levs. [m^3/kg] thv_ds_zm, & ! Dry, base-state theta_v on mom. levs. [K] Lscale, & ! Mixing length [m] - wp3_on_wp2, & ! Smoothed version of w'^3 / w'^2 zm [m/s] - wp3_on_wp2_zt ! Smoothed version of w'^3 / w'^2 zt [m/s] + wp3_on_wp2, & ! Smoothed version of / zm [m/s] + wp3_on_wp2_zt ! Smoothed version of / zt [m/s] logical, intent(in) :: l_iter ! Whether variances are prognostic - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dt ! Model timestep [s] ! Passive scalar input @@ -196,11 +199,11 @@ subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & ! An attribute of (inout) is also needed to import the value of the variances ! at the surface. Brian. 12/18/05. real( kind = core_rknd ), intent(inout), dimension(gr%nz) :: & - rtp2, & ! r_t'^2 [(kg/kg)^2] - thlp2, & ! th_l'^2 [K^2] - rtpthlp, & ! r_t' th_l' [(kg K)/kg] - up2, & ! u'^2 [m^2/s^2] - vp2 ! v'^2 [m^2/s^2] + rtp2, & ! [(kg/kg)^2] + thlp2, & ! [K^2] + rtpthlp, & ! [(kg K)/kg] + up2, & ! [m^2/s^2] + vp2 ! [m^2/s^2] ! Output variable for singular matrices integer, intent(inout) :: err_code @@ -218,9 +221,9 @@ subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & a1 ! a_1 (momentum levels); See eqn. 24 in `Equations for CLUBB' [-] real( kind = core_rknd ), dimension(gr%nz) :: & - upwp_zt, & ! u'w' interpolated to thermodynamic levels [m^2/s^2] - vpwp_zt, & ! v'w' interpolated to thermodynamic levels [m^2/s^2] - wpsclrp_zt ! w'sclr' interpolated to thermodynamic levels [m/s {sclrm units}] + upwp_zt, & ! interpolated to thermodynamic levels [m^2/s^2] + vpwp_zt, & ! interpolated to thermodynamic levels [m^2/s^2] + wpsclrp_zt ! interp. to thermo. levels [m/s {sclrm units}] real( kind = core_rknd ) :: & threshold ! Minimum value for variances [units vary] @@ -259,6 +262,11 @@ subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & sclrprtp_chnge, & ! Net change in sclr'r_t' due to clipping [{units vary}] sclrpthlp_chnge ! Net change in sclr'th_l' due to clipping [{units vary}] + real( kind = core_rknd ), dimension(gr%nz) :: & + sclrp2_forcing, & ! forcing (momentum levels) [units vary] + sclrprtp_forcing, & ! forcing (momentum levels) [units vary] + sclrpthlp_forcing ! forcing (momentum levels) [units vary] + logical :: l_scalar_calc, l_first_clip_ts, l_last_clip_ts ! Loop indices @@ -266,10 +274,19 @@ subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & !---------------------------- Begin Code ---------------------------------- + if ( clubb_at_least_debug_level( 2 ) ) then + ! Assertion check for C5 + if ( C5 > one .or. C5 < zero ) then + write(fstderr,*) "The C5 variable is outside the valid range" + err_code = clubb_var_out_of_range + return + end if + end if + if ( l_single_C2_Skw ) then ! Use a single value of C2 for all equations. C2rt_1d(1:gr%nz) & - = C2b + (C2-C2b) *exp( -0.5_core_rknd * (Skw_zm(1:gr%nz)/C2c)**2 ) + = C2b + (C2-C2b) *exp( -one_half * (Skw_zm(1:gr%nz)/C2c)**2 ) C2thl_1d = C2rt_1d C2rtthl_1d = C2rt_1d @@ -285,8 +302,7 @@ subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & end if ! Combine C4 and C14 for simplicity - C4_C14_1d(1:gr%nz) = ( 2.0_core_rknd/3.0_core_rknd * C4 ) + & - ( 1.0_core_rknd/3.0_core_rknd * C14 ) + C4_C14_1d(1:gr%nz) = ( two_thirds * C4 ) + ( one_third * C14 ) ! Are we solving for passive scalars as well? if ( sclr_dim > 0 ) then @@ -299,7 +315,7 @@ subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & ! Define a_1 (located on momentum levels). ! It is a variable that is a function of sigma_sqd_w (where sigma_sqd_w is ! located on the momentum levels). - a1(1:gr%nz) = 1.0_core_rknd / ( 1.0_core_rknd - sigma_sqd_w(1:gr%nz) ) + a1(1:gr%nz) = one / ( one - sigma_sqd_w(1:gr%nz) ) ! Interpolate a_1, w'r_t', w'th_l', u'w', and v'w' from the momentum levels @@ -336,8 +352,7 @@ subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & !!!!!***** r_t'^2 *****!!!!! ! Implicit contributions to term rtp2 - call xp2_xpyp_lhs( dt, l_iter, wp3_on_wp2_zt, & ! Intent(in) - wp3_on_wp2, & ! Intent(in) + call xp2_xpyp_lhs( dt, l_iter, wp3_on_wp2_zt, wp3_on_wp2, & ! Intent(in) a1, a1_zt, tau_zm, wm_zm, Kw2, & ! Intent(in) rho_ds_zt, rho_ds_zm, invrs_rho_ds_zm, & ! Intent(in) C2rt_1d, nu2_vert_res_dep, beta, & ! Intent(in) @@ -345,9 +360,9 @@ subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & call xp2_xpyp_rhs( xp2_xpyp_rtp2, dt, l_iter, a1, a1_zt, & ! Intent(in) - wp2_zt, wprtp, wprtp_zt, & ! Intent(in) - wp3_on_wp2, wp3_on_wp2_zt, & ! Intent(in) - wprtp, wprtp_zt, rtm, rtm, rtp2, & ! Intent(in) + wp2_zt, wprtp, wprtp_zt, wp3_on_wp2, & ! Intent(in) + wp3_on_wp2_zt, wprtp, wprtp_zt, & ! Intent(in) + rtm, rtm, rtp2, rtp2_forcing, & ! Intent(in) rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & ! Intent(in) C2rt_1d, tau_zm, rt_tol**2, beta, & ! Intent(in) rhs ) ! Intent(out) @@ -364,18 +379,17 @@ subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & !!!!!***** th_l'^2 *****!!!!! ! Implicit contributions to term thlp2 - call xp2_xpyp_lhs( dt, l_iter, wp3_on_wp2_zt, & ! Intent(in) - wp3_on_wp2, & ! Intent(in) - a1, a1_zt, tau_zm, wm_zm, Kw2, & ! Intent(in) + call xp2_xpyp_lhs( dt, l_iter, wp3_on_wp2_zt, wp3_on_wp2, & ! Intent(in) + a1, a1_zt, tau_zm, wm_zm, Kw2, & ! Intent(in) rho_ds_zt, rho_ds_zm, invrs_rho_ds_zm, & ! Intent(in) C2thl_1d, nu2_vert_res_dep, beta, & ! Intent(in) lhs ) ! Intent(out) ! Explicit contributions to thlp2 call xp2_xpyp_rhs( xp2_xpyp_thlp2, dt, l_iter, a1, a1_zt, & ! Intent(in) - wp2_zt, wpthlp, wpthlp_zt, & ! Intent(in) - wp3_on_wp2, wp3_on_wp2_zt, & ! Intent(in) - wpthlp, wpthlp_zt, thlm, thlm, thlp2, & ! Intent(in) + wp2_zt, wpthlp, wpthlp_zt, wp3_on_wp2, & ! Intent(in) + wp3_on_wp2_zt, wpthlp, wpthlp_zt, & ! Intent(in) + thlm, thlm, thlp2, thlp2_forcing, & ! Intent(in) rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & ! Intent(in) C2thl_1d, tau_zm, thl_tol**2, beta, & ! Intent(in) rhs ) ! Intent(out) @@ -393,8 +407,7 @@ subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & !!!!!***** r_t'th_l' *****!!!!! ! Implicit contributions to term rtpthlp - call xp2_xpyp_lhs( dt, l_iter, wp3_on_wp2_zt, & ! Intent(in) - wp3_on_wp2, & ! Intent(in) + call xp2_xpyp_lhs( dt, l_iter, wp3_on_wp2_zt, wp3_on_wp2, & ! Intent(in) a1, a1_zt, tau_zm, wm_zm, Kw2, & ! Intent(in) rho_ds_zt, rho_ds_zm, invrs_rho_ds_zm, & ! Intent(in) C2rtthl_1d, nu2_vert_res_dep, beta, & ! Intent(in) @@ -402,9 +415,9 @@ subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & ! Explicit contributions to rtpthlp call xp2_xpyp_rhs( xp2_xpyp_rtpthlp, dt, l_iter, a1, a1_zt, & ! Intent(in) - wp2_zt, wprtp, wprtp_zt, & ! Intent(in) - wp3_on_wp2, wp3_on_wp2_zt, & ! Intent(in) - wpthlp, wpthlp_zt, rtm, thlm, rtpthlp, & ! Intent(in) + wp2_zt, wprtp, wprtp_zt, wp3_on_wp2, & ! Intent(in) + wp3_on_wp2_zt, wpthlp, wpthlp_zt, & ! Intent(in) + rtm, thlm, rtpthlp, rtpthlp_forcing, & ! Intent(in) rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & ! Intent(in) C2rtthl_1d, tau_zm, zero_threshold, beta, & ! Intent(in) rhs ) ! Intent(out) @@ -422,12 +435,11 @@ subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & !!!!!***** u'^2 / v'^2 *****!!!!! ! Implicit contributions to term up2/vp2 - call xp2_xpyp_lhs( dt, l_iter, wp3_on_wp2_zt, & ! Intent(in) - wp3_on_wp2, & ! Intent(in) - a1, a1_zt, tau_zm, wm_zm, Kw9, & ! Intent(in) - rho_ds_zt, rho_ds_zm, invrs_rho_ds_zm, & ! Intent(in) - C4_C14_1d, nu9_vert_res_dep, beta, & ! Intent(in) - lhs ) ! Intent(out) + call xp2_xpyp_lhs( dt, l_iter, wp3_on_wp2_zt, wp3_on_wp2, & ! Intent(in) + a1, a1_zt, tau_zm, wm_zm, Kw9, & ! Intent(in) + rho_ds_zt, rho_ds_zm, invrs_rho_ds_zm, & ! Intent(in) + C4_C14_1d, nu9_vert_res_dep, beta, & ! Intent(in) + lhs ) ! Intent(out) ! Explicit contributions to up2 call xp2_xpyp_uv_rhs( xp2_xpyp_up2, dt, l_iter, a1, a1_zt, wp2, & ! Intent(in) @@ -482,7 +494,7 @@ subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & ! Clipping for r_t'^2 - !threshold = 0.0_core_rknd + !threshold = zero_threshold ! !where ( wp2 >= w_tol_sqd ) & ! threshold = rt_tol*rt_tol @@ -501,7 +513,7 @@ subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & ! This overwrites stats clipping data from clip_variance if ( l_stats_samp ) then - call stat_modify( irtp2_cl, -rtp2 / real( dt, kind = core_rknd ), zm ) + call stat_modify( irtp2_cl, -rtp2 / dt, stats_zm ) endif do k = 1, gr%nz @@ -512,7 +524,7 @@ subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & end do ! k = 1..gr%nz if ( l_stats_samp ) then - call stat_modify( irtp2_cl, rtp2 / real( dt, kind = core_rknd ), zm ) + call stat_modify( irtp2_cl, rtp2 / dt, stats_zm ) endif end if ! l_clip_large_rtp2 @@ -521,7 +533,7 @@ subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & ! Clipping for th_l'^2 - !threshold = 0.0_core_rknd + !threshold = zero_threshold ! !where ( wp2 >= w_tol_sqd ) & ! threshold = thl_tol*thl_tol @@ -534,7 +546,7 @@ subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & ! Clipping for u'^2 - !threshold = 0.0_core_rknd + !threshold = zero_threshold threshold = w_tol_sqd call clip_variance( xp2_xpyp_up2, dt, threshold, & ! Intent(in) @@ -543,7 +555,7 @@ subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & ! Clipping for v'^2 - !threshold = 0.0_core_rknd + !threshold = zero_threshold threshold = w_tol_sqd call clip_variance( xp2_xpyp_vp2, dt, threshold, & ! Intent(in) @@ -569,12 +581,11 @@ subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & !!!!!***** sclr'^2, sclr'r_t', sclr'th_l' *****!!!!! - call xp2_xpyp_lhs( dt, l_iter, wp3_on_wp2_zt, & ! Intent(in) - wp3_on_wp2, & ! Intent(in) - a1, a1_zt, tau_zm, wm_zm, Kw2, & ! Intent(in) - rho_ds_zt, rho_ds_zm, invrs_rho_ds_zm, & ! Intent(in) - C2sclr_1d, nu2_vert_res_dep, beta, & ! Intent(in) - lhs ) ! Intent(out) + call xp2_xpyp_lhs( dt, l_iter, wp3_on_wp2_zt, wp3_on_wp2, & ! Intent(in) + a1, a1_zt, tau_zm, wm_zm, Kw2, & ! Intent(in) + rho_ds_zt, rho_ds_zm, invrs_rho_ds_zm, & ! Intent(in) + C2sclr_1d, nu2_vert_res_dep, beta, & ! Intent(in) + lhs ) ! Intent(out) ! Explicit contributions to passive scalars @@ -586,12 +597,15 @@ subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & ! terms in each equation. wpsclrp_zt = zm2zt( wpsclrp(:,i) ) + ! Forcing for . + sclrp2_forcing = zero + !!!!!***** sclr'^2 *****!!!!! call xp2_xpyp_rhs( xp2_xpyp_sclrp2, dt, l_iter, a1, a1_zt, & ! In - wp2_zt, wpsclrp(:,i), wpsclrp_zt, & ! In - wp3_on_wp2, wp3_on_wp2_zt, & ! In - wpsclrp(:,i), wpsclrp_zt, sclrm(:,i), sclrm(:,i), sclrp2(:,i), & ! In + wp2_zt, wpsclrp(:,i), wpsclrp_zt, wp3_on_wp2, & ! In + wp3_on_wp2_zt, wpsclrp(:,i), wpsclrp_zt, & ! In + sclrm(:,i), sclrm(:,i), sclrp2(:,i), sclrp2_forcing, & ! In rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & ! In C2sclr_1d, tau_zm, sclr_tol(i)**2, beta, & ! In sclr_rhs(:,i) ) ! Out @@ -599,41 +613,47 @@ subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & !!!!!***** sclr'r_t' *****!!!!! if ( i == iisclr_rt ) then - ! In this case we're trying to emulate rt'^2 with sclr'rt', so we - ! handle this as we would a variance, even though generally speaking - ! the scalar is not rt - threshold = rt_tol**2 + ! In this case we're trying to emulate rt'^2 with sclr'rt', so we + ! handle this as we would a variance, even though generally speaking + ! the scalar is not rt + sclrprtp_forcing = rtp2_forcing + threshold = rt_tol**2 else - threshold = 0.0_core_rknd - end if + sclrprtp_forcing = zero + threshold = zero_threshold + endif call xp2_xpyp_rhs( xp2_xpyp_sclrprtp, dt, l_iter, a1, a1_zt, & ! In - wp2_zt, wpsclrp(:,i), wpsclrp_zt, & ! In - wp3_on_wp2, wp3_on_wp2_zt, & ! In - wprtp, wprtp_zt, sclrm(:,i), rtm, sclrprtp(:,i), & ! In + wp2_zt, wpsclrp(:,i), wpsclrp_zt, wp3_on_wp2, & ! In + wp3_on_wp2_zt, wprtp, wprtp_zt, & ! In + sclrm(:,i), rtm, sclrprtp(:,i), sclrprtp_forcing, & ! In rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & ! In C2sclr_1d, tau_zm, threshold, beta, & ! In - sclr_rhs(:,i+sclr_dim) ) ! In + sclr_rhs(:,i+sclr_dim) ) ! Out !!!!!***** sclr'th_l' *****!!!!! if ( i == iisclr_thl ) then - ! In this case we're trying to emulate thl'^2 with sclr'thl', so we - ! handle this as we did with sclr_rt, above. - threshold = thl_tol**2 + ! In this case we're trying to emulate thl'^2 with sclr'thl', so we + ! handle this as we did with sclr_rt, above. + sclrpthlp_forcing = thlp2_forcing + threshold = thl_tol**2 else - threshold = 0.0_core_rknd - end if + sclrpthlp_forcing = zero + threshold = zero_threshold + endif call xp2_xpyp_rhs( xp2_xpyp_sclrpthlp, dt, l_iter, a1, a1_zt, & ! In - wp2_zt, wpsclrp(:,i), wpsclrp_zt, & ! In - wp3_on_wp2, wp3_on_wp2_zt, & ! In - wpthlp, wpthlp_zt, sclrm(:,i), thlm, sclrpthlp(:,i), & ! In + wp2_zt, wpsclrp(:,i), wpsclrp_zt, wp3_on_wp2, & ! In + wp3_on_wp2_zt, wpthlp, wpthlp_zt, & ! In + sclrm(:,i), thlm, sclrpthlp(:,i), sclrpthlp_forcing, & ! In rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & ! In C2sclr_1d, tau_zm, threshold, beta, & ! In sclr_rhs(:,i+2*sclr_dim) ) ! Out - end do ! 1..sclr_dim + + + enddo ! 1..sclr_dim ! Solve the tridiagonal system @@ -673,7 +693,7 @@ subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & ! Clipping for sclr'^2 do i = 1, sclr_dim, 1 -! threshold = 0.0_core_rknd +! threshold = zero_threshold ! ! where ( wp2 >= w_tol_sqd ) & ! threshold = sclr_tol(i)*sclr_tol(i) @@ -764,6 +784,9 @@ subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & write(fstderr,*) "sigma_sqd_w = ", sigma_sqd_w write(fstderr,*) "Skw_zm = ", Skw_zm write(fstderr,*) "Kh_zt = ", Kh_zt + write(fstderr,*) "rtp2_forcing = ", rtp2_forcing + write(fstderr,*) "thlp2_forcing = ", thlp2_forcing + write(fstderr,*) "rtpthlp_forcing = ", rtpthlp_forcing write(fstderr,*) "rho_ds_zm = ", rho_ds_zm write(fstderr,*) "rho_ds_zt = ", rho_ds_zt write(fstderr,*) "invrs_rho_ds_zm = ", invrs_rho_ds_zm @@ -795,8 +818,7 @@ subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & end subroutine advance_xp2_xpyp !============================================================================= - subroutine xp2_xpyp_lhs( dt, l_iter, wp3_on_wp2_zt, & - wp3_on_wp2, & + subroutine xp2_xpyp_lhs( dt, l_iter, wp3_on_wp2_zt, wp3_on_wp2, & a1, a1_zt, tau_zm, wm_zm, Kw, & rho_ds_zt, rho_ds_zm, invrs_rho_ds_zm, & Cn, nu, beta, lhs ) @@ -812,14 +834,15 @@ subroutine xp2_xpyp_lhs( dt, l_iter, wp3_on_wp2_zt, & gr ! Variable(s) use constants_clubb, only: & - gamma_over_implicit_ts ! Constant(s) + gamma_over_implicit_ts, & ! Constant(s) + one, & + zero use model_flags, only: & - l_upwind_xpyp_ta ! Constant(s) + l_upwind_xpyp_ta ! Constant(s) use clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd + core_rknd ! Variable(s) use diffusion, only: & diffusion_zm_lhs ! Procedure(s) @@ -828,34 +851,34 @@ subroutine xp2_xpyp_lhs( dt, l_iter, wp3_on_wp2_zt, & term_ma_zm_lhs ! Procedure(s) use stats_variables, only: & - zmscr01, & - zmscr02, & - zmscr03, & - zmscr04, & - zmscr05, & - zmscr06, & - zmscr07, & - zmscr08, & - zmscr09, & - zmscr10, & - l_stats_samp, & - irtp2_ma, & - irtp2_ta, & - irtp2_dp1, & - irtp2_dp2, & - ithlp2_ma, & - ithlp2_ta, & - ithlp2_dp1, & - ithlp2_dp2, & - irtpthlp_ma, & - irtpthlp_ta, & - irtpthlp_dp1, & - irtpthlp_dp2, & - iup2_ma, & - iup2_ta, & - iup2_dp2, & - ivp2_ma, & - ivp2_ta, & + zmscr01, & + zmscr02, & + zmscr03, & + zmscr04, & + zmscr05, & + zmscr06, & + zmscr07, & + zmscr08, & + zmscr09, & + zmscr10, & + l_stats_samp, & + irtp2_ma, & + irtp2_ta, & + irtp2_dp1, & + irtp2_dp2, & + ithlp2_ma, & + ithlp2_ta, & + ithlp2_dp1, & + ithlp2_dp2, & + irtpthlp_ma, & + irtpthlp_ta, & + irtpthlp_dp1, & + irtpthlp_dp2, & + iup2_ma, & + iup2_ta, & + iup2_dp2, & + ivp2_ma, & + ivp2_ta, & ivp2_dp2 use advance_helper_module, only: set_boundary_conditions_lhs @@ -870,7 +893,7 @@ subroutine xp2_xpyp_lhs( dt, l_iter, wp3_on_wp2_zt, & km1_mdiag = 3 ! Momentum subdiagonal index. ! Input Variables - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dt ! Timestep length [s] logical, intent(in) :: & @@ -907,7 +930,7 @@ subroutine xp2_xpyp_lhs( dt, l_iter, wp3_on_wp2_zt, & tmp ! Initialize LHS matrix to 0. - lhs = 0.0_core_rknd + lhs = zero ! Setup LHS of the tridiagonal system do k = 2, gr%nz-1, 1 @@ -970,7 +993,7 @@ subroutine xp2_xpyp_lhs( dt, l_iter, wp3_on_wp2_zt, & ! LHS time tendency. if ( l_iter ) then - lhs(k_mdiag,k) = lhs(k_mdiag,k) + ( 1.0_core_rknd / real( dt, kind = core_rknd ) ) + lhs(k_mdiag,k) = lhs(k_mdiag,k) + ( one / dt ) endif if ( l_stats_samp ) then @@ -1070,30 +1093,33 @@ subroutine xp2_xpyp_solve( solve_type, nrhs, rhs, lhs, xapxbp, err_code ) ! None !----------------------------------------------------------------------- + use constants_clubb, only: & + one ! Constant(s) + use lapack_wrap, only: & - tridag_solve, & ! Variable(s) - tridag_solvex !, & -! band_solve + tridag_solve, & ! Variable(s) + tridag_solvex !, & +! band_solve use grid_class, only: & - gr ! Variable(s) + gr ! Variable(s) - use stats_type, only: & - stat_update_var_pt ! Procedure(s) + use stats_type_utilities, only: & + stat_update_var_pt ! Procedure(s) use stats_variables, only: & - sfc, & ! Derived type - irtp2_matrix_condt_num, & ! Stat index Variables - ithlp2_matrix_condt_num, & - irtpthlp_matrix_condt_num, & - iup2_vp2_matrix_condt_num, & - l_stats_samp ! Logical + stats_sfc, & ! Derived type + irtp2_matrix_condt_num, & ! Stat index Variables + ithlp2_matrix_condt_num, & + irtpthlp_matrix_condt_num, & + iup2_vp2_matrix_condt_num, & + l_stats_samp ! Logical use error_code, only: & - clubb_no_error ! Constant + clubb_no_error ! Constant use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) implicit none @@ -1167,8 +1193,8 @@ subroutine xp2_xpyp_solve( solve_type, nrhs, rhs, lhs, xapxbp, err_code ) xapxbp(:,1:nrhs), rcond, err_code ) ! Intent(out) ! Est. of the condition number of the variance LHS matrix - call stat_update_var_pt( ixapxbp_matrix_condt_num, 1, 1.0_core_rknd / rcond, & ! Intent(in) - sfc ) ! Intent(inout) + call stat_update_var_pt( ixapxbp_matrix_condt_num, 1, one / rcond, & ! Intent(in) + stats_sfc ) ! Intent(inout) else call tridag_solve & @@ -1194,44 +1220,46 @@ subroutine xp2_xpyp_implicit_stats( solve_type, xapxbp ) use grid_class, only: & gr ! Derived type variable - use stats_type, only: & + use stats_type_utilities, only: & stat_end_update_pt, & ! Procedure(s) stat_update_var_pt - use stats_variables, only: & - zm, & ! Variable(s) - irtp2_dp1, & - irtp2_dp2, & - irtp2_ta, & - irtp2_ma, & - ithlp2_dp1, & - ithlp2_dp2, & - ithlp2_ta, & - ithlp2_ma, & - irtpthlp_dp1, & - irtpthlp_dp2, & - irtpthlp_ta, & - irtpthlp_ma, & - iup2_dp1, & - iup2_dp2, & - iup2_ta, & - iup2_ma, & - iup2_pr1, & - ivp2_dp1, & - ivp2_dp2, & - ivp2_ta, & - ivp2_ma, & - ivp2_pr1, & - zmscr01, & - zmscr02, & - zmscr03, & - zmscr04, & - zmscr05, & - zmscr06, & - zmscr07, & - zmscr08, & - zmscr09, & - zmscr10, & + use stats_variables, only: & + stats_zm, & ! Variable(s) + irtp2_dp1, & + irtp2_dp2, & + irtp2_ta, & + irtp2_ma, & + ithlp2_dp1, & + ithlp2_dp2, & + ithlp2_ta, & + ithlp2_ma, & + irtpthlp_dp1, & + irtpthlp_dp2, & + irtpthlp_ta, & + irtpthlp_ma, & + iup2_dp1, & + iup2_dp2, & + iup2_ta, & + iup2_ma, & + iup2_pr1, & + ivp2_dp1 + + use stats_variables, only: & + ivp2_dp2, & + ivp2_ta, & + ivp2_ma, & + ivp2_pr1, & + zmscr01, & + zmscr02, & + zmscr03, & + zmscr04, & + zmscr05, & + zmscr06, & + zmscr07, & + zmscr08, & + zmscr09, & + zmscr10, & zmscr11 use clubb_precision, only: & @@ -1316,14 +1344,14 @@ subroutine xp2_xpyp_implicit_stats( solve_type, xapxbp ) ! call stat_end_update_pt. call stat_end_update_pt( ixapxbp_dp1, k, & ! Intent(in) zmscr01(k) * xapxbp(k), & ! Intent(in) - zm ) ! Intent(inout) + stats_zm ) ! Intent(inout) ! x'y' term dp2 is completely implicit; call stat_update_var_pt. call stat_update_var_pt( ixapxbp_dp2, k, & ! Intent(in) zmscr02(k) * xapxbp(km1) & ! Intent(in) + zmscr03(k) * xapxbp(k) & + zmscr04(k) * xapxbp(kp1), & - zm ) ! Intent(inout) + stats_zm ) ! Intent(inout) ! x'y' term ta has both implicit and explicit components; ! call stat_end_update_pt. @@ -1331,20 +1359,20 @@ subroutine xp2_xpyp_implicit_stats( solve_type, xapxbp ) zmscr05(k) * xapxbp(km1) & ! Intent(in) + zmscr06(k) * xapxbp(k) & + zmscr07(k) * xapxbp(kp1), & - zm ) ! Intent(inout) + stats_zm ) ! Intent(inout) ! x'y' term ma is completely implicit; call stat_update_var_pt. call stat_update_var_pt( ixapxbp_ma, k, & ! Intent(in) zmscr08(k) * xapxbp(km1) & ! Intent(in) + zmscr09(k) * xapxbp(k) & + zmscr10(k) * xapxbp(kp1), & - zm ) ! Intent(inout) + stats_zm ) ! Intent(inout) ! x'y' term pr1 has both implicit and explicit components; ! call stat_end_update_pt. call stat_end_update_pt( ixapxbp_pr1, k, & ! Intent(in) zmscr11(k) * xapxbp(k), & ! Intent(in) - zm ) ! Intent(inout) + stats_zm ) ! Intent(inout) end do ! k=2..gr%nz-1 @@ -1370,16 +1398,19 @@ subroutine xp2_xpyp_uv_rhs( solve_type, dt, l_iter, a1, a1_zt, wp2, & use constants_clubb, only: & gamma_over_implicit_ts, & ! Constant(s) - w_tol_sqd + w_tol_sqd, & + one, & + two_thirds, & + one_third, & + zero use model_flags, only: & - l_upwind_xpyp_ta ! Constant(s) + l_upwind_xpyp_ta ! Constant(s) use clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd + core_rknd ! Variable(s) - use stats_type, only: & + use stats_type_utilities, only: & stat_begin_update_pt, & ! Procedure(s) stat_update_var_pt, & stat_modify_pt @@ -1395,7 +1426,7 @@ subroutine xp2_xpyp_uv_rhs( solve_type, dt, l_iter, a1, a1_zt, wp2, & iup2_dp1, & iup2_pr1, & iup2_pr2, & - zm, & + stats_zm, & zmscr01, & zmscr11, & l_stats_samp @@ -1405,7 +1436,7 @@ subroutine xp2_xpyp_uv_rhs( solve_type, dt, l_iter, a1, a1_zt, wp2, & ! Input Variables integer, intent(in) :: solve_type - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dt ! Model timestep [s] logical, intent(in) :: & @@ -1493,7 +1524,7 @@ subroutine xp2_xpyp_uv_rhs( solve_type, dt, l_iter, a1, a1_zt, wp2, & ! Initialize RHS vector to 0. - rhs = 0.0_core_rknd + rhs = zero do k = 2, gr%nz-1, 1 @@ -1541,7 +1572,7 @@ subroutine xp2_xpyp_uv_rhs( solve_type, dt, l_iter, a1, a1_zt, wp2, & rhs(k,1) & = rhs(k,1) & - + ( 1.0_core_rknd - gamma_over_implicit_ts ) & + + ( one - gamma_over_implicit_ts ) & * ( - lhs_fnc_output(1) * xap2(kp1) & - lhs_fnc_output(2) * xap2(k) & - lhs_fnc_output(3) * xap2(km1) ) @@ -1549,7 +1580,7 @@ subroutine xp2_xpyp_uv_rhs( solve_type, dt, l_iter, a1, a1_zt, wp2, & ! RHS turbulent production (tp) term. rhs(k,1) & = rhs(k,1) & - + (1.0_core_rknd - C5) & + + ( one - C5 ) & * term_tp( xam(kp1), xam(k), xam(kp1), xam(k), & wpxap(k), wpxap(k), gr%invrs_dzm(k) ) @@ -1566,7 +1597,7 @@ subroutine xp2_xpyp_uv_rhs( solve_type, dt, l_iter, a1, a1_zt, wp2, & = term_dp1_lhs( C4_C14_1d(k), tau_zm(k) ) rhs(k,1) & = rhs(k,1) & - + ( 1.0_core_rknd - gamma_over_implicit_ts ) & + + ( one - gamma_over_implicit_ts ) & * ( - lhs_fnc_output(1) * xap2(k) ) ! RHS pressure term 2 (pr2). @@ -1578,7 +1609,7 @@ subroutine xp2_xpyp_uv_rhs( solve_type, dt, l_iter, a1, a1_zt, wp2, & ! RHS time tendency. if ( l_iter ) then - rhs(k,1) = rhs(k,1) + 1.0_core_rknd/real( dt, kind = core_rknd ) * xap2(k) + rhs(k,1) = rhs(k,1) + one/dt * xap2(k) endif if ( l_stats_samp ) then @@ -1594,7 +1625,7 @@ subroutine xp2_xpyp_uv_rhs( solve_type, dt, l_iter, a1, a1_zt, wp2, & rho_ds_zt(kp1), rho_ds_zt(k), invrs_rho_ds_zm(k), & a1_zt(kp1), a1(k), a1_zt(k), wpxbp_zt(kp1), wpxbp_zt(k), & wpxap_zt(kp1), wpxap_zt(k), gr%invrs_dzm(k), beta ), & - zm ) ! Intent(inout) + stats_zm ) ! Intent(inout) ! Note: An "over-implicit" weighted time step is applied to this term. ! A weighting factor of greater than 1 may be used to make the @@ -1615,11 +1646,11 @@ subroutine xp2_xpyp_uv_rhs( solve_type, dt, l_iter, a1, a1_zt, wp2, & end if ! ~l_upwind_xpyp_ta call stat_modify_pt( ixapxbp_ta, k, & ! Intent(in) - + ( 1.0_core_rknd - gamma_over_implicit_ts ) & ! Intent(in) + + ( one - gamma_over_implicit_ts ) & ! Intent(in) * ( - lhs_fnc_output(1) * xap2(kp1) & - lhs_fnc_output(2) * xap2(k) & - lhs_fnc_output(3) * xap2(km1) ), & - zm ) ! Intent(inout) + stats_zm ) ! Intent(inout) if ( ixapxbp_dp1 > 0 ) then ! Note: The function term_pr1 is the explicit component of a @@ -1635,7 +1666,7 @@ subroutine xp2_xpyp_uv_rhs( solve_type, dt, l_iter, a1, a1_zt, wp2, & ! RHS turbulent advection (ta) term). tmp & = gamma_over_implicit_ts & - * term_dp1_lhs( (2.0_core_rknd/3.0_core_rknd)*C4, tau_zm(k) ) + * term_dp1_lhs( two_thirds*C4, tau_zm(k) ) zmscr01(k) = -tmp ! Statistical contribution of the explicit component of term dp1 for ! up2 or vp2. @@ -1645,19 +1676,19 @@ subroutine xp2_xpyp_uv_rhs( solve_type, dt, l_iter, a1, a1_zt, wp2, & ! Note: To find the contribution of x'y' term dp1, substitute 0 for ! the C_14 input to function term_pr1. call stat_begin_update_pt( ixapxbp_dp1, k, & ! Intent(in) - -term_pr1( C4, 0.0_core_rknd, xbp2(k), wp2(k), tau_zm(k) ), & ! Intent(in) - zm ) ! Intent(inout) + -term_pr1( C4, zero, xbp2(k), wp2(k), tau_zm(k) ), & ! Intent(in) + stats_zm ) ! Intent(inout) ! Note: An "over-implicit" weighted time step is applied to this ! term. A weighting factor of greater than 1 may be used to ! make the term more numerically stable (see note above for ! RHS turbulent advection (ta) term). lhs_fnc_output(1) & - = term_dp1_lhs( (2.0_core_rknd/3.0_core_rknd)*C4, tau_zm(k) ) + = term_dp1_lhs( two_thirds*C4, tau_zm(k) ) call stat_modify_pt( ixapxbp_dp1, k, & ! Intent(in) - + ( 1.0_core_rknd - gamma_over_implicit_ts ) & ! Intent(in) + + ( one - gamma_over_implicit_ts ) & ! Intent(in) * ( - lhs_fnc_output(1) * xap2(k) ), & ! Intent(in) - zm ) ! Intent(inout) + stats_zm ) ! Intent(inout) endif @@ -1674,7 +1705,7 @@ subroutine xp2_xpyp_uv_rhs( solve_type, dt, l_iter, a1, a1_zt, wp2, & ! RHS turbulent advection (ta) term). tmp & = gamma_over_implicit_ts & - * term_dp1_lhs( (1.0_core_rknd/3.0_core_rknd)*C14, tau_zm(k) ) + * term_dp1_lhs( one_third*C14, tau_zm(k) ) zmscr11(k) = -tmp ! Statistical contribution of the explicit component of term pr1 for ! up2 or vp2. @@ -1684,19 +1715,19 @@ subroutine xp2_xpyp_uv_rhs( solve_type, dt, l_iter, a1, a1_zt, wp2, & ! Note: To find the contribution of x'y' term pr1, substitute 0 for ! the C_4 input to function term_pr1. call stat_begin_update_pt( ixapxbp_pr1, k, & ! Intent(in) - -term_pr1( 0.0_core_rknd, C14, xbp2(k), wp2(k), tau_zm(k) ), & ! Intent(in) - zm ) ! Intent(inout) + -term_pr1( zero, C14, xbp2(k), wp2(k), tau_zm(k) ), & ! Intent(in) + stats_zm ) ! Intent(inout) ! Note: An "over-implicit" weighted time step is applied to this ! term. A weighting factor of greater than 1 may be used to ! make the term more numerically stable (see note above for ! RHS turbulent advection (ta) term). lhs_fnc_output(1) & - = term_dp1_lhs( (1.0_core_rknd/3.0_core_rknd)*C14, tau_zm(k) ) + = term_dp1_lhs( one_third*C14, tau_zm(k) ) call stat_modify_pt( ixapxbp_pr1, k, & ! Intent(in) - + ( 1.0_core_rknd - gamma_over_implicit_ts ) & ! Intent(in) + + ( one - gamma_over_implicit_ts ) & ! Intent(in) * ( - lhs_fnc_output(1) * xap2(k) ), & ! Intent(in) - zm ) ! Intent(inout) + stats_zm ) ! Intent(inout) endif @@ -1705,14 +1736,14 @@ subroutine xp2_xpyp_uv_rhs( solve_type, dt, l_iter, a1, a1_zt, wp2, & term_pr2( C5, thv_ds_zm(k), wpthvp(k), wpxap(k), wpxbp(k), & ! Intent(in) xam, xbm, gr%invrs_dzm(k), kp1, k, & Lscale(kp1), Lscale(k), wp2_zt(kp1), wp2_zt(k) ), & - zm ) ! Intent(inout) + stats_zm ) ! Intent(inout) ! x'y' term tp is completely explicit; call stat_update_var_pt. call stat_update_var_pt( ixapxbp_tp, k, & ! Intent(in) - (1.0_core_rknd - C5) & ! Intent(in) + ( one - C5 ) & ! Intent(in) * term_tp( xam(kp1), xam(k), xam(kp1), xam(k), & wpxap(k), wpxap(k), gr%invrs_dzm(k) ), & - zm ) ! Intent(inout) + stats_zm ) ! Intent(inout) endif ! l_stats_samp @@ -1735,9 +1766,9 @@ end subroutine xp2_xpyp_uv_rhs !============================================================================= subroutine xp2_xpyp_rhs( solve_type, dt, l_iter, a1, a1_zt, & - wp2_zt, wpxap, wpxap_zt, & - wp3_on_wp2, wp3_on_wp2_zt, & - wpxbp, wpxbp_zt, xam, xbm, xapxbp, & + wp2_zt, wpxap, wpxap_zt, wp3_on_wp2, & + wp3_on_wp2_zt, wpxbp, wpxbp_zt, & + xam, xbm, xapxbp, xapxbp_forcing, & rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & Cn, tau_zm, threshold, beta, & rhs ) @@ -1751,32 +1782,36 @@ subroutine xp2_xpyp_rhs( solve_type, dt, l_iter, a1, a1_zt, & gr ! Variable(s) use constants_clubb, only: & - gamma_over_implicit_ts ! Variable(s) + gamma_over_implicit_ts, & ! Constant(s) + one, & + zero use model_flags, only: & - l_upwind_xpyp_ta ! Constant(s) + l_upwind_xpyp_ta ! Constant(s) use clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd + core_rknd ! Variable(s) - use stats_type, only: & + use stats_type_utilities, only: & stat_begin_update_pt, & ! Procedure(s) stat_update_var_pt, & stat_modify_pt use stats_variables, only: & - irtp2_ta, & ! Variable(s) - irtp2_tp, & - irtp2_dp1, & - ithlp2_ta, & - ithlp2_tp, & - ithlp2_dp1, & - irtpthlp_ta, & - irtpthlp_tp1, & - irtpthlp_tp2, & - irtpthlp_dp1, & - zm, & + irtp2_ta, & ! Variable(s) + irtp2_tp, & + irtp2_dp1, & + irtp2_forcing, & + ithlp2_ta, & + ithlp2_tp, & + ithlp2_dp1, & + ithlp2_forcing, & + irtpthlp_ta, & + irtpthlp_tp1, & + irtpthlp_tp2, & + irtpthlp_dp1, & + irtpthlp_forcing, & + stats_zm, & l_stats_samp use advance_helper_module, only: set_boundary_conditions_rhs @@ -1786,7 +1821,7 @@ subroutine xp2_xpyp_rhs( solve_type, dt, l_iter, a1, a1_zt, & ! Input Variables integer, intent(in) :: solve_type - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dt ! Model timestep [s] logical, intent(in) :: & @@ -1805,6 +1840,7 @@ subroutine xp2_xpyp_rhs( solve_type, dt, l_iter, a1, a1_zt, & xam, & ! x_am (thermodynamic levels) [{x_am units}] xbm, & ! x_bm (thermodynamic levels) [{x_bm units}] xapxbp, & ! x_a'x_b' (momentum levels) [{x_am units}*{x_bm units}] + xapxbp_forcing, & ! x_a'x_b' forcing (momentum levels) [{x_am units}*{x_bm units}/s] rho_ds_zm, & ! Dry, static density on moment. levels [kg/m^3] rho_ds_zt, & ! Dry, static density on thermo. levels [kg/m^3] invrs_rho_ds_zm, & ! Inv. dry, static density on momentum levs. [m^3/kg] @@ -1839,7 +1875,8 @@ subroutine xp2_xpyp_rhs( solve_type, dt, l_iter, a1, a1_zt, & ixapxbp_tp, & ixapxbp_tp1, & ixapxbp_tp2, & - ixapxbp_dp1 + ixapxbp_dp1, & + ixapxbp_f !------------------------------ Begin Code --------------------------------- @@ -1850,29 +1887,33 @@ subroutine xp2_xpyp_rhs( solve_type, dt, l_iter, a1, a1_zt, & ixapxbp_tp1 = 0 ixapxbp_tp2 = 0 ixapxbp_dp1 = irtp2_dp1 + ixapxbp_f = irtp2_forcing case ( xp2_xpyp_thlp2 ) ixapxbp_ta = ithlp2_ta ixapxbp_tp = ithlp2_tp ixapxbp_tp1 = 0 ixapxbp_tp2 = 0 ixapxbp_dp1 = ithlp2_dp1 + ixapxbp_f = ithlp2_forcing case ( xp2_xpyp_rtpthlp ) ixapxbp_ta = irtpthlp_ta ixapxbp_tp = 0 ixapxbp_tp1 = irtpthlp_tp1 ixapxbp_tp2 = irtpthlp_tp2 ixapxbp_dp1 = irtpthlp_dp1 + ixapxbp_f = irtpthlp_forcing case default ! No budgets for passive scalars ixapxbp_ta = 0 ixapxbp_tp = 0 ixapxbp_tp1 = 0 ixapxbp_tp2 = 0 ixapxbp_dp1 = 0 + ixapxbp_f = 0 end select ! Initialize RHS vector to 0. - rhs = 0.0_core_rknd + rhs = zero do k = 2, gr%nz-1, 1 @@ -1916,11 +1957,11 @@ subroutine xp2_xpyp_rhs( solve_type, dt, l_iter, a1, a1_zt, & gr%invrs_dzt(k), gr%invrs_dzt(kp1), & invrs_rho_ds_zm(k), & rho_ds_zm(kp1), rho_ds_zm(k), rho_ds_zm(km1), beta ) - end if + endif rhs(k,1) & = rhs(k,1) & - + ( 1.0_core_rknd - gamma_over_implicit_ts ) & + + ( one - gamma_over_implicit_ts ) & * ( - lhs_fnc_output(1) * xapxbp(kp1) & - lhs_fnc_output(2) * xapxbp(k) & - lhs_fnc_output(3) * xapxbp(km1) ) @@ -1943,14 +1984,19 @@ subroutine xp2_xpyp_rhs( solve_type, dt, l_iter, a1, a1_zt, & = term_dp1_lhs( Cn(k), tau_zm(k) ) rhs(k,1) & = rhs(k,1) & - + ( 1.0_core_rknd - gamma_over_implicit_ts ) & + + ( one - gamma_over_implicit_ts ) & * ( - lhs_fnc_output(1) * xapxbp(k) ) ! RHS time tendency. if ( l_iter ) then - rhs(k,1) = rhs(k,1) + 1.0_core_rknd/real( dt, kind = core_rknd ) * xapxbp(k) + rhs(k,1) = rhs(k,1) + one/dt * xapxbp(k) endif + ! RHS forcing. + ! Note: forcing includes the effects of microphysics on . + rhs(k,1) = rhs(k,1) + xapxbp_forcing(k) + + if ( l_stats_samp ) then ! Statistics: explicit contributions for rtp2, thlp2, or rtpthlp. @@ -1964,7 +2010,7 @@ subroutine xp2_xpyp_rhs( solve_type, dt, l_iter, a1, a1_zt, & rho_ds_zt(kp1), rho_ds_zt(k), invrs_rho_ds_zm(k), & a1_zt(kp1), a1(k), a1_zt(k), wpxbp_zt(kp1), wpxbp_zt(k), & wpxap_zt(kp1), wpxap_zt(k), gr%invrs_dzm(k), beta ), & - zm ) ! Intent(inout) + stats_zm ) ! Intent(inout) ! Note: An "over-implicit" weighted time step is applied to this term. ! A weighting factor of greater than 1 may be used to make the @@ -1984,18 +2030,18 @@ subroutine xp2_xpyp_rhs( solve_type, dt, l_iter, a1, a1_zt, & rho_ds_zm(kp1), rho_ds_zm(k), rho_ds_zm(km1), beta ) end if call stat_modify_pt( ixapxbp_ta, k, & ! Intent(in) - + ( 1.0_core_rknd - gamma_over_implicit_ts ) & ! Intent(in) + + ( one - gamma_over_implicit_ts ) & ! Intent(in) * ( - lhs_fnc_output(1) * xapxbp(kp1) & - lhs_fnc_output(2) * xapxbp(k) & - lhs_fnc_output(3) * xapxbp(km1) ), & - zm ) ! Intent(inout) + stats_zm ) ! Intent(inout) ! x'y' term dp1 has both implicit and explicit components; call ! stat_begin_update_pt. Since stat_begin_update_pt automatically ! subtracts the value sent in, reverse the sign on term_dp1_rhs. call stat_begin_update_pt( ixapxbp_dp1, k, & ! Intent(in) -term_dp1_rhs( Cn(k), tau_zm(k), threshold ), & ! Intent(in) - zm ) ! Intent(inout) + stats_zm ) ! Intent(inout) ! Note: An "over-implicit" weighted time step is applied to this term. ! A weighting factor of greater than 1 may be used to make the @@ -2004,33 +2050,36 @@ subroutine xp2_xpyp_rhs( solve_type, dt, l_iter, a1, a1_zt, & lhs_fnc_output(1) & = term_dp1_lhs( Cn(k), tau_zm(k) ) call stat_modify_pt( ixapxbp_dp1, k, & ! Intent(in) - + ( 1.0_core_rknd - gamma_over_implicit_ts ) & ! Intent(in) + + ( one - gamma_over_implicit_ts ) & ! Intent(in) * ( - lhs_fnc_output(1) * xapxbp(k) ), & ! Intent(in) - zm ) ! Intent(inout) + stats_zm ) ! Intent(inout) ! rtp2/thlp2 case (1 turbulent production term) ! x'y' term tp is completely explicit; call stat_update_var_pt. call stat_update_var_pt( ixapxbp_tp, k, & ! Intent(in) term_tp( xam(kp1), xam(k), xbm(kp1), xbm(k), & ! Intent(in) wpxbp(k), wpxap(k), gr%invrs_dzm(k) ), & - zm ) ! Intent(inout) + stats_zm ) ! Intent(inout) ! rtpthlp case (2 turbulent production terms) ! x'y' term tp1 is completely explicit; call stat_update_var_pt. ! Note: To find the contribution of x'y' term tp1, substitute 0 for all ! the xam inputs and the wpxbp input to function term_tp. call stat_update_var_pt( ixapxbp_tp1, k, & ! Intent(in) - term_tp( 0.0_core_rknd, 0.0_core_rknd, xbm(kp1), xbm(k), & ! Intent(in) - 0.0_core_rknd, wpxap(k), gr%invrs_dzm(k) ), & - zm ) ! Intent(inout) + term_tp( zero, zero, xbm(kp1), xbm(k), & ! Intent(in) + zero, wpxap(k), gr%invrs_dzm(k) ), & + stats_zm ) ! Intent(inout) ! x'y' term tp2 is completely explicit; call stat_update_var_pt. ! Note: To find the contribution of x'y' term tp2, substitute 0 for all ! the xbm inputs and the wpxap input to function term_tp. call stat_update_var_pt( ixapxbp_tp2, k, & ! Intent(in) - term_tp( xam(kp1), xam(k), 0.0_core_rknd, 0.0_core_rknd, & ! Intent(in) - wpxbp(k), 0.0_core_rknd, gr%invrs_dzm(k) ), & - zm ) ! Intent(inout) + term_tp( xam(kp1), xam(k), zero, zero, & ! Intent(in) + wpxbp(k), zero, gr%invrs_dzm(k) ), & + stats_zm ) ! Intent(inout) + + ! x'y' forcing term is completely explicit; call stat_update_var_pt. + call stat_update_var_pt( ixapxbp_f, k, xapxbp_forcing(k), stats_zm ) endif ! l_stats_samp @@ -2149,11 +2198,14 @@ pure function term_ta_lhs( wp3_on_wp2_ztp1, wp3_on_wp2_zt, & use grid_class, only: & ! gr%weights_zm2zt gr ! Variable(s) + use constants_clubb, only: & + one_third ! Constant(s) + use model_flags, only: & l_standard_term_ta use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) implicit none @@ -2211,7 +2263,7 @@ pure function term_ta_lhs( wp3_on_wp2_ztp1, wp3_on_wp2_zt, & ! Momentum superdiagonal: [ x xapxbp(k+1,) ] lhs(kp1_mdiag) & - = + (1.0_core_rknd/3.0_core_rknd) * beta & + = + one_third * beta & * invrs_rho_ds_zm & * invrs_dzm & * rho_ds_ztp1 * a1_ztp1 & @@ -2220,7 +2272,7 @@ pure function term_ta_lhs( wp3_on_wp2_ztp1, wp3_on_wp2_zt, & ! Momentum main diagonal: [ x xapxbp(k,) ] lhs(k_mdiag) & - = + (1.0_core_rknd/3.0_core_rknd) * beta & + = + one_third * beta & * invrs_rho_ds_zm & * invrs_dzm & * ( rho_ds_ztp1 * a1_ztp1 & @@ -2233,7 +2285,7 @@ pure function term_ta_lhs( wp3_on_wp2_ztp1, wp3_on_wp2_zt, & ! Momentum subdiagonal: [ x xapxbp(k-1,) ] lhs(km1_mdiag) & - = - (1.0_core_rknd/3.0_core_rknd) * beta & + = - one_third * beta & * invrs_rho_ds_zm & * invrs_dzm & * rho_ds_zt * a1_zt & @@ -2251,7 +2303,7 @@ pure function term_ta_lhs( wp3_on_wp2_ztp1, wp3_on_wp2_zt, & ! Momentum superdiagonal: [ x xapxbp(k+1,) ] lhs(kp1_mdiag) & - = + (1.0_core_rknd/3.0_core_rknd) * beta & + = + one_third * beta & * invrs_rho_ds_zm * a1 & * invrs_dzm & * rho_ds_ztp1 & @@ -2260,7 +2312,7 @@ pure function term_ta_lhs( wp3_on_wp2_ztp1, wp3_on_wp2_zt, & ! Momentum main diagonal: [ x xapxbp(k,) ] lhs(k_mdiag) & - = + (1.0_core_rknd/3.0_core_rknd) * beta & + = + one_third * beta & * invrs_rho_ds_zm * a1 & * invrs_dzm & * ( rho_ds_ztp1 & @@ -2273,7 +2325,7 @@ pure function term_ta_lhs( wp3_on_wp2_ztp1, wp3_on_wp2_zt, & ! Momentum subdiagonal: [ x xapxbp(k-1,) ] lhs(km1_mdiag) & - = - (1.0_core_rknd/3.0_core_rknd) * beta & + = - one_third * beta & * invrs_rho_ds_zm * a1 & * invrs_dzm & * rho_ds_zt & @@ -2303,8 +2355,12 @@ pure function term_ta_lhs_upwind( a1_zm, a1_zm_p1, a1_zm_m1, & ! None !----------------------------------------------------------------------------- + use constants_clubb, only: & + one_third, & ! Constant(s) + zero + use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) implicit none @@ -2334,20 +2390,20 @@ pure function term_ta_lhs_upwind( a1_zm, a1_zm_p1, a1_zm_m1, & real( kind = core_rknd ), dimension(3) :: lhs - if ( wp3_on_wp2 > 0._core_rknd ) then + if ( wp3_on_wp2 > zero ) then ! Momentum main diagonal: [ x xapxbp(k+1,) ] - lhs(kp1_mdiag) = 0._core_rknd + lhs(kp1_mdiag) = zero ! Momentum main diagonal: [ x xapxbp(k,) ] lhs(k_mdiag) & - = + (1.0_core_rknd/3.0_core_rknd) * beta & + = + one_third * beta & * invrs_dzt * invrs_rho_ds_zm & * rho_ds_zm * a1_zm * wp3_on_wp2 ! Momentum subdiagonal: [ x xapxbp(k-1,) ] lhs(km1_mdiag) & - = - (1.0_core_rknd/3.0_core_rknd) * beta & + = - one_third * beta & * invrs_dzt * invrs_rho_ds_zm & * rho_ds_zm_m1 * a1_zm_m1 * wp3_on_wp2_m1 @@ -2355,18 +2411,18 @@ pure function term_ta_lhs_upwind( a1_zm, a1_zm_p1, a1_zm_m1, & ! Momentum main diagonal: [ x xapxbp(k+1,) ] lhs(kp1_mdiag) & - = + (1.0_core_rknd/3.0_core_rknd) * beta & + = + one_third * beta & * invrs_dzt_p1 * invrs_rho_ds_zm & * rho_ds_zm_p1 * a1_zm_p1 * wp3_on_wp2_p1 ! Momentum main diagonal: [ x xapxbp(k,) ] lhs(k_mdiag) & - = - (1.0_core_rknd/3.0_core_rknd) * beta & + = - one_third * beta & * invrs_dzt_p1 * invrs_rho_ds_zm & * rho_ds_zm * a1_zm * wp3_on_wp2 ! Momentum subdiagonal: [ x xapxbp(k-1,) ] - lhs(km1_mdiag) = 0._core_rknd + lhs(km1_mdiag) = zero end if @@ -2457,11 +2513,15 @@ pure function term_ta_rhs( wp2_ztp1, wp2_zt, & ! References: !----------------------------------------------------------------------- + use constants_clubb, only: & + one, & ! Constant(s) + one_third + use model_flags, only: & l_standard_term_ta use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) implicit none @@ -2498,7 +2558,7 @@ pure function term_ta_rhs( wp2_ztp1, wp2_zt, & ! listed above. rhs & - = - ( 1.0_core_rknd - (1.0_core_rknd/3.0_core_rknd) * beta ) & + = - ( one - one_third * beta ) & * invrs_rho_ds_zm & * invrs_dzm & * ( rho_ds_ztp1 * a1_ztp1**2 & @@ -2520,7 +2580,7 @@ pure function term_ta_rhs( wp2_ztp1, wp2_zt, & ! the derivative. rhs & - = - ( 1.0_core_rknd - (1.0_core_rknd/3.0_core_rknd) * beta ) & + = - ( one - one_third * beta ) & * invrs_rho_ds_zm * a1**2 & * invrs_dzm & * ( rho_ds_ztp1 & @@ -2816,10 +2876,11 @@ pure function term_pr1( C4, C14, xbp2, wp2, tau_zm ) & !----------------------------------------------------------------------- use constants_clubb, only: & - w_tol_sqd + w_tol_sqd, & ! Constant(s) + one_third use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) implicit none @@ -2834,14 +2895,14 @@ pure function term_pr1( C4, C14, xbp2, wp2, tau_zm ) & ! Return Variable real( kind = core_rknd ) :: rhs - rhs = + 1.0_core_rknd/3.0_core_rknd * ( C4 - C14 ) * ( xbp2 + wp2 ) / tau_zm & + rhs = + one_third * ( C4 - C14 ) * ( xbp2 + wp2 ) / tau_zm & + ( C14 / tau_zm ) * w_tol_sqd return end function term_pr1 !============================================================================= - pure function term_pr2( C5, thv_ds_zm, wpthvp, upwp, vpwp, & + function term_pr2( C5, thv_ds_zm, wpthvp, upwp, vpwp, & um, vm, invrs_dzm, kp1, k, & Lscalep1, Lscale, wp2_ztp1, wp2_zt ) & result( rhs ) @@ -2884,14 +2945,17 @@ pure function term_pr2( C5, thv_ds_zm, wpthvp, upwp, vpwp, & !----------------------------------------------------------------------- use constants_clubb, only: & ! Constants - grav, & ! Gravitational acceleration [m/s^2] - zero_threshold + grav, & ! Gravitational acceleration [m/s^2] + one, & + two_thirds, & + zero, & + zero_threshold use grid_class, only: & - gr ! Variable(s) + gr ! Variable(s) use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) implicit none @@ -2929,7 +2993,7 @@ pure function term_pr2( C5, thv_ds_zm, wpthvp, upwp, vpwp, & real( kind = core_rknd ), parameter :: & ! Constants empirically determined for experimental version of term_pr2 ! ldgrant March 2010 - constant1 = 1.0_core_rknd, & ! [m/s] + constant1 = one, & ! [m/s] constant2 = 1000.0_core_rknd, & ! [m] vert_avg_depth = 200.0_core_rknd ! Depth over which to average d(um)/dz and d(vm)/dz [m] @@ -2953,11 +3017,11 @@ pure function term_pr2( C5, thv_ds_zm, wpthvp, upwp, vpwp, & ! use original version of term_pr2 ! As applied to w'2 - rhs = + (2.0_core_rknd/3.0_core_rknd) * C5 & - * ( ( grav / thv_ds_zm ) * wpthvp & - - upwp * invrs_dzm * ( um(kp1) - um(k) ) & - - vpwp * invrs_dzm * ( vm(kp1) - vm(k) ) & - ) + rhs = + two_thirds * C5 & + * ( ( grav / thv_ds_zm ) * wpthvp & + - upwp * invrs_dzm * ( um(kp1) - um(k) ) & + - vpwp * invrs_dzm * ( vm(kp1) - vm(k) ) & + ) else ! use experimental version of term_pr2 --ldgrant March 2010 @@ -3013,15 +3077,15 @@ pure function term_pr2( C5, thv_ds_zm, wpthvp, upwp, vpwp, & ! For better results, we reduced the value of C5 from 5.2 to 3.0 and ! changed the eddy diffusivity coefficient Kh so that it is ! proportional to 1.5*wp2 rather than to em. - rhs = + (2.0_core_rknd/3.0_core_rknd) * C5 & + rhs = + two_thirds * C5 & * ( constant1 * abs( wp2_ztp1 - wp2_zt ) * invrs_dzm & ! * abs( Lscalep1 - Lscale ) * invrs_dzm & + constant2 * abs( wp2_ztp1 - wp2_zt ) * invrs_dzm & * abs( vm_high - vm_low ) / ( zt_high - zt_low ) & - + ( Lscalep1 + Lscale ) * 0._core_rknd & + + ( Lscalep1 + Lscale ) * zero & ! This line eliminates an Intel compiler - ) ! warning that Lscalep1/Lscale are not - ! used. -meyern + ) ! warning that Lscalep1/Lscale are not + ! used. -meyern end if ! .not. l_use_experimental_term_pr2 ! Added by dschanen for ticket #36 @@ -3034,7 +3098,7 @@ pure function term_pr2( C5, thv_ds_zm, wpthvp, upwp, vpwp, & end function term_pr2 !============================================================================= - pure subroutine find_endpts_for_vert_avg_winds & + subroutine find_endpts_for_vert_avg_winds & ( vert_avg_depth, k, um, vm, & ! intent(in) zt_high, um_high, vm_high, & ! intent(out) zt_low, um_low, vm_low ) ! intent(out) @@ -3047,17 +3111,19 @@ pure subroutine find_endpts_for_vert_avg_winds & ! then this subroutine will determine the values of um and vm which ! are 100m above and below the current level. ! ldgrant March 2010 - !--------------------------------------------------------------------------- + !----------------------------------------------------------------------- + use constants_clubb, only: & + two ! Constant(s) use interpolation, only : & - binary_search, lin_int ! Function(s) + binary_search, lin_interpolate_two_points ! Function(s) use grid_class, only: & - gr ! Variable(s) + gr ! Variable(s) use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) implicit none @@ -3092,7 +3158,7 @@ pure subroutine find_endpts_for_vert_avg_winds & !------ Begin code ------------ - depth = vert_avg_depth / 2.0_core_rknd + depth = vert_avg_depth / two ! Find the grid level that contains the altitude greater than or ! equal to the current altitude + depth @@ -3116,9 +3182,9 @@ pure subroutine find_endpts_for_vert_avg_winds & vm_high = vm(k_high) else ! Do an interpolation to find um & vm at current altitude + depth. zt_high = gr%zt(k)+depth - um_high = lin_int( zt_high, gr%zt(k_high), gr%zt(k_high-1), & + um_high = lin_interpolate_two_points( zt_high, gr%zt(k_high), gr%zt(k_high-1), & um(k_high), um(k_high-1) ) - vm_high = lin_int( zt_high, gr%zt(k_high), gr%zt(k_high-1), & + vm_high = lin_interpolate_two_points( zt_high, gr%zt(k_high), gr%zt(k_high-1), & vm(k_high), vm(k_high-1) ) end if ! k_high ... @@ -3144,9 +3210,9 @@ pure subroutine find_endpts_for_vert_avg_winds & vm_low = vm(k_low) else ! Do an interpolation to find um at current altitude - depth. zt_low = gr%zt(k)-depth - um_low = lin_int( zt_low, gr%zt(k_low), gr%zt(k_low-1), & + um_low = lin_interpolate_two_points( zt_low, gr%zt(k_low), gr%zt(k_low-1), & um(k_low), um(k_low-1) ) - vm_low = lin_int( zt_low, gr%zt(k_low), gr%zt(k_low-1), & + vm_low = lin_interpolate_two_points( zt_low, gr%zt(k_low), gr%zt(k_low-1), & vm(k_low), vm(k_low-1) ) end if ! k_low ... @@ -3162,14 +3228,14 @@ subroutine pos_definite_variances( solve_type, dt, tolerance, & ! Use the hole filling code to make a variance term positive definite !----------------------------------------------------------------------- - use fill_holes, only: fill_holes_driver + use fill_holes, only: fill_holes_vertical use grid_class, only: gr - use clubb_precision, only: time_precision, core_rknd + use clubb_precision, only: core_rknd use stats_variables, only: & - zm, l_stats_samp, & + stats_zm, l_stats_samp, & irtp2_pd, ithlp2_pd, iup2_pd, ivp2_pd ! variables - use stats_type, only: & + use stats_type_utilities, only: & stat_begin_update, stat_end_update ! subroutines @@ -3182,7 +3248,7 @@ subroutine pos_definite_variances( solve_type, dt, tolerance, & integer, intent(in) :: & solve_type - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dt ! Model timestep [s] real( kind = core_rknd ), intent(in) :: & @@ -3215,8 +3281,8 @@ subroutine pos_definite_variances( solve_type, dt, tolerance, & if ( l_stats_samp ) then ! Store previous value for effect of the positive definite scheme - call stat_begin_update( ixp2_pd, xp2_np1 / real( dt, kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) + call stat_begin_update( ixp2_pd, xp2_np1 / dt, & ! Intent(in) + stats_zm ) ! Intent(inout) endif @@ -3225,7 +3291,7 @@ subroutine pos_definite_variances( solve_type, dt, tolerance, & ! Call the hole-filling scheme. ! The first pass-through should draw from only two levels on either side ! of the hole. - call fill_holes_driver( 2, tolerance, "zm", & ! Intent(in) + call fill_holes_vertical( 2, tolerance, "zm", & ! Intent(in) rho_ds_zt, rho_ds_zm, & ! Intent(in) xp2_np1 ) ! Intent(inout) @@ -3233,14 +3299,156 @@ subroutine pos_definite_variances( solve_type, dt, tolerance, & if ( l_stats_samp ) then ! Store previous value for effect of the positive definite scheme - call stat_end_update( ixp2_pd, xp2_np1 / real( dt, kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) + call stat_end_update( ixp2_pd, xp2_np1 / dt, & ! Intent(in) + stats_zm ) ! Intent(inout) endif return end subroutine pos_definite_variances + !============================================================================ + subroutine update_xp2_mc( nz, dt, cloud_frac, rcm, rvm, thlm, & + wm, exner, rrm_evap, pdf_params, & + rtp2_mc, thlp2_mc, wprtp_mc, wpthlp_mc, & + rtpthlp_mc ) + !Description: + !This subroutine is for use when l_morr_xp2_mc = .true. + !The effects of rain evaporation on rtp2 and thlp2 are included by + !assuming rain falls through the moist (cold) portion of the pdf. + !This is accomplished by defining a precip_fraction and assuming a double + !delta shaped pdf, such that the evaporation makes the moist component + !moister and the colder component colder. Calculations are done using + !variables on the zt grid, and the outputs are on the zm grid --storer + + use pdf_parameter_module, only: pdf_parameter + + use grid_class, only: & + zt2zm ! Procedure(s) + + use constants_clubb, only: & + cloud_frac_min, & !Variables + Cp, & + Lv + + use clubb_precision, only: & + core_rknd ! Variable(s) + + + implicit none + + !input parameters + integer, intent(in) :: nz ! Points in the Vertical [-] + + real( kind = core_rknd ), intent(in) :: dt ! Model timestep [s] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + cloud_frac, & !Cloud fraction [-] + rcm, & !Cloud water mixing ratio [kg/kg] + rvm, & !Vapor water mixing ratio [kg/kg] + thlm, & !Liquid potential temperature [K] + wm, & !Mean vertical velocity [m/s] + exner, & !Exner function [-] + rrm_evap !Evaporation of rain [kg/kg/s] + !It is expected that this variable is negative, as + !that is the convention in Morrison microphysics + + type(pdf_parameter), dimension(nz), intent(in) :: & + pdf_params ! PDF parameters + + !input/output variables + real( kind = core_rknd ), dimension(nz), intent(inout) :: & + rtp2_mc, & !Tendency of due to evaporation [(kg/kg)^2/s] + thlp2_mc, & !Tendency of due to evaporation [K^2/s] + wprtp_mc, & !Tendency of due to evaporation [m*(kg/kg)/s^2] + wpthlp_mc, & !Tendency of due to evaporation [m*K/s^2] + rtpthlp_mc !Tendency of due to evaporation [K*(kg/kg)/s] + + !local variables + real( kind = core_rknd ), dimension(nz) :: & + temp_rtp2, & !Used only to calculate rtp2_mc [(kg/kg)^2] + temp_thlp2, & !Used to calculate thlp2_mc [K^2/s] + temp_wp2, & !Used to calculate wpxp_mc [m^2/s^2] + rtp2_mc_zt, & !Calculated on the zt grid [(kg/kg)^2/s] + thlp2_mc_zt, & !Calculated on the zt grid [(kg/kg)^2/s] + wprtp_mc_zt, & !Calculated on the zt grid [m*(kg/kg)/s^2] + wpthlp_mc_zt, & !Calcualted on the zt grid [m*K/s^2] + rtpthlp_mc_zt,& !Calculated on the zt grid [K*(kg/kg)/s] + precip_frac_double_delta, &!Precipitation fraction for a double delta [-] + pf_const ! ( 1 - pf )/( pf ) [-] + + integer :: k + + ! ---- Begin Code ---- + + ! Calculate precip_frac_double_delta + precip_frac_double_delta(nz) = 0.0_core_rknd + do k = nz-1, 1, -1 + if ( cloud_frac(k) > cloud_frac_min ) then + precip_frac_double_delta(k) = cloud_frac(k) + else + precip_frac_double_delta(k) = precip_frac_double_delta(k+1) + end if + end do + + + !pf_const is calculated so that when precip_frac_double_delta = 0, rtp2_mc and + !thlp2_mc will both be zero. This also avoids a divide by zero error + where ( precip_frac_double_delta > cloud_frac_min ) + pf_const = ( 1.0_core_rknd - precip_frac_double_delta ) / precip_frac_double_delta + else where + pf_const = 0.0_core_rknd + end where + + ! Include effects of rain evaporation on rtp2 + temp_rtp2 = pdf_params%mixt_frac & + * ( ( pdf_params%rt_1 - ( rcm + rvm ) )**2 + pdf_params%varnce_rt_1 ) & + + ( 1.0_core_rknd - pdf_params%mixt_frac ) & + * ( ( pdf_params%rt_2 - ( rcm + rvm ) )**2 + pdf_params%varnce_rt_2 ) + + rtp2_mc_zt = rrm_evap**2 * pf_const * dt & + + 2.0_core_rknd * abs(rrm_evap) * sqrt(temp_rtp2 * pf_const) + !use absolute value of evaporation, as evaporation will add + !to rt_1 + rtp2_mc = zt2zm( rtp2_mc_zt ) + + !Include the effects of rain evaporation on thlp2 + temp_thlp2 = pdf_params%mixt_frac & + * ( ( pdf_params%thl_1 - thlm )**2 + pdf_params%varnce_thl_1 ) & + + ( 1.0_core_rknd - pdf_params%mixt_frac ) & + * ( ( pdf_params%thl_2 - thlm )**2 + pdf_params%varnce_thl_2 ) + + thlp2_mc_zt = ( rrm_evap * Lv / ( Cp * exner) )**2 & + * pf_const * dt & + + 2.0_core_rknd * abs(rrm_evap) * Lv / ( Cp * exner ) & + * sqrt(temp_thlp2 * pf_const) + + thlp2_mc = zt2zm( thlp2_mc_zt ) + + ! Include effects of rain evaporation on other moments (wprtp, wpthlp, and + ! rtpthlp - added 07/13 rstorer + + temp_wp2 = pdf_params%mixt_frac & + * ( ( pdf_params%w_1 - wm )**2 + pdf_params%varnce_w_1 ) & + + ( 1.0_core_rknd - pdf_params%mixt_frac ) & + * ( ( pdf_params%w_2 - wm )**2 + pdf_params%varnce_w_2 ) + + wprtp_mc_zt = abs(rrm_evap) * sqrt(pf_const) * sqrt(temp_wp2) + + wpthlp_mc_zt = -1.0_core_rknd * Lv / ( Cp * exner) * abs(rrm_evap) & + * sqrt(pf_const) * sqrt(temp_wp2) + + rtpthlp_mc_zt = -1.0_core_rknd * abs(rrm_evap) * sqrt( pf_const ) & + * ( ( Lv / (cp * exner ) ) * sqrt( temp_rtp2 ) & + + sqrt( temp_thlp2 ) ) & + - ( Lv / (cp * exner ) ) * pf_const & + * ( rrm_evap )**2 * dt + + wprtp_mc = zt2zm( wprtp_mc_zt ) + wpthlp_mc = zt2zm( wpthlp_mc_zt ) + rtpthlp_mc = zt2zm( rtpthlp_mc_zt ) + end subroutine update_xp2_mc + !=============================================================================== end module advance_xp2_xpyp_module diff --git a/models/atm/cam/src/physics/clubb/anl_erf.F90 b/models/atm/cam/src/physics/clubb/anl_erf.F90 index 28965e199e79..4931332978e0 100644 --- a/models/atm/cam/src/physics/clubb/anl_erf.F90 +++ b/models/atm/cam/src/physics/clubb/anl_erf.F90 @@ -1,115 +1,175 @@ -! $Id: anl_erf.F90 5324 2011-07-27 21:05:45Z dschanen@uwm.edu $ +!----------------------------------------------------------------------- +! $Id: anl_erf.F90 7269 2014-09-04 21:00:07Z raut@uwm.edu $ +!=============================================================================== module anl_erf implicit none - public :: erf + public :: dp_erf, & + dp_erfc, & + erf, & + erfc + + private :: cr_erf, & + cr_erfc + ! The interfaces allow us to avoid a compiler warning about + ! shadowing the intrinsic functions interface erf - module procedure dp_erf, sp_erf + module procedure cr_erf end interface - private :: dp_erf, sp_erf + interface erfc + module procedure cr_erfc + end interface private ! Default Scope contains - function dp_erf( x ) result( erfx ) -!----------------------------------------------------------------------- -! Description: -! DP_ERF evaluates the error function DP_ERF(X). -! -! Original Author: -! William Cody, -! Mathematics and Computer Science Division, -! Argonne National Laboratory, -! Argonne, Illinois, 60439. -! -! References: -! William Cody, -! "Rational Chebyshev approximations for the error function", -! Mathematics of Computation, -! 1969, pages 631-638. -! -! Arguments: -! Input, real ( kind = 8 ) X, the argument of ERF. -! Output, real ( kind = 8 ) ERFX, the value of ERF(X). -!----------------------------------------------------------------------- + !============================================================================= + pure function cr_erf( x ) result( erfx_core_rknd ) + ! Description: + ! Calls dp_erf after casting x to double precision. + ! This allows CLUBB to run erf even when core_rknd is in single precision. + ! + ! Arguments: + ! Input, real ( kind = dp ) x, the argument of ERF. + ! Output, real ( kind = core_rknd ) erfx_core_rknd, the value of ERF(X). + !----------------------------------------------------------------------- + + use clubb_precision, only: & + dp, & ! Constants + core_rknd implicit none ! Input Variables(s) - double precision, intent(in) :: x + real( kind = core_rknd), intent(in) :: x + + ! Return type + real( kind = core_rknd ) :: erfx_core_rknd + + ! Local Variables + real( kind = dp) :: x_dp, erfx_dp + + ! Cast the input to dp + x_dp = real( x, kind = dp ) + + ! Call the function with the correct argument + erfx_dp = dp_erf( x_dp ) + + ! Get the output in core_rknd + erfx_core_rknd = real( erfx_dp, kind = core_rknd ) + + return + + end function cr_erf + + !============================================================================= + pure function dp_erf( x ) result( erfx ) + + ! Description: + ! DP_ERF evaluates the error function DP_ERF(X). + ! + ! Original Author: + ! William Cody, + ! Mathematics and Computer Science Division, + ! Argonne National Laboratory, + ! Argonne, Illinois, 60439. + ! + ! References: + ! William Cody, + ! "Rational Chebyshev approximations for the error function", + ! Mathematics of Computation, + ! 1969, pages 631-638. + ! + ! Arguments: + ! Input, real ( kind = dp ) X, the argument of ERF. + ! Output, real ( kind = dp ) ERFX, the value of ERF(X). + ! + ! Modifications: + ! kind = 8 was replaced by the more portable sp and dp by UWM. + !----------------------------------------------------------------------- + + use clubb_precision, only: & + dp, & ! Constants + core_rknd + + implicit none + + ! Input Variables(s) + real( kind = dp ), intent(in) :: x ! External intrinsic :: epsilon, exp, aint ! Local Constants - real( kind = 8 ), parameter, dimension( 5 ) :: & - a = (/ 3.16112374387056560D+00, & - 1.13864154151050156D+02, & - 3.77485237685302021D+02, & - 3.20937758913846947D+03, & - 1.85777706184603153D-01 /) - real( kind = 8 ), parameter, dimension( 4 ) :: & - b = (/ 2.36012909523441209D+01, & - 2.44024637934444173D+02, & - 1.28261652607737228D+03, & - 2.84423683343917062D+03 /) - real( kind = 8 ), parameter, dimension( 9 ) :: & - c = (/ 5.64188496988670089D-01, & - 8.88314979438837594D+00, & - 6.61191906371416295D+01, & - 2.98635138197400131D+02, & - 8.81952221241769090D+02, & - 1.71204761263407058D+03, & - 2.05107837782607147D+03, & - 1.23033935479799725D+03, & - 2.15311535474403846D-08 /) - real( kind = 8 ), parameter, dimension( 8 ) :: & - d = (/ 1.57449261107098347D+01, & - 1.17693950891312499D+02, & - 5.37181101862009858D+02, & - 1.62138957456669019D+03, & - 3.29079923573345963D+03, & - 4.36261909014324716D+03, & - 3.43936767414372164D+03, & - 1.23033935480374942D+03 /) - real( kind = 8 ), parameter, dimension( 6 ) :: & - p = (/ 3.05326634961232344D-01, & - 3.60344899949804439D-01, & - 1.25781726111229246D-01, & - 1.60837851487422766D-02, & - 6.58749161529837803D-04, & - 1.63153871373020978D-02 /) - - real( kind = 8 ), parameter, dimension( 5 ) :: & - q = (/ 2.56852019228982242D+00, & - 1.87295284992346047D+00, & - 5.27905102951428412D-01, & - 6.05183413124413191D-02, & - 2.33520497626869185D-03 /) - - real( kind = 8 ), parameter :: & - SQRPI = 0.56418958354775628695D+00, & - THRESH = 0.46875D+00, & - XBIG = 26.543D+00 + real( kind = dp ), parameter, dimension( 5 ) :: & + a = (/ 3.16112374387056560E+00_dp, & + 1.13864154151050156E+02_dp, & + 3.77485237685302021E+02_dp, & + 3.20937758913846947E+03_dp, & + 1.85777706184603153E-01_dp /) + real( kind = dp ), parameter, dimension( 4 ) :: & + b = (/ 2.36012909523441209E+01_dp, & + 2.44024637934444173E+02_dp, & + 1.28261652607737228E+03_dp, & + 2.84423683343917062E+03_dp /) + real( kind = dp ), parameter, dimension( 9 ) :: & + c = (/ 5.64188496988670089E-01_dp, & + 8.88314979438837594E+00_dp, & + 6.61191906371416295E+01_dp, & + 2.98635138197400131E+02_dp, & + 8.81952221241769090E+02_dp, & + 1.71204761263407058E+03_dp, & + 2.05107837782607147E+03_dp, & + 1.23033935479799725E+03_dp, & + 2.15311535474403846E-08_dp /) + real( kind = dp ), parameter, dimension( 8 ) :: & + d = (/ 1.57449261107098347E+01_dp, & + 1.17693950891312499E+02_dp, & + 5.37181101862009858E+02_dp, & + 1.62138957456669019E+03_dp, & + 3.29079923573345963E+03_dp, & + 4.36261909014324716E+03_dp, & + 3.43936767414372164E+03_dp, & + 1.23033935480374942E+03_dp /) + real( kind = dp ), parameter, dimension( 6 ) :: & + p = (/ 3.05326634961232344E-01_dp, & + 3.60344899949804439E-01_dp, & + 1.25781726111229246E-01_dp, & + 1.60837851487422766E-02_dp, & + 6.58749161529837803E-04_dp, & + 1.63153871373020978E-02_dp /) + + real( kind = dp ), parameter, dimension( 5 ) :: & + q = (/ 2.56852019228982242E+00_dp, & + 1.87295284992346047E+00_dp, & + 5.27905102951428412E-01_dp, & + 6.05183413124413191E-02_dp, & + 2.33520497626869185E-03_dp /) + + real( kind = dp ), parameter :: & + SQRPI = 0.56418958354775628695E+00_dp, & + THRESH = 0.46875E+00_dp, & + XBIG = 26.543E+00_dp ! Return type - real( kind = 8 ) :: erfx + real( kind = dp ) :: erfx ! Local variables - real( kind = 8 ) :: & + real( kind = dp ) :: & del, & - xabs, & + xabs, & xden, & xnum, & xsq integer :: i ! Index -!------------------------------------------------------------------------------- + !----------------------------------------------------------------------- + ! Get the abs value of xabs - schemena 20140827 xabs = abs( x ) ! @@ -120,7 +180,7 @@ function dp_erf( x ) result( erfx ) if ( epsilon( xabs ) < xabs ) then xsq = xabs * xabs else - xsq = 0.0D+00 + xsq = 0.0E+00_dp end if xnum = a(5) * xsq @@ -134,7 +194,7 @@ function dp_erf( x ) result( erfx ) ! ! Evaluate ERFC(X) for 0.46875 <= |X| <= 4.0. ! - else if ( xabs <= 4.0D+00 ) then + else if ( xabs <= 4.0E+00_dp ) then xnum = c(9) * xabs xden = xabs @@ -144,16 +204,16 @@ function dp_erf( x ) result( erfx ) end do erfx = ( xnum + c(8) ) / ( xden + d(8) ) - xsq = aint( xabs * 16.0D+00 ) / 16.0D+00 + xsq = aint( xabs * 16.0E+00_dp ) / 16.0E+00_dp del = ( xabs - xsq ) * ( xabs + xsq ) ! xsq * xsq in the exponential was changed to xsq**2. ! This seems to decrease runtime by about a half a percent. ! ~~EIHoppe//20090622 erfx = exp( - xsq**2 ) * exp( - del ) * erfx - erfx = ( 0.5D+00 - erfx ) + 0.5D+00 + erfx = ( 0.5E+00_dp - erfx ) + 0.5E+00_dp - if ( x < 0.0D+00 ) then + if ( x < 0.0E+00_dp ) then erfx = - erfx end if ! @@ -163,15 +223,15 @@ function dp_erf( x ) result( erfx ) if ( XBIG <= xabs ) then - if ( 0.0D+00 < x ) then - erfx = 1.0D+00 + if ( 0.0E+00_dp < real(x, kind=dp) ) then + erfx = 1.0E+00_dp else - erfx = -1.0D+00 + erfx = -1.0E+00_dp end if else - xsq = 1.0D+00 / ( xabs * xabs ) + xsq = 1.0E+00_dp / ( xabs * xabs ) xnum = p(6) * xsq xden = xsq @@ -182,12 +242,12 @@ function dp_erf( x ) result( erfx ) erfx = xsq * ( xnum + p(5) ) / ( xden + q(5) ) erfx = ( SQRPI - erfx ) / xabs - xsq = aint( xabs * 16.0D+00 ) / 16.0D+00 + xsq = aint( xabs * 16.0E+00_dp ) / 16.0E+00_dp del = ( xabs - xsq ) * ( xabs + xsq ) erfx = exp( - xsq * xsq ) * exp( - del ) * erfx - erfx = ( 0.5D+00 - erfx ) + 0.5D+00 - if ( x < 0.0D+00 ) then + erfx = ( 0.5E+00_dp - erfx ) + 0.5E+00_dp + if ( x < 0.0E+00_dp ) then erfx = - erfx end if @@ -196,33 +256,89 @@ function dp_erf( x ) result( erfx ) end if return + end function dp_erf -!----------------------------------------------------------------------- - function sp_erf( x ) result( erfx ) + !============================================================================= + pure function cr_erfc( x ) result( erfcx_core_rknd ) + ! Description: + ! Calls dp_erfc after casting x to double precision. + ! This allows CLUBB to run erfc even when core_rknd is in single precision. + ! + ! Arguments: + ! Input, real ( kind = core_rknd ) x, the argument of ERFC. + ! Output, real ( kind = core_rknd ) erfcx_core_rknd, the value of ERFC(X). + !----------------------------------------------------------------------- -! Description: -! Return a truncation of the 64bit approx. of the error function. -! Ideally we would probably use a 32bit table for our approx. + use clubb_precision, only: & + dp, & ! Constants + core_rknd -! References: -! None -!----------------------------------------------------------------------- + implicit none + + ! Input Variables(s) + real( kind = core_rknd), intent(in) :: x + + ! Return type + real( kind = core_rknd ) :: erfcx_core_rknd + + ! Local Variables + real( kind = dp) :: x_dp, erfcx_dp + + ! Cast the input to dp + x_dp = real( x, kind = dp ) + + ! Call the function with the correct argument + erfcx_dp = dp_erfc( x_dp ) + + ! Get the output in core_rknd + erfcx_core_rknd = real( erfcx_dp, kind = core_rknd ) + + return + + end function cr_erfc + + !============================================================================= + pure function dp_erfc( x ) result( erfcx ) + + ! Description: + ! The complimentary error function of x: + ! + ! erfc(x) = 1 - erf(x); + ! + ! where: + ! + ! erf(x) = ( 2 / sqrt(pi) ) INT(0:x) e^-t^2 dt; + ! + ! and + ! + ! erfc(x) = ( 2 / sqrt(pi) ) INT(x:inf) e^-t^2 dt. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one_dp ! Constant(s) + + use clubb_precision, only: & + dp ! Variable(s) implicit none - ! External - intrinsic :: real + ! Input Variable + real( kind = dp ), intent(in) :: x - ! Input Variables - real( kind=4 ), intent(in) :: x + ! Return Variable + real( kind = dp ) :: erfcx - ! Return type - real( kind=4 ) :: erfx - erfx = real( dp_erf( real(x, kind=8) ), kind=4 ) + erfcx = one_dp - dp_erf( x ) + return - end function sp_erf + + end function dp_erfc + +!=============================================================================== end module anl_erf diff --git a/models/atm/cam/src/physics/clubb/array_index.F90 b/models/atm/cam/src/physics/clubb/array_index.F90 index 72c9c6e10cc7..967b8c75247a 100644 --- a/models/atm/cam/src/physics/clubb/array_index.F90 +++ b/models/atm/cam/src/physics/clubb/array_index.F90 @@ -1,28 +1,38 @@ -!----------------------------------------------------------------------- -! $Id: array_index.F90 5216 2011-06-06 18:58:41Z dschanen@uwm.edu $ -!----------------------------------------------------------------------- +!--------------------------------------------------------------------------- +! $Id: array_index.F90 7118 2014-07-25 00:12:15Z raut@uwm.edu $ +!=============================================================================== module array_index -! Description: -! Contains indices to variables in larger arrays. -! Note that the 'ii' is necessary because 'i' is used in -! statistics to track locations in the zt/zm/sfc derived types. + ! Description: + ! Contains indices to variables in larger arrays. + ! Note that the 'ii' is necessary because 'i' is used in + ! statistics to track locations in the zt/zm/sfc derived types. + + ! References: + ! None + !------------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Precision -! References: -! None -!----------------------------------------------------------------------- implicit none ! Variables ! Microphysics mixing ratios integer, public :: & - iirrainm, iirsnowm, iiricem, iirgraupelm ! [kg/kg] -!$omp threadprivate(iirrainm, iirsnowm, iiricem, iirgraupelm) + iirrm, & ! Hydrometeor array index for rain water mixing ratio, rr + iirsm, & ! Hydrometeor array index for snow mixing ratio, rs + iirim, & ! Hydrometeor array index for ice mixing ratio, ri + iirgm ! Hydrometeor array index for graupel mixing ratio, rg +!$omp threadprivate(iirrm, iirsm, iirim, iirgm) - ! Microphysics number concentration + ! Microphysics concentrations integer, public :: & - iiNrm, iiNsnowm, iiNim, iiNgraupelm, iiNcm ! [#/kg] -!$omp threadprivate(iiNrm, iiNsnowm, iiNim, iiNgraupelm, iiNcm) + iiNrm, & ! Hydrometeor array index for rain drop concentration, Nr + iiNsm, & ! Hydrometeor array index for snow concentration, Ns + iiNim, & ! Hydrometeor array index for ice concentration, Ni + iiNgm ! Hydrometeor array index for graupel concentration, Ng +!$omp threadprivate(iiNrm, iiNsm, iiNim, iiNgm) ! Scalar quantities integer, public :: & @@ -31,7 +41,24 @@ module array_index !$omp threadprivate(iisclr_rt, iisclr_thl, iisclr_CO2, & !$omp iiedsclr_rt, iiedsclr_thl, iiedsclr_CO2) + ! Logical fields + logical, dimension(:), allocatable, public :: & + l_frozen_hm, & ! if true, then the hydrometeor is frozen; otherwise liquid + l_mix_rat_hm ! if true, then the quantity is a hydrometeor mixing ratio +!$omp threadprivate(l_frozen_hm, l_mix_rat_hm) + + character(len=10), dimension(:), allocatable, public :: & + hydromet_list + +!$omp threadprivate( hydromet_list ) + + real( kind = core_rknd ), dimension(:), allocatable, public :: & + hydromet_tol ! Tolerance values for all hydrometeors [units vary] + +!$omp threadprivate( hydromet_tol ) + private ! Default Scope +!=============================================================================== + end module array_index -!----------------------------------------------------------------------- diff --git a/models/atm/cam/src/physics/clubb/calendar.F90 b/models/atm/cam/src/physics/clubb/calendar.F90 index 5a1b387c0ddf..e8480fa17692 100644 --- a/models/atm/cam/src/physics/clubb/calendar.F90 +++ b/models/atm/cam/src/physics/clubb/calendar.F90 @@ -1,4 +1,6 @@ -!$Id: calendar.F90 5421 2011-09-28 20:40:18Z connork@uwm.edu $ +!----------------------------------------------------------------------- +!$Id: calendar.F90 7140 2014-07-31 19:14:05Z betlej@uwm.edu $ +!=============================================================================== module calendar implicit none @@ -13,8 +15,8 @@ module calendar ! 3 Letter Month Abbreviations character(len=3), dimension(12), public, parameter :: & - month = (/'JAN','FEB','MAR','APR','MAY','JUN', & - 'JUL','AUG','SEP','OCT','NOV','DEC'/) + month_names = (/'JAN','FEB','MAR','APR','MAY','JUN', & + 'JUL','AUG','SEP','OCT','NOV','DEC'/) ! Number of days per month (Jan..Dec) for a non leap year integer, public, dimension(12), parameter :: & @@ -75,9 +77,9 @@ subroutine julian2gregorian_date & ! Output Variable(s) integer, intent(out):: & - day, & ! Gregorian calender day for given Month [dd] - month, & ! Gregorian calender month for given Year [mm] - year ! Gregorian calender year [yyyy] + day, & ! Gregorian calender day for given Month [dd] + month, & ! Gregorian calender month for given Year [mm] + year ! Gregorian calender year [yyyy] ! Local Variables integer :: i, j, k, n, l @@ -140,6 +142,8 @@ subroutine compute_current_date( previous_day, previous_month, & ! Computes the current Gregorian date from a previous date and ! the seconds that have transpired since that date. ! +! References: +! None !---------------------------------------------------------------------------- use clubb_precision, only: & time_precision ! Variable(s) @@ -187,14 +191,14 @@ subroutine compute_current_date( previous_day, previous_month, & ! Determine the amount of days that have passed since start date days_since_start = & - floor( seconds_since_previous_date / sec_per_day ) + floor( seconds_since_previous_date / real(sec_per_day,kind=time_precision) ) ! Set days_since_1jan4713 to the present Julian date days_since_1jan4713bc = days_since_1jan4713bc + days_since_start ! Set Present time to be seconds since the Julian date seconds_since_current_date = seconds_since_previous_date & - - ( real( days_since_start, kind=time_precision ) * sec_per_day ) + - ( real( days_since_start, kind=time_precision ) * real(sec_per_day,kind=time_precision) ) call julian2gregorian_date & ( days_since_1jan4713bc, & @@ -216,8 +220,10 @@ integer function gregorian2julian_day( day, month, year ) implicit none - ! Input Variable(s) + ! External + intrinsic :: sum + ! Input Variable(s) integer, intent(in) :: & day, & ! Day of the Month [dd] month, & ! Month of the Year [mm] @@ -226,21 +232,18 @@ integer function gregorian2julian_day( day, month, year ) ! ---- Begin Code ---- ! Add the days from the previous months - gregorian2julian_day = day + sum(days_per_month(1:month-1)) -! do j = 1, month-1, 1 -! julian_day = julian_day + days_per_month(j) -! end do + gregorian2julian_day = day + sum( days_per_month(1:month-1) ) ! Kluge for a leap year ! If the date were 29 Feb 2000 this would not increment julian_day ! However 01 March 2000 would need the 1 day bump - if ( leap_year(year) .and. month > 2 ) then + if ( leap_year( year ) .and. month > 2 ) then gregorian2julian_day = gregorian2julian_day + 1 end if if ( ( leap_year( year ) .and. gregorian2julian_day > 366 ) .or. & ( .not. leap_year( year ) .and. gregorian2julian_day > 365 ) ) then - stop "Problem with Julian day conversion." + stop "Problem with Julian day conversion in gregorian2julian_day." end if return diff --git a/models/atm/cam/src/physics/clubb/clip_explicit.F90 b/models/atm/cam/src/physics/clubb/clip_explicit.F90 index 15e2af00a622..80bd25e0beec 100644 --- a/models/atm/cam/src/physics/clubb/clip_explicit.F90 +++ b/models/atm/cam/src/physics/clubb/clip_explicit.F90 @@ -1,5 +1,5 @@ !------------------------------------------------------------------------------- -! $Id: clip_explicit.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +! $Id: clip_explicit.F90 7315 2014-09-30 20:49:54Z schemena@uwm.edu $ !=============================================================================== module clip_explicit @@ -9,27 +9,29 @@ module clip_explicit public :: clip_covars_denom, & clip_covar, & + clip_covar_level, & clip_variance, & clip_skewness, & clip_skewness_core ! Named constants to avoid string comparisons integer, parameter, public :: & - clip_rtp2 = 1, & ! Named constant for rtp2 clipping - clip_thlp2 = 2, & ! Named constant for thlp2 clipping - clip_rtpthlp = 3, & ! Named constant for rtpthlp clipping - clip_up2 = 5, & ! Named constant for up2 clipping - clip_vp2 = 6, & ! Named constant for vp2 clipping -! clip_scalar = 7, & ! Named constant for scalar clipping - clip_wprtp = 8, & ! Named constant for wprtp clipping - clip_wpthlp = 9, & ! Named constant for wpthlp clipping - clip_upwp = 10, & ! Named constant for upwp clipping - clip_vpwp = 11, & ! Named constant for vpwp clipping - clip_wp2 = 12, & ! Named constant for wp2 clipping - clip_wpsclrp = 13, & ! Named constant for wp scalar clipping - clip_sclrp2 = 14, & ! Named constant for sclrp2 clipping - clip_sclrprtp = 15, & ! Named constant for sclrprtp clipping - clip_sclrpthlp = 16 ! Named constant for sclrpthlp clipping + clip_rtp2 = 1, & ! Named constant for rtp2 clipping + clip_thlp2 = 2, & ! Named constant for thlp2 clipping + clip_rtpthlp = 3, & ! Named constant for rtpthlp clipping + clip_up2 = 5, & ! Named constant for up2 clipping + clip_vp2 = 6, & ! Named constant for vp2 clipping +! clip_scalar = 7, & ! Named constant for scalar clipping + clip_wprtp = 8, & ! Named constant for wprtp clipping + clip_wpthlp = 9, & ! Named constant for wpthlp clipping + clip_upwp = 10, & ! Named constant for upwp clipping + clip_vpwp = 11, & ! Named constant for vpwp clipping + clip_wp2 = 12, & ! Named constant for wp2 clipping + clip_wpsclrp = 13, & ! Named constant for wp scalar clipping + clip_sclrp2 = 14, & ! Named constant for sclrp2 clipping + clip_sclrprtp = 15, & ! Named constant for sclrprtp clipping + clip_sclrpthlp = 16, & ! Named constant for sclrpthlp clipping + clip_wphydrometp = 17 ! Named constant for wphydrometp clipping contains @@ -68,22 +70,21 @@ subroutine clip_covars_denom( dt, rtp2, thlp2, up2, vp2, wp2, & l_tke_aniso ! Logical use clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd + core_rknd ! Variable(s) - use stats_type, only: & + use stats_type_utilities, only: & stat_modify ! Procedure(s) use stats_variables, only: & iwprtp_bt, & ! Variable(s) iwpthlp_bt, & - zm, & + stats_zm, & l_stats_samp implicit none ! Input Variables - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dt ! Timestep [s] real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & @@ -158,12 +159,12 @@ subroutine clip_covars_denom( dt, rtp2, thlp2, up2, vp2, wp2, & if ( wprtp_cl_num == 2 ) then ! wprtp total time tendency (effect of clipping) - call stat_modify( iwprtp_bt, -wprtp / real( dt, kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) + call stat_modify( iwprtp_bt, -wprtp / dt, & ! intent(in) + stats_zm ) ! intent(inout) elseif ( wprtp_cl_num == 3 ) then ! wprtp total time tendency (effect of clipping) - call stat_modify( iwprtp_bt, -wprtp / real( dt, kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) + call stat_modify( iwprtp_bt, -wprtp / dt, & ! intent(in) + stats_zm ) ! intent(inout) endif endif @@ -187,12 +188,12 @@ subroutine clip_covars_denom( dt, rtp2, thlp2, up2, vp2, wp2, & if ( l_stats_samp ) then if ( wprtp_cl_num == 1 ) then ! wprtp total time tendency (effect of clipping) - call stat_modify( iwprtp_bt, wprtp / real( dt, kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) + call stat_modify( iwprtp_bt, wprtp / dt, & ! intent(in) + stats_zm ) ! intent(inout) elseif ( wprtp_cl_num == 2 ) then ! wprtp total time tendency (effect of clipping) - call stat_modify( iwprtp_bt, wprtp / real( dt, kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) + call stat_modify( iwprtp_bt, wprtp / dt, & ! intent(in) + stats_zm ) ! intent(inout) ! if wprtp_cl_num == 3 do nothing since ! iwprtp_bt stat_end_update is called outside of this method @@ -227,12 +228,12 @@ subroutine clip_covars_denom( dt, rtp2, thlp2, up2, vp2, wp2, & if ( wpthlp_cl_num == 2 ) then ! wpthlp total time tendency (effect of clipping) - call stat_modify( iwpthlp_bt, -wpthlp / real( dt, kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) + call stat_modify( iwpthlp_bt, -wpthlp / dt, & ! intent(in) + stats_zm ) ! intent(inout) elseif ( wpthlp_cl_num == 3 ) then ! wpthlp total time tendency (effect of clipping) - call stat_modify( iwpthlp_bt, -wpthlp / real( dt, kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) + call stat_modify( iwpthlp_bt, -wpthlp / dt, & ! intent(in) + stats_zm ) ! intent(inout) endif endif @@ -257,12 +258,12 @@ subroutine clip_covars_denom( dt, rtp2, thlp2, up2, vp2, wp2, & if ( l_stats_samp ) then if ( wpthlp_cl_num == 1 ) then ! wpthlp total time tendency (effect of clipping) - call stat_modify( iwpthlp_bt, wpthlp / real( dt, kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) + call stat_modify( iwpthlp_bt, wpthlp / dt, & ! intent(in) + stats_zm ) ! intent(inout) elseif ( wpthlp_cl_num == 2 ) then ! wpthlp total time tendency (effect of clipping) - call stat_modify( iwpthlp_bt, wpthlp / real( dt, kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) + call stat_modify( iwpthlp_bt, wpthlp / dt, & ! intent(in) + stats_zm ) ! intent(inout) ! if wpthlp_cl_num == 3 do nothing since ! iwpthlp_bt stat_end_update is called outside of this method @@ -439,7 +440,8 @@ subroutine clip_covar( solve_type, l_first_clip_ts, & ! ! w'r_t', w'th_l', w'sclr', (computed in advance_xm_wpxp); ! r_t'th_l', sclr'r_t', sclr'th_l', (computed in advance_xp2_xpyp); - ! u'w', v'w', w'edsclr' (computed in advance_windm_edsclrm). + ! u'w', v'w', w'edsclr' (computed in advance_windm_edsclrm); + ! and w'hm' (computed in setup_pdf_parameters). ! References: ! None @@ -452,16 +454,15 @@ subroutine clip_covar( solve_type, l_first_clip_ts, & max_mag_correlation ! Constant(s) use clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd + core_rknd ! Variable(s) - use stats_type, only: & + use stats_type_utilities, only: & stat_begin_update, & ! Procedure(s) stat_modify, & stat_end_update use stats_variables, only: & - zm, & ! Variable(s) + stats_zm, & ! Variable(s) iwprtp_cl, & iwpthlp_cl, & irtpthlp_cl, & @@ -477,7 +478,7 @@ subroutine clip_covar( solve_type, l_first_clip_ts, & l_first_clip_ts, & ! First instance of clipping in a timestep. l_last_clip_ts ! Last instance of clipping in a timestep. - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dt ! Model timestep; used here for STATS [s] real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & @@ -514,9 +515,9 @@ subroutine clip_covar( solve_type, l_first_clip_ts, & if ( l_stats_samp ) then if ( l_first_clip_ts ) then - call stat_begin_update( ixpyp_cl, xpyp / real( dt, kind = core_rknd ), zm ) + call stat_begin_update( ixpyp_cl, xpyp / dt, stats_zm ) else - call stat_modify( ixpyp_cl, -xpyp / real( dt, kind = core_rknd ), zm ) + call stat_modify( ixpyp_cl, -xpyp / dt, stats_zm ) endif endif @@ -562,9 +563,9 @@ subroutine clip_covar( solve_type, l_first_clip_ts, & if ( l_stats_samp ) then if ( l_last_clip_ts ) then - call stat_end_update( ixpyp_cl, xpyp / real( dt, kind = core_rknd ), zm ) + call stat_end_update( ixpyp_cl, xpyp / dt, stats_zm ) else - call stat_modify( ixpyp_cl, xpyp / real( dt, kind = core_rknd ), zm ) + call stat_modify( ixpyp_cl, xpyp / dt, stats_zm ) endif endif @@ -572,6 +573,169 @@ subroutine clip_covar( solve_type, l_first_clip_ts, & return end subroutine clip_covar + !============================================================================= + subroutine clip_covar_level( solve_type, level, l_first_clip_ts, & + l_last_clip_ts, dt, xp2, yp2, & + xpyp, xpyp_chnge ) + + ! Description: + ! Clipping the value of covariance x'y' based on the correlation between x + ! and y. This is all done at a single vertical level. + ! + ! The correlation between variables x and y is: + ! + ! corr_(x,y) = x'y' / [ sqrt(x'^2) * sqrt(y'^2) ]; + ! + ! where x'^2 is the variance of x, y'^2 is the variance of y, and x'y' is + ! the covariance of x and y. + ! + ! The correlation of two variables must always have a value between -1 + ! and 1, such that: + ! + ! -1 <= corr_(x,y) <= 1. + ! + ! Therefore, there is an upper limit on x'y', such that: + ! + ! x'y' <= [ sqrt(x'^2) * sqrt(y'^2) ]; + ! + ! and a lower limit on x'y', such that: + ! + ! x'y' >= -[ sqrt(x'^2) * sqrt(y'^2) ]. + ! + ! The values of x'y', x'^2, and y'^2 are all found on momentum levels. + ! + ! The value of x'y' may need to be clipped whenever x'y', x'^2, or y'^2 is + ! updated. + ! + ! The following covariances are found in the code: + ! + ! w'r_t', w'th_l', w'sclr', (computed in advance_xm_wpxp); + ! r_t'th_l', sclr'r_t', sclr'th_l', (computed in advance_xp2_xpyp); + ! u'w', v'w', w'edsclr' (computed in advance_windm_edsclrm); + ! and w'hm' (computed in setup_pdf_parameters). + + ! References: + ! None + !----------------------------------------------------------------------- + + use constants_clubb, only: & + max_mag_correlation, & ! Constant(s) + zero + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use stats_type_utilities, only: & + stat_begin_update_pt, & ! Procedure(s) + stat_modify_pt, & + stat_end_update_pt + + use stats_variables, only: & + stats_zm, & ! Variable(s) + iwprtp_cl, & + iwpthlp_cl, & + irtpthlp_cl, & + l_stats_samp + + implicit none + + ! Input Variables + integer, intent(in) :: & + solve_type, & ! Variable being solved; used for STATS + level ! Vertical level index + + logical, intent(in) :: & + l_first_clip_ts, & ! First instance of clipping in a timestep. + l_last_clip_ts ! Last instance of clipping in a timestep. + + real( kind = core_rknd ), intent(in) :: & + dt ! Model timestep; used here for STATS [s] + + real( kind = core_rknd ), intent(in) :: & + xp2, & ! Variance of x, [{x units}^2] + yp2 ! Variance of y, [{y units}^2] + + ! Output Variable + real( kind = core_rknd ), intent(inout) :: & + xpyp ! Covariance of x and y, [{x units}*{y units}] + + real( kind = core_rknd ), intent(out) :: & + xpyp_chnge ! Net change in due to clipping [{x units}*{y units}] + + + ! Local Variable + integer :: & + ixpyp_cl ! Statistics index + + + select case ( solve_type ) + case ( clip_wprtp ) ! wprtp clipping budget term + ixpyp_cl = iwprtp_cl + case ( clip_wpthlp ) ! wpthlp clipping budget term + ixpyp_cl = iwpthlp_cl + case ( clip_rtpthlp ) ! rtpthlp clipping budget term + ixpyp_cl = irtpthlp_cl + case default ! scalars (or upwp/vpwp) are involved + ixpyp_cl = 0 + end select + + + if ( l_stats_samp ) then + if ( l_first_clip_ts ) then + call stat_begin_update_pt( ixpyp_cl, level, & + xpyp / dt, stats_zm ) + else + call stat_modify_pt( ixpyp_cl, level, & + -xpyp / dt, stats_zm ) + endif + endif + + ! The value of x'y' at the surface (or lower boundary) is a set value that + ! is either specified or determined elsewhere in a surface subroutine. It + ! is ensured elsewhere that the correlation between x and y at the surface + ! (or lower boundary) is between -1 and 1. Thus, the covariance clipping + ! code does not need to be invoked at the lower boundary. Likewise, the + ! value of x'y' is set at the upper boundary, so the covariance clipping + ! code does not need to be invoked at the upper boundary. + ! Note that if clipping were applied at the lower boundary, momentum will + ! not be conserved, therefore it should never be added. + + ! Clipping for xpyp at an upper limit corresponding with a correlation + ! between x and y of max_mag_correlation. + if ( xpyp > max_mag_correlation * sqrt( xp2 * yp2 ) ) then + + xpyp_chnge = max_mag_correlation * sqrt( xp2 * yp2 ) - xpyp + + xpyp = max_mag_correlation * sqrt( xp2 * yp2 ) + + ! Clipping for xpyp at a lower limit corresponding with a correlation + ! between x and y of -max_mag_correlation. + elseif ( xpyp < -max_mag_correlation * sqrt( xp2 * yp2 ) ) then + + xpyp_chnge = -max_mag_correlation * sqrt( xp2 * yp2 ) - xpyp + + xpyp = -max_mag_correlation * sqrt( xp2 * yp2 ) + + else + + xpyp_chnge = zero + + endif + + if ( l_stats_samp ) then + if ( l_last_clip_ts ) then + call stat_end_update_pt( ixpyp_cl, level, & + xpyp / dt, stats_zm ) + else + call stat_modify_pt( ixpyp_cl, level, & + xpyp / dt, stats_zm ) + endif + endif + + + return + end subroutine clip_covar_level + !============================================================================= subroutine clip_variance( solve_type, dt, threshold, & xp2 ) @@ -595,15 +759,14 @@ subroutine clip_variance( solve_type, dt, threshold, & gr ! Variable(s) use clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd + core_rknd ! Variable(s) - use stats_type, only: & + use stats_type_utilities, only: & stat_begin_update, & ! Procedure(s) stat_end_update use stats_variables, only: & - zm, & ! Variable(s) + stats_zm, & ! Variable(s) iwp2_cl, & irtp2_cl, & ithlp2_cl, & @@ -617,7 +780,7 @@ subroutine clip_variance( solve_type, dt, threshold, & integer, intent(in) :: & solve_type ! Variable being solved; used for STATS. - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dt ! Model timestep; used here for STATS [s] real( kind = core_rknd ), intent(in) :: & @@ -653,7 +816,7 @@ subroutine clip_variance( solve_type, dt, threshold, & if ( l_stats_samp ) then - call stat_begin_update( ixp2_cl, xp2 / real( dt, kind = core_rknd ), zm ) + call stat_begin_update( ixp2_cl, xp2 / dt, stats_zm ) endif ! Limit the value of x'^2 at threshold. @@ -662,14 +825,19 @@ subroutine clip_variance( solve_type, dt, threshold, & ! clipping code does not need to be invoked at the lower boundary. ! Likewise, the value of x'^2 is set at the upper boundary, so the variance ! clipping code does not need to be invoked at the upper boundary. - do k = 2, gr%nz-1, 1 + ! + ! charlass on 09/11/2013: I changed the clipping so that also the surface + ! level is clipped. I did this because we discovered that there are slightly + ! negative values in thlp2(1) and rtp2(1) when running quarter_ss case with + ! WRF-CLUBB (see wrf:ticket:51#comment:33) + do k = 1, gr%nz-1, 1 if ( xp2(k) < threshold ) then xp2(k) = threshold endif enddo if ( l_stats_samp ) then - call stat_end_update( ixp2_cl, xp2 / real( dt, kind = core_rknd ), zm ) + call stat_end_update( ixp2_cl, xp2 / dt, stats_zm ) endif @@ -722,15 +890,14 @@ subroutine clip_skewness( dt, sfc_elevation, wp2_zt, wp3 ) gr ! Variable(s) use clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd + core_rknd ! Variable(s) - use stats_type, only: & + use stats_type_utilities, only: & stat_begin_update, & ! Procedure(s) stat_end_update use stats_variables, only: & - zt, & ! Variable(s) + stats_zt, & ! Variable(s) iwp3_cl, & l_stats_samp @@ -740,7 +907,7 @@ subroutine clip_skewness( dt, sfc_elevation, wp2_zt, wp3 ) intrinsic :: sign, sqrt, real ! Input Variables - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dt ! Model timestep; used here for STATS [s] real( kind = core_rknd ), intent(in) :: & @@ -756,13 +923,13 @@ subroutine clip_skewness( dt, sfc_elevation, wp2_zt, wp3 ) ! ---- Begin Code ---- if ( l_stats_samp ) then - call stat_begin_update( iwp3_cl, wp3 / real( dt, kind = core_rknd ), zt ) + call stat_begin_update( iwp3_cl, wp3 / dt, stats_zt ) endif call clip_skewness_core( sfc_elevation, wp2_zt, wp3 ) if ( l_stats_samp ) then - call stat_end_update( iwp3_cl, wp3 / real( dt, kind = core_rknd ), zt ) + call stat_end_update( iwp3_cl, wp3 / dt, stats_zt ) endif return diff --git a/models/atm/cam/src/physics/clubb/clip_semi_implicit.F90 b/models/atm/cam/src/physics/clubb/clip_semi_implicit.F90 index 700f0d95b9a6..09caeb90e6ef 100644 --- a/models/atm/cam/src/physics/clubb/clip_semi_implicit.F90 +++ b/models/atm/cam/src/physics/clubb/clip_semi_implicit.F90 @@ -1,5 +1,5 @@ !----------------------------------------------------------------------- -! $Id: clip_semi_implicit.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +! $Id: clip_semi_implicit.F90 7140 2014-07-31 19:14:05Z betlej@uwm.edu $ !=============================================================================== module clip_semi_implicit @@ -200,8 +200,7 @@ module clip_semi_implicit !----------------------------------------------------------------------- use clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd + core_rknd ! Variable(s) implicit none @@ -229,7 +228,7 @@ module clip_semi_implicit ! timestep, dt. The smaller the value of dt_clip_coef, ! the smaller the value of dt_clip, and the larger the ! magnitude of (df/dt)_clipping. - real(kind=time_precision), parameter :: dt_clip_coef = 1.0_time_precision + real(kind=core_rknd), parameter :: dt_clip_coef = 1.0_core_rknd contains @@ -276,7 +275,7 @@ function clip_semi_imp_lhs( dt, f_unclipped, & implicit none ! Input Variables - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dt ! Model timestep. [s] real( kind = core_rknd ), intent(in) :: & @@ -292,7 +291,7 @@ function clip_semi_imp_lhs( dt, f_unclipped, & real( kind = core_rknd ) :: lhs ! Local Variables - real(kind=time_precision) :: & + real( kind = core_rknd ) :: & dt_clip ! Time scale for semi-implicit clipping term. [s] real( kind = core_rknd ) :: & @@ -391,7 +390,7 @@ pure function compute_clip_lhs( dt_clip, B_fnc ) & implicit none ! Input Variables - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd), intent(in) :: & dt_clip ! Time scale for semi-implicit clipping term. [s] real( kind = core_rknd ), intent(in) :: & @@ -403,7 +402,7 @@ pure function compute_clip_lhs( dt_clip, B_fnc ) & ! Main diagonal: [ x f_unclipped(k,) ] lhs_contribution & - = + (1.0_core_rknd/real( dt_clip, kind = core_rknd ) * B_fnc ) + = + (1.0_core_rknd/dt_clip * B_fnc ) end function compute_clip_lhs @@ -447,7 +446,7 @@ function clip_semi_imp_rhs( dt, f_unclipped, & implicit none ! Input Variables - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dt ! Model timestep. [s] real( kind = core_rknd ), intent(in) :: & @@ -463,7 +462,7 @@ function clip_semi_imp_rhs( dt, f_unclipped, & real( kind = core_rknd ) :: rhs ! Local Variables - real(kind=time_precision) :: & + real( kind = core_rknd) :: & dt_clip ! Time scale for semi-implicit clipping term. [s] real( kind = core_rknd ) :: & @@ -495,7 +494,7 @@ function clip_semi_imp_rhs( dt, f_unclipped, & ! Compute the explicit (RHS) contribution from clipping for the upper ! threshold. rhs_upper & - = + (1.0_core_rknd/real( dt_clip, kind = core_rknd ) & + = + (1.0_core_rknd/dt_clip & * ( A_fnc - B_fnc * f_diff + B_fnc * upper_threshold ) ) else @@ -522,7 +521,7 @@ function clip_semi_imp_rhs( dt, f_unclipped, & ! Compute the explicit (RHS) contribution from clipping for the lower ! threshold. rhs_lower & - = - (1.0_core_rknd/ real( dt_clip, kind = core_rknd )) & + = - (1.0_core_rknd/ dt_clip) & * ( A_fnc - B_fnc * f_diff - B_fnc * lower_threshold ) else diff --git a/models/atm/cam/src/physics/clubb/clubb_api_module.F90 b/models/atm/cam/src/physics/clubb/clubb_api_module.F90 new file mode 100644 index 000000000000..36e4afeff434 --- /dev/null +++ b/models/atm/cam/src/physics/clubb/clubb_api_module.F90 @@ -0,0 +1,1946 @@ +!-------------------------------------------------------------------------------------------------- +! $Id: clubb_api_module.F90 7361 2014-11-04 21:51:02Z bmg2@uwm.edu $ +!================================================================================================== +! +! ######## ### ### ### ######### ######### ### ######### ########### +! ### ### ### ### ### ### ### ### ### ### ### ### ### ### +! ### ### ### ### ### ### ### ### ### ### ### ### ### +! ### ### ### ### ######### ######### ########### ######### ### +! ### ### ### ### ### ### ### ### ### ### ### ### +! ### ### ### ### ### ### ### ### ### ### ### ### ### +! ######## ########## ######## ######### ######### ### ### ### ########### +! +! The CLUBB API serves as the doorway through which external models can interact with CLUBB. +! +! PLEASE REMEMBER, IF ANY CODE IS CHANGED IN THIS DOCUMENT, +! THE CHANGES MUST BE PROPOGATED TO ALL HOST MODELS. +! +module clubb_api_module + + use grid_class, only : & + zt2zm_api => zt2zm, & ! The interface implementation of these subroutines + zm2zt_api => zm2zt ! requires a use statement "interface" here. + + use mt95, only : & + assignment( = ), & + genrand_state, & ! Internal representation of the RNG state. + genrand_srepr, & ! Public representation of the RNG state. Should be used to save the RNG state + genrand_intg, & + genrand_init_api => genrand_init + + use array_index, only : & + hydromet_list, & + hydromet_tol, & ! Tolerance values for all hydrometeors [units vary] + iiNgm, & ! Hydrometeor array index for graupel concentration, Ng + iiNim, & ! Hydrometeor array index for ice concentration, Ni + iiNrm, & ! Hydrometeor array index for rain drop concentration, Nr + iiNsm, & ! Hydrometeor array index for snow concentration, Ns + iirgm, & ! Hydrometeor array index for graupel mixing ratio, rg + iirim, & ! Hydrometeor array index for ice mixing ratio, ri + iirrm, & ! Hydrometeor array index for rain water mixing ratio, rr + iirsm, & ! Hydrometeor array index for snow mixing ratio, rs + iisclr_rt, & + iisclr_thl, & + iisclr_CO2, & + iiedsclr_rt, & + iiedsclr_thl, & + iiedsclr_CO2, & + l_frozen_hm, & ! if true, then the hydrometeor is frozen; otherwise liquid + l_mix_rat_hm ! if true, then the quantity is a hydrometeor mixing ratio + + use clubb_precision, only : & + time_precision, & + core_rknd, & + stat_nknd, & + stat_rknd, & + dp ! Double Precision + + use constants_clubb, only : & + cloud_frac_min, & ! Threshold for cloud fractions + cm3_per_m3, & ! Cubic centimeters per cubic meter + Cp, & ! Dry air specific heat at constant p [J/kg/K] + em_min, & ! Minimum value for em (turbulence kinetic energy) + ep, & ! ep = 0.622 [-] + fstderr, & ! Fortran file unit I/O constant + fstdout, & ! Fortran file unit I/O constant + grav, & ! Gravitational acceleration [m/s^2] + Ls, & ! Latent heat of sublimation [J/kg] + Lv, & ! Latent heat of vaporization [J/kg] + Lf, & ! Latent heat of fusion [J/kg] + pi, & ! The ratio of radii to their circumference + pi_dp, & ! pi in double precision + radians_per_deg_dp, & + Rd, & ! Dry air gas constant [J/kg/K] + Rv, & ! Water vapor gas constant [J/kg/K] + sec_per_day, & ! Seconds in a day. + sec_per_hr, & ! Seconds in an hour. + sec_per_min, & ! Seconds in a minute. + T_freeze_K, & ! Freezing point of water [K] + var_length, & ! Maximum variable name length in CLUBB GrADS or netCDF output + zero, & ! 0.0_core_rknd + zero_threshold, & ! Defining a threshold on a physical quantity to be 0. + ! Tolerances + Nc_tol, & ! Tolerance value for N_c [#/kg] + Ng_tol, & ! Tolerance value for N_s [#/kg] + Ni_tol, & ! Tolerance value for N_i [#/kg] + Nr_tol, & ! Tolerance value for N_r [#/kg] + Ns_tol, & ! Tolerance value for N_s [#/kg] + rg_tol, & ! Tolerance value for r_g [kg/kg] + rho_lw, & + ri_tol, & ! Tolerance value for r_i [kg/kg] + rr_tol, & ! Tolerance value for r_r [kg/kg] + rs_tol, & ! Tolerance value for r_s [kg/kg] + rt_tol, & ! [kg/kg] + thl_tol, & ! [K] + w_tol_sqd ! [m^2/s^2] + + use corr_varnce_module, only : & + corr_array_cloud, & ! + corr_array_below, & + d_variables, & + iiPDF_chi, & + iiPDF_rr, & + iiPDF_w, & + iiPDF_Nr, & + iiPDF_ri, & + iiPDF_Ni, & + iiPDF_Ncn, & + iiPDF_rs, & + iiPDF_Ns, & + iiPDF_rg, & + iiPDF_Ng, & + sigma2_on_mu2_ratios_type + + use error_code, only : & + clubb_no_error ! Enum representing that no errors have occurred in CLUBB + + use grid_class, only : & + gr + + use hydromet_pdf_parameter_module, only : & + hydromet_pdf_parameter + + use model_flags, only : & + l_use_boussinesq, & ! Use Boussinesq form of predictive equations (default is Anelastic). + l_diagnose_correlations, & ! Diagnose correlations instead of using fixed ones + l_calc_w_corr, & ! Calculate the correlations between w and the hydrometeors + l_use_cloud_cover, & ! helps to increase cloudiness at coarser grid resolutions. + l_use_precip_frac, & ! Flag to use precipitation fraction in KK microphysics. + l_tke_aniso, & ! For anisotropic turbulent kinetic energy + l_fix_chi_eta_correlations, & ! Use a fixed correlation for s and t Mellor(chi/eta) + l_const_Nc_in_cloud ! Use a constant cloud droplet conc. within cloud (K&K) + + use parameters_model, only : & + hydromet_dim ! Number of hydrometeor species + + use parameters_tunable, only : & + l_prescribed_avg_deltaz ! used in adj_low_res_nu. If .true., avg_deltaz = deltaz + + use parameter_indices, only: & + nparams, & ! Variable(s) + iSkw_denom_coef, & ! Index of iSkw_denom_coef + ibeta, & ! index of beta + iC11, & ! Index of C11 + iC11b ! Index of C11b + + use pdf_parameter_module, only : & +#ifdef CLUBB_CAM /* Code for storing pdf_parameter structs in pbuf as array */ + num_pdf_params, & +#endif + pdf_parameter + + use stat_file_module, only : & + clubb_i, & ! Used to output multiple columns + clubb_j ! The indices must not exceed nlon (for i) or nlat (for j). + + use stats_rad_zm_module, only : & + nvarmax_rad_zm ! Maximum variables allowed + + use stats_rad_zt_module, only : & + nvarmax_rad_zt ! Maximum variables allowed + + use stats_variables, only : & + stats_zt, & ! zt grid + stats_zm, & ! zm grid + stats_rad_zt, & ! rad_zt grid + stats_rad_zm, & ! rad_zm grid + stats_sfc, & + l_stats_last, & ! Last time step of output period + stats_tsamp, & ! Sampling interval [s] + stats_tout, & ! Output interval [s] + l_output_rad_files, & ! Flag to turn off radiation statistics output + l_stats, & ! Main flag to turn statistics on/off + l_stats_samp, & ! Sample flag for current time step + l_grads, & ! Output to GrADS format + fname_rad_zt, & ! Name of the stats file for the stats_zt radiation grid fields + fname_rad_zm, & ! Name of the stats file for the stats_zm radiation grid fields + fname_sfc, & ! Name of the stats file for surface only fields + l_netcdf, & ! Output to NetCDF format + ! These are used in CAM only + ztscr01, ztscr02, ztscr03, & + ztscr04, ztscr05, ztscr06, & + ztscr07, ztscr08, ztscr09, & + ztscr10, ztscr11, ztscr12, & + ztscr13, ztscr14, ztscr15, & + ztscr16, ztscr17, ztscr18, & + ztscr19, ztscr20, ztscr21, & + zmscr01, zmscr02, zmscr03, & + zmscr04, zmscr05, zmscr06, & + zmscr07, zmscr08, zmscr09, & + zmscr10, zmscr11, zmscr12, & + zmscr13, zmscr14, zmscr15, & + zmscr16, zmscr17 + + use stats_zm_module, only : & + nvarmax_zm ! Maximum variables allowed + + use stats_zt_module, only : & + nvarmax_zt ! Maximum variables allowed + + use stats_sfc_module, only : & + nvarmax_sfc + + use variables_diagnostic_module, only : & + Lscale, & ! Mixing lengths + wp2_zt, & ! w'^2 on thermo. grid [m^2/s^2] + wphydrometp ! Covariance of w and hydrometeor (momentum levels) [(m/s)un] + + implicit none + + private + + public & + ! To Implement CLUBB: + read_parameters_api, & + setup_clubb_core_api, & + ! CLUBB can be set more specifically using these flags: + l_use_boussinesq, & + l_diagnose_correlations, & + l_calc_w_corr, & + l_use_cloud_cover, & + l_use_precip_frac, & + l_tke_aniso, & + l_fix_chi_eta_correlations, & + l_const_Nc_in_cloud, & + ! The parameters of CLUBB can be retrieved and tuned using these indices: + iSkw_denom_coef, & + ibeta, & + iC11, & + iC11b, & + advance_clubb_core_api, & + pdf_parameter, & + ! A hydromet array is required, and these variables are required for a hydromet array: + hydromet_list, & + hydromet_tol, & + hydromet_dim, & + iiNgm, & + iiNim, & + iiNrm, & + iiNsm, & + iirgm, & + iirim, & + iirrm, & + iirsm, & + iisclr_rt, & + iisclr_thl, & + iisclr_CO2, & + iiedsclr_rt, & + iiedsclr_thl, & + iiedsclr_CO2, & + l_frozen_hm, & + l_mix_rat_hm, & + cleanup_clubb_core_api + + public & + ! To Implement SILHS: + setup_pdf_indices_api, & + setup_corr_varnce_array_api, & + setup_pdf_parameters_api, & + hydromet_pdf_parameter, & + ! lh_subcolumn_generator - SILHS API + genrand_init_api, & ! if you are doing restarts) + genrand_state, & + genrand_srepr, & + genrand_intg, & + ! To use the results, you will need these variables: + corr_array_cloud, & + corr_array_below, & + d_variables, & + iiPDF_chi, & + iiPDF_rr, & + iiPDF_w, & + iiPDF_Nr, & + iiPDF_ri, & + iiPDF_Ni, & + iiPDF_Ncn, & + iiPDF_rs, & + iiPDF_Ns, & + iiPDF_rg, & + iiPDF_Ng + + public & + ! To Interact With CLUBB's Grid: + gr, & + ! For Varying Grids + setup_grid_heights_api ! if heights vary with time + + public & + ! To Obtain More Output from CLUBB for Diagnostics: + stats_begin_timestep_api, & + stats_end_timestep_api, & + stats_finalize_api, & + stats_init_api, & + l_stats, & + l_stats_last, & + l_stats_samp, & + stats_tsamp, & + stats_tout + + public & + ! To Convert Between Common CLUBB-related quantities: + lin_interpolate_two_points_api, & ! OR + lin_interpolate_on_grid_api, & + T_in_K2thlm_api, & + thlm2T_in_K_api, & + zt2zm_api, & + zm2zt_api + + public & + ! To Check For and Handle CLUBB's Errors: + calculate_spurious_source_api, & + clubb_at_least_debug_level_api, & + clubb_no_error, & + fatal_error_api, & + fill_holes_driver_api, & ! OR + fill_holes_vertical_api, & + report_error_api, & + set_clubb_debug_level_api, & + vertical_integral_api + + public & + ! Constants That May be Helpful: + cloud_frac_min, & + cm3_per_m3, & + core_rknd, & + Cp, & + dp, & + em_min, & + ep, & + fstderr, & + fstdout, & + grav, & + Lf, & + Ls, & + Lv, & + pi_dp, & + pi, & + radians_per_deg_dp, & + Rd, & + Rv, & + sec_per_day, & + sec_per_hr, & + sec_per_min, & + T_freeze_K, & + time_precision, & + var_length, & + zero_threshold, & + zero, & + ! Tolerances + Nc_tol, & + Ng_tol, & + Ni_tol, & + Nr_tol, & + Ns_tol, & + rg_tol, & + rho_lw, & + ri_tol, & + rr_tol, & + rs_tol, & + rt_tol, & + thl_tol, & + w_tol_sqd + + public & + ! Attempt to Not Use the Following: +#ifdef CLUBB_CAM /* Code for storing pdf_parameter structs in pbuf as array */ + pack_pdf_params_api, & + unpack_pdf_params_api, & + num_pdf_params, & +#endif + adj_low_res_nu_api, & + assignment( = ), & + clubb_i, & + clubb_j, & + compute_current_date_api, & + fname_rad_zm, & + fname_rad_zt, & + fname_sfc, & + gregorian2julian_day_api, & + l_grads, & + l_netcdf, & + l_output_rad_files, & + l_prescribed_avg_deltaz, & + leap_year_api, & + Lscale, & + nvarmax_rad_zm, & + nvarmax_rad_zt, & + nvarmax_sfc, & + nvarmax_zm, & + nvarmax_zt, & + stats_rad_zm, & + stats_rad_zt + public & + sigma2_on_mu2_ratios_type, & + nparams, & + setup_parameters_api, & + stats_sfc, & + stat_nknd, & + stat_rknd, & + stats_accumulate_hydromet_api, & + stats_init_rad_zm_api, & + stats_init_rad_zt_api, & + stats_init_sfc_api, & + stats_init_zm_api, & + stats_init_zt_api, & + wp2_zt, & + wphydrometp, & + stats_zm, & + zmscr01, zmscr02, zmscr03, & + zmscr04, zmscr05, zmscr06, & + zmscr07, zmscr08, zmscr09, & + zmscr10, zmscr11, zmscr12, & + zmscr13, zmscr14, zmscr15, & + zmscr16, zmscr17, & + stats_zt, & + ztscr01, ztscr02, ztscr03, & + ztscr04, ztscr05, ztscr06, & + ztscr07, ztscr08, ztscr09, & + ztscr10, ztscr11, ztscr12, & + ztscr13, ztscr14, ztscr15, & + ztscr16, ztscr17, ztscr18, & + ztscr19, ztscr20, ztscr21 + + +contains + + !================================================================================================ + ! advance_clubb_core - Advances the model one timestep. + !================================================================================================ + + subroutine advance_clubb_core_api( & + l_implemented, dt, fcor, sfc_elevation, hydromet_dim, & ! intent(in) + thlm_forcing, rtm_forcing, um_forcing, vm_forcing, & ! intent(in) + sclrm_forcing, edsclrm_forcing, wprtp_forcing, & ! intent(in) + wpthlp_forcing, rtp2_forcing, thlp2_forcing, & ! intent(in) + rtpthlp_forcing, wm_zm, wm_zt, & ! intent(in) + wpthlp_sfc, wprtp_sfc, upwp_sfc, vpwp_sfc, & ! intent(in) + wpsclrp_sfc, wpedsclrp_sfc, & ! intent(in) + p_in_Pa, rho_zm, rho, exner, & ! intent(in) + rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & ! intent(in) + invrs_rho_ds_zt, thv_ds_zm, thv_ds_zt, hydromet, & ! intent(in) + rfrzm, radf, wphydrometp, wp2hmp, rtphmp, thlphmp, & ! intent(in) + host_dx, host_dy, & ! intent(in) + um, vm, upwp, vpwp, up2, vp2, & ! intent(inout) + thlm, rtm, wprtp, wpthlp, & ! intent(inout) + wp2, wp3, rtp2, thlp2, rtpthlp, & ! intent(inout) + sclrm, & +#ifdef GFDL + sclrm_trsport_only, & ! h1g, 2010-06-16 ! intent(inout) +#endif + sclrp2, sclrprtp, sclrpthlp, & ! intent(inout) + wpsclrp, edsclrm, err_code, & ! intent(inout) +#ifdef GFDL + RH_crit, & !h1g, 2010-06-16 ! intent(inout) + do_liquid_only_in_clubb, & ! intent(in) +#endif + rcm, wprcp, cloud_frac, ice_supersat_frac, & ! intent(out) + rcm_in_layer, cloud_cover, & ! intent(out) +#if defined(CLUBB_CAM) || defined(GFDL) + khzm, khzt, & ! intent(out) +#endif +#ifdef CLUBB_CAM + qclvar, & ! intent(out) +#endif + pdf_params ) ! intent(out) + + use advance_clubb_core_module, only : advance_clubb_core + + use parameters_model, only: & + sclr_dim, & ! Variable(s) + edsclr_dim + + implicit none + !!! Input Variables + logical, intent(in) :: & + l_implemented ! Is this part of a larger host model (T/F) ? + + real( kind = core_rknd ), intent(in) :: & + dt ! Current timestep duration [s] + + real( kind = core_rknd ), intent(in) :: & + fcor, & ! Coriolis forcing [s^-1] + sfc_elevation ! Elevation of ground level [m AMSL] + + integer, intent(in) :: & + hydromet_dim ! Total number of hydrometeors [#] + + ! Input Variables + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + thlm_forcing, & ! theta_l forcing (thermodynamic levels) [K/s] + rtm_forcing, & ! r_t forcing (thermodynamic levels) [(kg/kg)/s] + um_forcing, & ! u wind forcing (thermodynamic levels) [m/s/s] + vm_forcing, & ! v wind forcing (thermodynamic levels) [m/s/s] + wprtp_forcing, & ! forcing (momentum levels) [m*K/s^2] + wpthlp_forcing, & ! forcing (momentum levels) [m*(kg/kg)/s^2] + rtp2_forcing, & ! forcing (momentum levels) [(kg/kg)^2/s] + thlp2_forcing, & ! forcing (momentum levels) [K^2/s] + rtpthlp_forcing, & ! forcing (momentum levels) [K*(kg/kg)/s] + wm_zm, & ! w mean wind component on momentum levels [m/s] + wm_zt, & ! w mean wind component on thermo. levels [m/s] + p_in_Pa, & ! Air pressure (thermodynamic levels) [Pa] + rho_zm, & ! Air density on momentum levels [kg/m^3] + rho, & ! Air density on thermodynamic levels [kg/m^3] + exner, & ! Exner function (thermodynamic levels) [-] + rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] + rho_ds_zt, & ! Dry, static density on thermo. levels [kg/m^3] + invrs_rho_ds_zm, & ! Inv. dry, static density @ momentum levs. [m^3/kg] + invrs_rho_ds_zt, & ! Inv. dry, static density @ thermo. levs. [m^3/kg] + thv_ds_zm, & ! Dry, base-state theta_v on momentum levs. [K] + thv_ds_zt, & ! Dry, base-state theta_v on thermo. levs. [K] + rfrzm ! Total ice-phase water mixing ratio [kg/kg] + + logical :: do_expldiff + + real( kind = core_rknd ), dimension(gr%nz,hydromet_dim), intent(in) :: & + hydromet ! Collection of hydrometeors [units vary] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + radf ! Buoyancy production at the CL top due to LW radiative cooling [m^2/s^3] + + real( kind = core_rknd ), dimension(gr%nz, hydromet_dim), intent(in) :: & + wphydrometp, & ! Covariance of w and a hydrometeor [(m/s) ] + wp2hmp, & ! Third moment: * [(m/s)^2 ] + rtphmp, & ! Covariance of rt and a hydrometeor [(kg/kg) ] + thlphmp ! Covariance of thl and a hydrometeor [K ] + + real( kind = core_rknd ), intent(in) :: & + wpthlp_sfc, & ! w' theta_l' at surface [(m K)/s] + wprtp_sfc, & ! w' r_t' at surface [(kg m)/( kg s)] + upwp_sfc, & ! u'w' at surface [m^2/s^2] + vpwp_sfc ! v'w' at surface [m^2/s^2] + + ! Passive scalar variables + real( kind = core_rknd ), intent(in), dimension(gr%nz,sclr_dim) :: & + sclrm_forcing ! Passive scalar forcing [{units vary}/s] + + real( kind = core_rknd ), intent(in), dimension(sclr_dim) :: & + wpsclrp_sfc ! Scalar flux at surface [{units vary} m/s] + + ! Eddy passive scalar variables + real( kind = core_rknd ), intent(in), dimension(gr%nz,edsclr_dim) :: & + edsclrm_forcing ! Eddy passive scalar forcing [{units vary}/s] + + real( kind = core_rknd ), intent(in), dimension(edsclr_dim) :: & + wpedsclrp_sfc ! Eddy-Scalar flux at surface [{units vary} m/s] + + ! Host model horizontal grid spacing, if part of host model. + real( kind = core_rknd ), intent(in) :: & + host_dx, & ! East-West horizontal grid spacing [m] + host_dy ! North-South horizontal grid spacing [m] + +#ifdef CLUBBND_CAM + real( kind = core_rknd ) :: varmu +#endif + + !!! Input/Output Variables + ! These are prognostic or are planned to be in the future + real( kind = core_rknd ), intent(inout), dimension(gr%nz) :: & + um, & ! u mean wind component (thermodynamic levels) [m/s] + upwp, & ! u'w' (momentum levels) [m^2/s^2] + vm, & ! v mean wind component (thermodynamic levels) [m/s] + vpwp, & ! v'w' (momentum levels) [m^2/s^2] + up2, & ! u'^2 (momentum levels) [m^2/s^2] + vp2, & ! v'^2 (momentum levels) [m^2/s^2] + rtm, & ! total water mixing ratio, r_t (thermo. levels) [kg/kg] + wprtp, & ! w' r_t' (momentum levels) [(kg/kg) m/s] + thlm, & ! liq. water pot. temp., th_l (thermo. levels) [K] + wpthlp, & ! w' th_l' (momentum levels) [(m/s) K] + rtp2, & ! r_t'^2 (momentum levels) [(kg/kg)^2] + thlp2, & ! th_l'^2 (momentum levels) [K^2] + rtpthlp, & ! r_t' th_l' (momentum levels) [(kg/kg) K] + wp2, & ! w'^2 (momentum levels) [m^2/s^2] + wp3 ! w'^3 (thermodynamic levels) [m^3/s^3] + + ! Passive scalar variables + real( kind = core_rknd ), intent(inout), dimension(gr%nz,sclr_dim) :: & + sclrm, & ! Passive scalar mean (thermo. levels) [units vary] + wpsclrp, & ! w'sclr' (momentum levels) [{units vary} m/s] + sclrp2, & ! sclr'^2 (momentum levels) [{units vary}^2] + sclrprtp, & ! sclr'rt' (momentum levels) [{units vary} (kg/kg)] + sclrpthlp ! sclr'thl' (momentum levels) [{units vary} K] + +#ifdef GFDL + real( kind = core_rknd ), intent(inout), dimension(gr%nz,sclr_dim) :: & ! h1g, 2010-06-16 + sclrm_trsport_only ! Passive scalar concentration due to pure transport [{units vary}/s] +#endif + + real( kind = core_rknd ), intent(inout), dimension(gr%nz,edsclr_dim) :: & + edsclrm ! Eddy passive scalar mean (thermo. levels) [units vary] + + real( kind = core_rknd ), intent(out), dimension(gr%nz) :: & + rcm, & ! cloud water mixing ratio, r_c (thermo. levels) [kg/kg] + rcm_in_layer, & ! rcm in cloud layer [kg/kg] + cloud_cover ! cloud cover [-] + + type(pdf_parameter), dimension(gr%nz), intent(out) :: & + pdf_params ! PDF parameters [units vary] + + ! Variables that need to be output for use in host models + real( kind = core_rknd ), intent(out), dimension(gr%nz) :: & + wprcp, & ! w'r_c' (momentum levels) [(kg/kg) m/s] + cloud_frac, & ! cloud fraction (thermodynamic levels) [-] + ice_supersat_frac ! ice cloud fraction (thermodynamic levels) [-] + +#if defined(CLUBB_CAM) || defined(GFDL) + real( kind = core_rknd ), intent(out), dimension(gr%nz) :: & + khzt, & ! eddy diffusivity on thermo levels + khzm ! eddy diffusivity on momentum levels +#endif + + real( kind = core_rknd), dimension(gr%nz) :: thlprcp_out + +#ifdef CLUBB_CAM + real( kind = core_rknd), intent(out), dimension(gr%nz) :: & + qclvar ! cloud water variance +#endif + + !!! Output Variable + integer, intent(inout) :: err_code ! Diagnostic, for if some calculation goes amiss. + +#ifdef GFDL + ! hlg, 2010-06-16 + real( kind = core_rknd ), intent(inOUT), dimension(gr%nz, min(1,sclr_dim) , 2) :: & + RH_crit ! critical relative humidity for droplet and ice nucleation + logical, intent(in) :: do_liquid_only_in_clubb +#endif + call advance_clubb_core( & + l_implemented, dt, fcor, sfc_elevation, hydromet_dim, & ! intent(in) + thlm_forcing, rtm_forcing, um_forcing, vm_forcing, & ! intent(in) + sclrm_forcing, edsclrm_forcing, wprtp_forcing, & ! intent(in) + wpthlp_forcing, rtp2_forcing, thlp2_forcing, & ! intent(in) + rtpthlp_forcing, wm_zm, wm_zt, & ! intent(in) + wpthlp_sfc, wprtp_sfc, upwp_sfc, vpwp_sfc, & ! intent(in) + wpsclrp_sfc, wpedsclrp_sfc, & ! intent(in) + p_in_Pa, rho_zm, rho, exner, & ! intent(in) + rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & ! intent(in) + invrs_rho_ds_zt, thv_ds_zm, thv_ds_zt, hydromet, & ! intent(in) + rfrzm, radf,do_expldiff, & +#ifdef CLUBBND_CAM + varmu, & +#endif + wphydrometp, wp2hmp, rtphmp, thlphmp, & ! intent(in) + host_dx, host_dy, & ! intent(in) + um, vm, upwp, vpwp, up2, vp2, & ! intent(inout) + thlm, rtm, wprtp, wpthlp, & ! intent(inout) + wp2, wp3, rtp2, thlp2, rtpthlp, & ! intent(inout) + sclrm, & +#ifdef GFDL + sclrm_trsport_only, & ! h1g, 2010-06-16 ! intent(inout) +#endif + sclrp2, sclrprtp, sclrpthlp, & ! intent(inout) + wpsclrp, edsclrm, err_code, & ! intent(inout) +#ifdef GFDL + RH_crit, & !h1g, 2010-06-16 ! intent(inout) + do_liquid_only_in_clubb, & ! intent(in) +#endif + rcm, wprcp, cloud_frac, ice_supersat_frac, & ! intent(out) + rcm_in_layer, cloud_cover, & ! intent(out) +#if defined(CLUBB_CAM) || defined(GFDL) + khzm, khzt, thlprcp_out, & ! intent(out) +#endif +#ifdef CLUBB_CAM + qclvar, & ! intent(out) +#endif + pdf_params ) ! intent(out) + end subroutine advance_clubb_core_api + + !================================================================================================ + ! setup_clubb_core - Sets up the model for execution. + !================================================================================================ + + subroutine setup_clubb_core_api( & + nzmax, T0_in, ts_nudge_in, & ! intent(in) + hydromet_dim_in, sclr_dim_in, & ! intent(in) + sclr_tol_in, edsclr_dim_in, params, & ! intent(in) + l_host_applies_sfc_fluxes, & ! intent(in) + l_uv_nudge, saturation_formula, & ! intent(in) +#ifdef GFDL + I_sat_sphum, & ! intent(in) h1g, 2010-06-16 +#endif + l_implemented, grid_type, deltaz, zm_init, zm_top, & ! intent(in) + momentum_heights, thermodynamic_heights, & ! intent(in) + sfc_elevation, & ! intent(in) +#ifdef GFDL + cloud_frac_min , & ! intent(in) h1g, 2010-06-16 +#endif + err_code ) ! intent(out) + + use advance_clubb_core_module, only : setup_clubb_core + + use parameter_indices, only: & + nparams ! Variable(s) + +! TODO: This should be called from the api, but all the host models appear to call +! it directly or not at all. +! use model_flags, only: & +! setup_model_flags ! Subroutine + +#ifdef MKL + use csr_matrix_class, only: & + initialize_csr_class, & ! Subroutine + intlc_5d_5d_ja_size ! Variable + +#endif + + implicit none + + ! Input Variables + + integer, intent(in) :: nzmax ! Vertical grid levels [#] + + real( kind = core_rknd ), intent(in) :: & + sfc_elevation ! Elevation of ground level [m AMSL] + + logical, intent(in) :: l_implemented ! (T/F) CLUBB implemented in host model? + + ! If CLUBB is running on it's own, this option determines + ! if it is using: + ! 1) an evenly-spaced grid, + ! 2) a stretched (unevenly-spaced) grid entered on the + ! thermodynamic grid levels (with momentum levels set + ! halfway between thermodynamic levels), or + ! 3) a stretched (unevenly-spaced) grid entered on the + ! momentum grid levels (with thermodynamic levels set + ! halfway between momentum levels). + integer, intent(in) :: grid_type + + ! If the CLUBB model is running by itself, and is using an + ! evenly-spaced grid (grid_type = 1), it needs the vertical + ! grid spacing, momentum-level starting altitude, and maximum + ! altitude as input. + real( kind = core_rknd ), intent(in) :: & + deltaz, & ! Change in altitude per level [m] + zm_init, & ! Initial grid altitude (momentum level) [m] + zm_top ! Maximum grid altitude (momentum level) [m] + + ! If the CLUBB parameterization is implemented in a host model, + ! it needs to use the host model's momentum level altitudes + ! and thermodynamic level altitudes. + ! If the CLUBB model is running by itself, but is using a + ! stretched grid entered on thermodynamic levels (grid_type = 2), + ! it needs to use the thermodynamic level altitudes as input. + ! If the CLUBB model is running by itself, but is using a + ! stretched grid entered on momentum levels (grid_type = 3), + ! it needs to use the momentum level altitudes as input. + real( kind = core_rknd ), intent(in), dimension(nzmax) :: & + momentum_heights, & ! Momentum level altitudes (input) [m] + thermodynamic_heights ! Thermodynamic level altitudes (input) [m] + + ! Model parameters + real( kind = core_rknd ), intent(in) :: & + T0_in, ts_nudge_in + + integer, intent(in) :: & + hydromet_dim_in, & ! Number of hydrometeor species + sclr_dim_in, & ! Number of passive scalars + edsclr_dim_in ! Number of eddy-diff. passive scalars + + real( kind = core_rknd ), intent(in), dimension(sclr_dim_in) :: & + sclr_tol_in ! Thresholds for passive scalars + + real( kind = core_rknd ), intent(in), dimension(nparams) :: & + params ! Including C1, nu1, nu2, etc. + + ! Flags + logical, intent(in) :: & + l_uv_nudge, & ! Wind nudging + l_host_applies_sfc_fluxes ! Whether to apply for the surface flux + + character(len=*), intent(in) :: & + saturation_formula ! Approximation for saturation vapor pressure + +#ifdef GFDL + logical, intent(in) :: & ! h1g, 2010-06-16 begin mod + I_sat_sphum + + real( kind = core_rknd ), intent(in) :: & + cloud_frac_min ! h1g, 2010-06-16 end mod +#endif + + ! Output variables + integer, intent(out) :: & + err_code ! Diagnostic for a problem with the setup + + call setup_clubb_core & + ( nzmax, T0_in, ts_nudge_in, & ! intent(in) + hydromet_dim_in, sclr_dim_in, & ! intent(in) + sclr_tol_in, edsclr_dim_in, params, & ! intent(in) + l_host_applies_sfc_fluxes, & ! intent(in) + l_uv_nudge, saturation_formula, & ! intent(in) +#ifdef GFDL + I_sat_sphum, & ! intent(in) h1g, 2010-06-16 +#endif + l_implemented, grid_type, deltaz, zm_init, zm_top, & ! intent(in) + momentum_heights, thermodynamic_heights, & ! intent(in) + sfc_elevation, & ! intent(in) +#ifdef GFDL + cloud_frac_min , & ! intent(in) h1g, 2010-06-16 +#endif + err_code ) ! intent(out) + + end subroutine setup_clubb_core_api + + !================================================================================================ + ! cleanup_clubb_core_api - Frees memory used by the model. + !================================================================================================ + + subroutine cleanup_clubb_core_api( & + l_implemented ) + + use advance_clubb_core_module, only : cleanup_clubb_core + + implicit none + + ! Flag to see if CLUBB is running on it's own, + ! or if it's implemented as part of a host model. + logical, intent(in) :: l_implemented ! (T/F) + + call cleanup_clubb_core( & + l_implemented ) + end subroutine cleanup_clubb_core_api + + !================================================================================================ + ! gregorian2julian_day - Computes the number of days since 1 January 4713 BC. + !================================================================================================ + + integer function gregorian2julian_day_api( & + day, month, year ) + + use calendar, only : gregorian2julian_day + + implicit none + + ! Input Variables + integer, intent(in) :: & + day, & ! Gregorian Calendar Day for given Month [dd] + month, & ! Gregorian Calendar Month for given Year [mm] + year ! Gregorian Calendar Year [yyyy] + + gregorian2julian_day_api = gregorian2julian_day( & + day, month, year ) + end function gregorian2julian_day_api + + !================================================================================================ + ! compute_current_date - Computes the current date and the seconds since that date. + !================================================================================================ + + subroutine compute_current_date_api( & + previous_day, previous_month, & + previous_year, & + seconds_since_previous_date, & + current_day, current_month, & + current_year, & + seconds_since_current_date ) + + use calendar, only : compute_current_date + + implicit none + + ! Previous date + integer, intent(in) :: & + previous_day, & ! Day of the month [dd] + previous_month, & ! Month of the year [mm] + previous_year ! Year [yyyy] + + real(kind=time_precision), intent(in) :: & + seconds_since_previous_date ! [s] + + ! Output Variable(s) + + ! Current date + integer, intent(out) :: & + current_day, & ! Day of the month [dd] + current_month, & ! Month of the year [mm] + current_year ! Year [yyyy] + + real(kind=time_precision), intent(out) :: & + seconds_since_current_date + + call compute_current_date( & + previous_day, previous_month, & + previous_year, & + seconds_since_previous_date, & + current_day, current_month, & + current_year, & + seconds_since_current_date ) + end subroutine compute_current_date_api + + !================================================================================================ + ! leap_year - Determines if the given year is a leap year. + !================================================================================================ + + logical function leap_year_api( & + year ) + + use calendar, only : leap_year + + implicit none + + ! External + intrinsic :: mod + + ! Input Variable(s) + integer, intent(in) :: year ! Gregorian Calendar Year [yyyy] + + leap_year_api = leap_year( & + year ) + end function leap_year_api + + !================================================================================================ + ! setup_corr_varnce_array - Creates a correlation array with x'^2/xm^2 variables on the diagonal + !================================================================================================ + + subroutine setup_corr_varnce_array_api( & + input_file_cloud, input_file_below, iunit, sigma2_on_mu2_ratios ) + + use corr_varnce_module, only : setup_corr_varnce_array, sigma2_on_mu2_ratios_type + + implicit none + + ! External + intrinsic :: max, epsilon, trim + + ! Input Variables + integer, intent(in) :: & + iunit ! The file unit + + character(len=*), intent(in) :: & + input_file_cloud, & ! Path to the in cloud correlation file + input_file_below ! Path to the out of cloud correlation file + + type(sigma2_on_mu2_ratios_type), intent(in) :: & + sigma2_on_mu2_ratios ! Prescribed sigma^2/mu^2 ratios + + call setup_corr_varnce_array( & + input_file_cloud, input_file_below, iunit, sigma2_on_mu2_ratios ) + + end subroutine setup_corr_varnce_array_api + + !================================================================================================ + ! setup_pdf_indices - Sets up the iiPDF indices. + !================================================================================================ + + subroutine setup_pdf_indices_api( & + hydromet_dim, iirrm, iiNrm, & + iirim, iiNim, iirsm, iiNsm, & + iirgm, iiNgm ) + + use corr_varnce_module, only : setup_pdf_indices + + implicit none + + ! Input Variables + integer, intent(in) :: & + hydromet_dim ! Total number of hydrometeor species. + + integer, intent(in) :: & + iirrm, & ! Index of rain water mixing ratio + iiNrm, & ! Index of rain drop concentration + iirim, & ! Index of ice mixing ratio + iiNim, & ! Index of ice crystal concentration + iirsm, & ! Index of snow mixing ratio + iiNsm, & ! Index of snow flake concentration + iirgm, & ! Index of graupel mixing ratio + iiNgm ! Index of graupel concentration + + call setup_pdf_indices( & + hydromet_dim, iirrm, iiNrm, & + iirim, iiNim, iirsm, iiNsm, & + iirgm, iiNgm ) + end subroutine setup_pdf_indices_api + + !================================================================================================ + ! report_error - Reports the meaning of an error code to the console. + !================================================================================================ + + subroutine report_error_api( & + err_code) + + use error_code, only: & + report_error ! Procedure + + implicit none + + ! Input Variable + integer, intent(in) :: err_code ! Error Code being examined + + call report_error( & + err_code) + end subroutine report_error_api + + !================================================================================================ + ! fatal_error - Checks to see if an error code is usually one which causes an exit elsewhere. + !================================================================================================ + + elemental function fatal_error_api( & + err_code ) + + use error_code, only : fatal_error + + implicit none + + ! Input Variable + integer, intent(in) :: err_code ! Error Code being examined + + ! Output variable + logical :: fatal_error_api + + fatal_error_api = fatal_error( & + err_code ) + end function fatal_error_api + + !================================================================================================ + ! set_clubb_debug_level - Controls the importance of error messages sent to the console. + !================================================================================================ + + subroutine set_clubb_debug_level_api( & + level ) + + use error_code, only : set_clubb_debug_level + + implicit none + + ! Input variable + integer, intent(in) :: level ! The debug level being checked against the current setting + + call set_clubb_debug_level( & + level ) + end subroutine set_clubb_debug_level_api + + !================================================================================================ + ! clubb_at_least_debug_level - Checks to see if clubb has been set to a specified debug level. + !================================================================================================ + + logical function clubb_at_least_debug_level_api( & + level ) + + use error_code, only : clubb_at_least_debug_level + + implicit none + + ! Input variable + integer, intent(in) :: level ! The debug level being checked against the current setting + + clubb_at_least_debug_level_api = clubb_at_least_debug_level( & + level ) + end function clubb_at_least_debug_level_api + + !================================================================================================ + ! fill_holes_driver - Fills holes between same-phase hydrometeors(i.e. for frozen hydrometeors). + !================================================================================================ + + subroutine fill_holes_driver_api( & + nz, dt, hydromet_dim, & ! Intent(in) + l_fill_holes_hm, & ! Intent(in) + rho_ds_zm, rho_ds_zt, exner, & ! Intent(in) + thlm_mc, rvm_mc, hydromet ) ! Intent(inout) + + use fill_holes, only : fill_holes_driver + + use constants_clubb, only: & + four_thirds, & + rho_ice + + use array_index, only: & + l_mix_rat_hm ! Variable(s) + + implicit none + + intrinsic :: trim + + ! Input Variables + integer, intent(in) :: hydromet_dim, nz + + logical, intent(in) :: l_fill_holes_hm + + real( kind = core_rknd ), intent(in) :: & + dt ! Timestep [s] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] + rho_ds_zt ! Dry, static density on thermo. levels [kg/m^3] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + exner ! Exner function [-] + + ! Input/Output Variables + real( kind = core_rknd ), dimension(nz, hydromet_dim), intent(inout) :: & + hydromet + + real( kind = core_rknd ), dimension(nz), intent(inout) :: & + rvm_mc, & ! Microphysics contributions to vapor water [kg/kg/s] + thlm_mc ! Microphysics contributions to liquid potential temp. [K/s] + + call fill_holes_driver( & + nz, dt, hydromet_dim, & ! Intent(in) + l_fill_holes_hm, & ! Intent(in) + rho_ds_zm, rho_ds_zt, exner, & ! Intent(in) + thlm_mc, rvm_mc, hydromet ) ! Intent(inout) + end subroutine fill_holes_driver_api + + !================================================================================================ + ! fill_holes_vertical - clips values of 'field' that are below 'threshold' as much as possible. + !================================================================================================ + + subroutine fill_holes_vertical_api( & + num_pts, threshold, field_grid, & + rho_ds, rho_ds_zm, & + field ) + + use fill_holes, only : fill_holes_vertical + + implicit none + + ! Input variables + integer, intent(in) :: & + num_pts ! The number of points on either side of the hole; + ! Mass is drawn from these points to fill the hole. [] + + real( kind = core_rknd ), intent(in) :: & + threshold ! A threshold (e.g. w_tol*w_tol) below which field must not + ! fall [Units vary; same as field] + + character(len=2), intent(in) :: & + field_grid ! The grid of the field, either stats_zt or stats_zm + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + rho_ds, & ! Dry, static density on thermodynamic levels [kg/m^3] + rho_ds_zm ! Dry, static density on momentum levels [kg/m^3] + + ! Input/Output variable + real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & + field ! The field (e.g. wp2) that contains holes [Units same as threshold] + + call fill_holes_vertical( & + num_pts, threshold, field_grid, & + rho_ds, rho_ds_zm, & + field ) + end subroutine fill_holes_vertical_api + + !================================================================================================ + ! vertical_integral - Computes the vertical integral. + !================================================================================================ + + function vertical_integral_api( & + total_idx, rho_ds, & + field, invrs_dz ) + + use fill_holes, only : vertical_integral + + implicit none + + ! Input variables + integer, intent(in) :: & + total_idx ! The total numer of indices within the range of averaging + + real( kind = core_rknd ), dimension(total_idx), intent(in) :: & + rho_ds, & ! Dry, static density [kg/m^3] + field, & ! The field to be vertically averaged [Units vary] + invrs_dz ! Level thickness [1/m] + ! Note: The rho_ds and field points need to be arranged from + ! lowest to highest in altitude, with rho_ds(1) and + ! field(1) actually their respective values at level k = begin_idx. + + real( kind = core_rknd ) :: & + vertical_integral_api ! Integral in the numerator (see description) + + vertical_integral_api = vertical_integral( & + total_idx, rho_ds, & + field, invrs_dz ) + end function vertical_integral_api + + !================================================================================================ + ! setup_grid_heights - Sets the heights and interpolation weights of the column. + !================================================================================================ + + subroutine setup_grid_heights_api( & + l_implemented, grid_type, & + deltaz, zm_init, momentum_heights, & + thermodynamic_heights ) + + use grid_class, only : setup_grid_heights, gr + + implicit none + + ! Input Variables + + ! Flag to see if CLUBB is running on it's own, + ! or if it's implemented as part of a host model. + logical, intent(in) :: l_implemented + + ! If CLUBB is running on it's own, this option determines if it is using: + ! 1) an evenly-spaced grid; + ! 2) a stretched (unevenly-spaced) grid entered on the thermodynamic grid + ! levels (with momentum levels set halfway between thermodynamic levels); + ! or + ! 3) a stretched (unevenly-spaced) grid entered on the momentum grid levels + ! (with thermodynamic levels set halfway between momentum levels). + integer, intent(in) :: grid_type + + ! If the CLUBB model is running by itself, and is using an evenly-spaced + ! grid (grid_type = 1), it needs the vertical grid spacing and + ! momentum-level starting altitude as input. + real( kind = core_rknd ), intent(in) :: & + deltaz, & ! Vertical grid spacing [m] + zm_init ! Initial grid altitude (momentum level) [m] + + + ! If the CLUBB parameterization is implemented in a host model, it needs to + ! use the host model's momentum level altitudes and thermodynamic level + ! altitudes. + ! If the CLUBB model is running by itself, but is using a stretched grid + ! entered on thermodynamic levels (grid_type = 2), it needs to use the + ! thermodynamic level altitudes as input. + ! If the CLUBB model is running by itself, but is using a stretched grid + ! entered on momentum levels (grid_type = 3), it needs to use the momentum + ! level altitudes as input. + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + momentum_heights, & ! Momentum level altitudes (input) [m] + thermodynamic_heights ! Thermodynamic level altitudes (input) [m] + + call setup_grid_heights( & + l_implemented, grid_type, & + deltaz, zm_init, momentum_heights, & + thermodynamic_heights ) + + end subroutine setup_grid_heights_api + + + !================================================================================================ + ! lin_interpolate_two_points - Computes a linear interpolation of the value of a variable. + !================================================================================================ + + function lin_interpolate_two_points_api( & + height_int, height_high, height_low, & + var_high, var_low ) + + use interpolation, only : lin_interpolate_two_points + + implicit none + + real( kind = core_rknd ), intent(in) :: & + height_int, & ! Height to be interpolated to [m] + height_high, & ! Height above the interpolation [m] + height_low, & ! Height below the interpolation [m] + var_high, & ! Variable above the interpolation [units vary] + var_low ! Variable below the interpolation [units vary] + + ! Output Variables + real( kind = core_rknd ) :: lin_interpolate_two_points_api + + lin_interpolate_two_points_api = lin_interpolate_two_points( & + height_int, height_high, height_low, & + var_high, var_low ) + + end function lin_interpolate_two_points_api + + !================================================================================================ + ! lin_interpolate_on_grid - Linear interpolation for 25 June 1996 altocumulus case. + !================================================================================================ + + subroutine lin_interpolate_on_grid_api( & + nparam, xlist, tlist, xvalue, tvalue ) + + use interpolation, only : lin_interpolate_on_grid + + implicit none + + ! Input Variables + integer, intent(in) :: nparam ! Number of parameters in xlist and tlist + + ! Input/Output Variables + real( kind = core_rknd ), intent(inout), dimension(nparam) :: & + xlist, & ! List of x-values (independent variable) + tlist ! List of t-values (dependent variable) + + real( kind = core_rknd ), intent(in) :: & + xvalue ! x-value at which to interpolate + + real( kind = core_rknd ), intent(inout) :: & + tvalue ! t-value solved by interpolation + + call lin_interpolate_on_grid( & + nparam, xlist, tlist, xvalue, tvalue ) + + end subroutine lin_interpolate_on_grid_api + + !================================================================================================ + ! read_parameters - Read a namelist containing the model parameters. + !================================================================================================ + + subroutine read_parameters_api( & + iunit, filename, params ) + + use parameters_tunable, only : read_parameters + + use parameter_indices, only: & + nparams ! Variable(s) + + implicit none + + ! Input variables + integer, intent(in) :: iunit + + character(len=*), intent(in) :: filename + + ! Output variables + real( kind = core_rknd ), intent(out), dimension(nparams) :: params + + call read_parameters( & + iunit, filename, params ) + + end subroutine read_parameters_api + + !================================================================================================ + ! setup_parameters - Sets up model parameters. + !================================================================================================ + + subroutine setup_parameters_api( & + deltaz, params, nzmax, & + grid_type, momentum_heights, thermodynamic_heights, & + err_code ) + + use parameters_tunable, only: & + setup_parameters + + use constants_clubb, only: & + fstderr ! Variable(s) + + use error_code, only: & + clubb_var_out_of_bounds ! Variable(s) + + use parameter_indices, only: & + nparams ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + deltaz ! Change per height level [m] + + real( kind = core_rknd ), intent(in), dimension(nparams) :: & + params ! Tuneable model parameters [-] + + ! Grid definition + integer, intent(in) :: nzmax ! Vertical grid levels [#] + + ! If CLUBB is running on its own, this option determines + ! if it is using: + ! 1) an evenly-spaced grid, + ! 2) a stretched (unevenly-spaced) grid entered on the + ! thermodynamic grid levels (with momentum levels set + ! halfway between thermodynamic levels), or + ! 3) a stretched (unevenly-spaced) grid entered on the + ! momentum grid levels (with thermodynamic levels set + ! halfway between momentum levels). + integer, intent(in) :: grid_type + + ! If the CLUBB parameterization is implemented in a host model, + ! it needs to use the host model's momentum level altitudes + ! and thermodynamic level altitudes. + ! If the CLUBB model is running by itself, but is using a + ! stretched grid entered on thermodynamic levels (grid_type = 2), + ! it needs to use the thermodynamic level altitudes as input. + ! If the CLUBB model is running by itself, but is using a + ! stretched grid entered on momentum levels (grid_type = 3), + ! it needs to use the momentum level altitudes as input. + real( kind = core_rknd ), intent(in), dimension(nzmax) :: & + momentum_heights, & ! Momentum level altitudes (input) [m] + thermodynamic_heights ! Thermodynamic level altitudes (input) [m] + + ! Output Variables + integer, intent(out) :: & + err_code ! Error condition + + call setup_parameters( & + deltaz, params, nzmax, & + grid_type, momentum_heights, thermodynamic_heights, & + err_code ) + + end subroutine setup_parameters_api + + !================================================================================================ + ! adj_low_res_nu - Adjusts values of background eddy diffusivity based on vertical grid spacing. + !================================================================================================ + + subroutine adj_low_res_nu_api( & + nzmax, grid_type, deltaz, & ! Intent(in) + momentum_heights, thermodynamic_heights ) ! Intent(in) + + use parameters_tunable, only : adj_low_res_nu + + implicit none + + ! Input Variables + + ! Grid definition + integer, intent(in) :: nzmax ! Vertical grid levels [#] + + ! If CLUBB is running on it's own, this option determines + ! if it is using: + ! 1) an evenly-spaced grid, + ! 2) a stretched (unevenly-spaced) grid entered on the + ! thermodynamic grid levels (with momentum levels set + ! halfway between thermodynamic levels), or + ! 3) a stretched (unevenly-spaced) grid entered on the + ! momentum grid levels (with thermodynamic levels set + ! halfway between momentum levels). + integer, intent(in) :: grid_type + + real( kind = core_rknd ), intent(in) :: & + deltaz ! Change per height level [m] + + ! If the CLUBB parameterization is implemented in a host model, + ! it needs to use the host model's momentum level altitudes + ! and thermodynamic level altitudes. + ! If the CLUBB model is running by itself, but is using a + ! stretched grid entered on thermodynamic levels (grid_type = 2), + ! it needs to use the thermodynamic level altitudes as input. + ! If the CLUBB model is running by itself, but is using a + ! stretched grid entered on momentum levels (grid_type = 3), + ! it needs to use the momentum level altitudes as input. + real( kind = core_rknd ), intent(in), dimension(nzmax) :: & + momentum_heights, & ! Momentum level altitudes (input) [m] + thermodynamic_heights ! Thermodynamic level altitudes (input) [m] + + call adj_low_res_nu( & + nzmax, grid_type, deltaz, & ! Intent(in) + momentum_heights, thermodynamic_heights ) ! Intent(in) + end subroutine adj_low_res_nu_api + +#ifdef CLUBB_CAM /* Code for storing pdf_parameter structs in pbuf as array */ + !================================================================================================ + ! pack_pdf_params - Returns a two dimensional real array with all values. + !================================================================================================ + + subroutine pack_pdf_params_api( & + pdf_params, nz, r_param_array) + + use pdf_parameter_module, only : pack_pdf_params + + !use statements + + implicit none + + ! Input a pdf_parameter array with nz instances of pdf_parameter + integer, intent(in) :: nz ! Num Vert Model Levs + type (pdf_parameter), dimension(nz), intent(in) :: pdf_params + + ! Output a two dimensional real array with all values + real (kind = core_rknd), dimension(nz,num_pdf_params), intent(out) :: & + r_param_array + + call pack_pdf_params( & + pdf_params, nz, r_param_array) + + end subroutine pack_pdf_params_api + + !================================================================================================ + ! unpack_pdf_params - Returns a pdf_parameter array with nz instances of pdf_parameter. + !================================================================================================ + + subroutine unpack_pdf_params_api( & + r_param_array, nz, pdf_params) + + use pdf_parameter_module, only : unpack_pdf_params + + implicit none + + ! Input a two dimensional real array with pdf values + integer, intent(in) :: nz ! Num Vert Model Levs + real (kind = core_rknd), dimension(nz,num_pdf_params), intent(in) :: & + r_param_array + + ! Output a pdf_parameter array with nz instances of pdf_parameter + type (pdf_parameter), dimension(nz), intent(out) :: pdf_params + + call unpack_pdf_params( & + r_param_array, nz, pdf_params) + end subroutine unpack_pdf_params_api +#endif + + !================================================================================================ + ! setup_pdf_parameters + !================================================================================================ + + subroutine setup_pdf_parameters_api( & + nz, d_variables, dt, rho, & ! Intent(in) + Nc_in_cloud, rcm, cloud_frac, & ! Intent(in) + ice_supersat_frac, hydromet, wphydrometp, & ! Intent(in) + corr_array_cloud, corr_array_below, & ! Intent(in) + pdf_params, l_stats_samp, & ! Intent(in) + hydrometp2, & ! Intent(inout) + mu_x_1_n, mu_x_2_n, & ! Intent(out) + sigma_x_1_n, sigma_x_2_n, & ! Intent(out) + corr_array_1_n, corr_array_2_n, & ! Intent(out) + corr_cholesky_mtx_1, corr_cholesky_mtx_2, & ! Intent(out) + hydromet_pdf_params ) ! Intent(out) + + use setup_clubb_pdf_params, only : setup_pdf_parameters + + use constants_clubb, only: & + one, & ! Constant(s) + Ncn_tol, & + cloud_frac_min + + use advance_windm_edsclrm_module, only: & + xpwp_fnc + + use variables_diagnostic_module, only: & + Kh_zm + + use parameters_tunable, only: & + c_K_hm + + use clip_explicit, only: & + clip_wphydrometp ! Variables(s) + + use stats_variables, only: & + ihm1, & ! Variable(s) + ihm2, & + iprecip_frac, & + iprecip_frac_1, & + iprecip_frac_2, & + iNcnm, & + ihmp2_zt, & + stats_zt + + use model_flags, only: & + l_diagnose_correlations ! Variable(s) + + implicit none + + ! Input Variables + integer, intent(in) :: & + nz, & ! Number of model vertical grid levels + d_variables ! Number of variables in the correlation array + + real( kind = core_rknd ), intent(in) :: & + dt ! Model timestep [s] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + rho, & ! Density [kg/m^3] + Nc_in_cloud ! Mean (in-cloud) cloud droplet concentration [num/kg] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + rcm, & ! Mean cloud water mixing ratio, < r_c > [kg/kg] + cloud_frac, & ! Cloud fraction [-] + ice_supersat_frac ! Ice supersaturation fraction [-] + + real( kind = core_rknd ), dimension(nz,hydromet_dim), intent(in) :: & + hydromet, & ! Mean of hydrometeor, hm (overall) (t-levs.) [units] + wphydrometp ! Covariance < w'h_m' > (momentum levels) [(m/s)units] + + real( kind = core_rknd ), dimension(d_variables,d_variables), & + intent(in) :: & + corr_array_cloud, & ! Prescribed correlation array in cloud [-] + corr_array_below ! Prescribed correlation array below cloud [-] + + type(pdf_parameter), dimension(nz), intent(in) :: & + pdf_params ! PDF parameters [units vary] + + logical, intent(in) :: & + l_stats_samp ! Flag to sample statistics + + ! Input/Output Variables + real( kind = core_rknd ), dimension(nz,hydromet_dim), intent(inout) :: & + hydrometp2 ! Variance of a hydrometeor (overall) (m-levs.) [units^2] + + ! Output Variables + real( kind = core_rknd ), dimension(d_variables,d_variables,nz), & + intent(out) :: & + corr_array_1_n, & ! Corr. array (normalized) of PDF vars. (comp. 1) [-] + corr_array_2_n ! Corr. array (normalized) of PDF vars. (comp. 2) [-] + + real( kind = core_rknd ), dimension(d_variables, nz), intent(out) :: & + mu_x_1_n, & ! Mean array (normalized) of PDF vars. (comp. 1) [un. vary] + mu_x_2_n, & ! Mean array (normalized) of PDF vars. (comp. 2) [un. vary] + sigma_x_1_n, & ! Std. dev. array (normalized) of PDF vars (comp. 1) [u.v.] + sigma_x_2_n ! Std. dev. array (normalized) of PDF vars (comp. 2) [u.v.] + + type(hydromet_pdf_parameter), dimension(nz), intent(out) :: & + hydromet_pdf_params ! Hydrometeor PDF parameters [units vary] + + real( kind = core_rknd ), dimension(d_variables,d_variables,nz), & + intent(out) :: & + corr_cholesky_mtx_1, & ! Transposed corr. cholesky matrix, 1st comp. [-] + corr_cholesky_mtx_2 ! Transposed corr. cholesky matrix, 2nd comp. [-] + + call setup_pdf_parameters( & + nz, d_variables, dt, rho, & ! Intent(in) + Nc_in_cloud, rcm, cloud_frac, & ! Intent(in) + ice_supersat_frac, hydromet, wphydrometp, & ! Intent(in) + corr_array_cloud, corr_array_below, & ! Intent(in) + pdf_params, l_stats_samp, & ! Intent(in) + hydrometp2, & ! Intent(inout) + mu_x_1_n, mu_x_2_n, & ! Intent(out) + sigma_x_1_n, sigma_x_2_n, & ! Intent(out) + corr_array_1_n, corr_array_2_n, & ! Intent(out) + corr_cholesky_mtx_1, corr_cholesky_mtx_2, & ! Intent(out) + hydromet_pdf_params ) ! Intent(out) + + end subroutine setup_pdf_parameters_api + + !================================================================================================ + ! stats_init - Initializes the statistics saving functionality of the CLUBB model. + !================================================================================================ + + subroutine stats_init_api( & + iunit, fname_prefix, fdir, l_stats_in, & + stats_fmt_in, stats_tsamp_in, stats_tout_in, fnamelist, & + nzmax, nlon, nlat, gzt, gzm, nnrad_zt, & + grad_zt, nnrad_zm, grad_zm, day, month, year, & + rlon, rlat, time_current, delt, l_silhs_out_in ) + + use stats_clubb_utilities, only : stats_init + + implicit none + + ! Input Variables + integer, intent(in) :: iunit ! File unit for fnamelist + + character(len=*), intent(in) :: & + fname_prefix, & ! Start of the stats filenames + fdir ! Directory to output to + + logical, intent(in) :: & + l_stats_in ! Stats on? T/F + + character(len=*), intent(in) :: & + stats_fmt_in ! Format of the stats file output + + real( kind = core_rknd ), intent(in) :: & + stats_tsamp_in, & ! Sampling interval [s] + stats_tout_in ! Output interval [s] + + character(len=*), intent(in) :: & + fnamelist ! Filename holding the &statsnl + + integer, intent(in) :: & + nlon, & ! Number of points in the X direction [-] + nlat, & ! Number of points in the Y direction [-] + nzmax ! Grid points in the vertical [-] + + real( kind = core_rknd ), intent(in), dimension(nzmax) :: & + gzt, gzm ! Thermodynamic and momentum levels [m] + + integer, intent(in) :: nnrad_zt ! Grid points in the radiation grid [count] + + real( kind = core_rknd ), intent(in), dimension(nnrad_zt) :: grad_zt ! Radiation levels [m] + + integer, intent(in) :: nnrad_zm ! Grid points in the radiation grid [count] + + real( kind = core_rknd ), intent(in), dimension(nnrad_zm) :: grad_zm ! Radiation levels [m] + + integer, intent(in) :: day, month, year ! Time of year + + real( kind = core_rknd ), dimension(nlon), intent(in) :: & + rlon ! Longitude(s) [Degrees E] + + real( kind = core_rknd ), dimension(nlat), intent(in) :: & + rlat ! Latitude(s) [Degrees N] + + real( kind = time_precision ), intent(in) :: & + time_current ! Model time [s] + + real( kind = core_rknd ), intent(in) :: & + delt ! Timestep (dt_main in CLUBB) [s] + + logical, intent(in) :: & + l_silhs_out_in ! Whether to output SILHS files (stats_lh_zt,stats_lh_sfc) [dimensionless] + + call stats_init( & + iunit, fname_prefix, fdir, l_stats_in, & + stats_fmt_in, stats_tsamp_in, stats_tout_in, fnamelist, & + nzmax, nlon, nlat, gzt, gzm, nnrad_zt, & + grad_zt, nnrad_zm, grad_zm, day, month, year, & + rlon, rlat, time_current, delt, l_silhs_out_in ) + end subroutine stats_init_api + + !================================================================================================ + ! stats_begin_timestep - Sets flags determining specific timestep info. + !================================================================================================ + + subroutine stats_begin_timestep_api( & + itime, stats_nsamp, stats_nout ) + + + use stats_clubb_utilities, only : stats_begin_timestep + + implicit none + + ! External + intrinsic :: mod + + ! Input Variable(s) + integer, intent(in) :: & + itime, & ! Elapsed model time [timestep] + stats_nsamp, & ! Stats sampling interval [timestep] + stats_nout ! Stats output interval [timestep] + + call stats_begin_timestep( & + itime, stats_nsamp, stats_nout ) + end subroutine stats_begin_timestep_api + + !================================================================================================ + ! stats_end_timestep - Calls statistics to be written to the output format. + !================================================================================================ + + subroutine stats_end_timestep_api + + use stats_clubb_utilities, only : stats_end_timestep + + implicit none + + call stats_end_timestep + + end subroutine stats_end_timestep_api + + !================================================================================================ + ! stats_accumulate_hydromet - Computes stats related the hydrometeors. + !================================================================================================ + + subroutine stats_accumulate_hydromet_api( & + hydromet, rho_ds_zt ) + + use stats_clubb_utilities, only : stats_accumulate_hydromet + + implicit none + + ! Input Variables + real( kind = core_rknd ), dimension(gr%nz,hydromet_dim), intent(in) :: & + hydromet ! All hydrometeors except for rcm [units vary] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + rho_ds_zt ! Dry, static density (thermo. levs.) [kg/m^3] + + call stats_accumulate_hydromet( & + hydromet, rho_ds_zt ) + end subroutine stats_accumulate_hydromet_api + + !================================================================================================ + ! stats_finalize - Close NetCDF files and deallocate scratch space and stats file structures. + !================================================================================================ + + subroutine stats_finalize_api + + use stats_clubb_utilities, only : stats_finalize + + implicit none + + call stats_finalize + + end subroutine stats_finalize_api + + !================================================================================================ + ! stats_init_rad_zm - Initializes array indices for rad_zm variables. + !================================================================================================ + + subroutine stats_init_rad_zm_api( & + vars_rad_zm, l_error ) + + use stats_rad_zm_module, only : stats_init_rad_zm, nvarmax_rad_zm + + implicit none + + ! Input Variable + character(len= * ), dimension(nvarmax_rad_zm), intent(in) :: vars_rad_zm + + ! Input/Output Variable + logical, intent(inout) :: l_error + + call stats_init_rad_zm( & + vars_rad_zm, l_error ) + end subroutine stats_init_rad_zm_api + + !================================================================================================ + ! stats_init_rad_zt - Initializes array indices for zt. + !================================================================================================ + + subroutine stats_init_rad_zt_api( & + vars_rad_zt, l_error ) + + use stats_rad_zt_module, only : stats_init_rad_zt, nvarmax_rad_zt + + implicit none + + ! Input Variable + character(len= * ), dimension(nvarmax_rad_zt), intent(in) :: vars_rad_zt + + ! Input/Output Variable + logical, intent(inout) :: l_error + + call stats_init_rad_zt( & + vars_rad_zt, l_error ) + end subroutine stats_init_rad_zt_api + + !================================================================================================ + ! stats_init_zm - Initializes array indices for zm. + !================================================================================================ + + subroutine stats_init_zm_api( & + vars_zm, l_error ) + + use stats_zm_module, only : stats_init_zm, nvarmax_zm + + implicit none + + ! Input Variable + character(len= * ), dimension(nvarmax_zm), intent(in) :: vars_zm ! zm variable names + + ! Input / Output Variable + logical, intent(inout) :: l_error + + call stats_init_zm( & + vars_zm, l_error ) + + end subroutine stats_init_zm_api + + !================================================================================================ + ! stats_init_zt - Initializes array indices for zt. + !================================================================================================ + + subroutine stats_init_zt_api( & + vars_zt, l_error ) + + use stats_zt_module, only : stats_init_zt, nvarmax_zt + + implicit none + + ! Input Variable + character(len= * ), dimension(nvarmax_zt), intent(in) :: vars_zt + + ! Input / Output Variable + logical, intent(inout) :: l_error + + call stats_init_zt( & + vars_zt, l_error ) + + end subroutine stats_init_zt_api + + !================================================================================================ + ! stats_init_sfc - Initializes array indices for sfc. + !================================================================================================ + + subroutine stats_init_sfc_api( & + vars_sfc, l_error ) + + use stats_sfc_module, only : stats_init_sfc, nvarmax_sfc + + implicit none + + ! Input Variable + character(len= * ), dimension(nvarmax_sfc), intent(in) :: vars_sfc + + ! Input / Output Variable + logical, intent(inout) :: l_error + + call stats_init_sfc( & + vars_sfc, l_error ) + + end subroutine stats_init_sfc_api + + !================================================================================================ + ! thlm2T_in_K - Calculates absolute temperature from liquid water potential temperature. + !================================================================================================ + + elemental function thlm2T_in_K_api( & + thlm, exner, rcm ) & + result( T_in_K ) + + use T_in_K_module, only : thlm2T_in_K + + implicit none + + ! Input + real( kind = core_rknd ), intent(in) :: & + thlm, & ! Liquid potential temperature [K] + exner, & ! Exner function [-] + rcm ! Liquid water mixing ratio [kg/kg] + + real( kind = core_rknd ) :: & + T_in_K ! Result temperature [K] + + T_in_K = thlm2T_in_K( & + thlm, exner, rcm ) + + end function thlm2T_in_K_api + + !================================================================================================ + ! T_in_K2thlm - Calculates liquid water potential temperature from absolute temperature + !================================================================================================ + + elemental function T_in_K2thlm_api( & + T_in_K, exner, rcm ) & + result( thlm ) + + use T_in_K_module, only : T_in_K2thlm + + implicit none + + ! Input + real( kind = core_rknd ), intent(in) :: & + T_in_K, &! Result temperature [K] + exner, & ! Exner function [-] + rcm ! Liquid water mixing ratio [kg/kg] + + real( kind = core_rknd ) :: & + thlm ! Liquid potential temperature [K] + + thlm = T_in_K2thlm( & + T_in_K, exner, rcm ) + + end function T_in_K2thlm_api + + !================================================================================================ + ! calculate_spurious_source - Checks whether there is conservation within the column. + !================================================================================================ + function calculate_spurious_source_api ( & + integral_after, integral_before, & + flux_top, flux_sfc, & + integral_forcing, dt ) result( spurious_source ) + + use numerical_check, only : calculate_spurious_source + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + integral_after, & ! Vertically-integrated quantity after dt time [units vary] + integral_before, & ! Vertically-integrated quantity before dt time [units vary] + flux_top, & ! Total flux at the top of the domain [units vary] + flux_sfc, & ! Total flux at the bottom of the domain [units vary] + integral_forcing, & ! Vertically-integrated forcing [units vary] + dt ! Timestep size [s] + + ! Return Variable + real( kind = core_rknd ) :: spurious_source ! [units vary] + + spurious_source = calculate_spurious_source( & + integral_after, integral_before, & + flux_top, flux_sfc, & + integral_forcing, dt ) + + end function calculate_spurious_source_api + +end module clubb_api_module diff --git a/models/atm/cam/src/physics/clubb/clubb_core.F90 b/models/atm/cam/src/physics/clubb/clubb_core.F90 deleted file mode 100644 index 24fa27bcb62a..000000000000 --- a/models/atm/cam/src/physics/clubb/clubb_core.F90 +++ /dev/null @@ -1,2657 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: clubb_core.F90 5654 2012-01-23 20:25:55Z dschanen@uwm.edu $ -!----------------------------------------------------------------------- -module clubb_core - -! Description: -! The module containing the `core' of the CLUBB parameterization. -! A host model implementing CLUBB should only require this subroutine -! and the functions and subroutines it calls. -! -! References: -! ``A PDF-Based Model for Boundary Layer Clouds. Part I: -! Method and Model Description'' Golaz, et al. (2002) -! JAS, Vol. 59, pp. 3540--3551. -! -! Copyright Notice: -! -! This code and the source code it references are (C) 2006-2011 -! Jean-Christophe Golaz, Vincent E. Larson, Brian M. Griffin, -! David P. Schanen, Adam J. Smith, and Michael J. Falk. -! -! The distribution of this code and derived works thereof -! should include this notice. -! -! Portions of this code derived from other sources (Hugh Morrison, -! ACM TOMS, Numerical Recipes, et cetera) are the intellectual -! property of their respective authors as noted and are also subject -! to copyright. -!----------------------------------------------------------------------- - - implicit none - - public :: & - setup_clubb_core, & - advance_clubb_core, & - cleanup_clubb_core, & - set_Lscale_max - - private ! Default Scope - - contains - - !----------------------------------------------------------------------- - subroutine advance_clubb_core & - ( l_implemented, dt, fcor, sfc_elevation, & - thlm_forcing, rtm_forcing, um_forcing, vm_forcing, & - sclrm_forcing, edsclrm_forcing, wm_zm, wm_zt, & - wpthlp_sfc, wprtp_sfc, upwp_sfc, vpwp_sfc, & - wpsclrp_sfc, wpedsclrp_sfc, & - p_in_Pa, rho_zm, rho, exner, & - rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & - invrs_rho_ds_zt, thv_ds_zm, thv_ds_zt, & - um, vm, upwp, vpwp, up2, vp2, & - thlm, rtm, wprtp, wpthlp, & - wp2, wp3, rtp2, thlp2, rtpthlp, & - sclrm, & -#ifdef GFDL - sclrm_trsport_only, & ! h1g, 2010-06-16 -#endif - sclrp2, sclrprtp, sclrpthlp, & - wpsclrp, edsclrm, err_code, & -#ifdef GFDL - RH_crit, & ! h1g, 2010-06-16 -#endif - rcm, wprcp, cloud_frac, & - rcm_in_layer, cloud_cover, & -#ifdef CLUBB_CAM - khzm, khzt, qclvar, & -#endif - pdf_params ) - - ! Description: - ! Subroutine to advance the model one timestep - - ! References: - ! ``A PDF-Based Model for Boundary Layer Clouds. Part I: - ! Method and Model Description'' Golaz, et al. (2002) - ! JAS, Vol. 59, pp. 3540--3551. - !----------------------------------------------------------------------- - - ! Modules to be included - - use constants_clubb, only: & - w_tol, & ! Variable(s) - em_min, & - thl_tol, & - rt_tol, & - w_tol_sqd, & - ep2, & - Cp, & - Lv, & - ep1, & - eps, & - p0, & - kappa, & - fstderr, & - zero_threshold, & - three_halves - - use parameters_tunable, only: & - gamma_coefc, & ! Variable(s) - gamma_coefb, & - gamma_coef, & - taumax, & - c_K, & - mu, & - Lscale_mu_coef, & - Lscale_pert_coef - - use parameters_model, only: & - sclr_dim, & ! Variable(s) - edsclr_dim, & - sclr_tol - - use model_flags, only: & - l_tke_aniso, & ! Variable(s) - l_gamma_Skw, & - l_trapezoidal_rule_zt, & - l_trapezoidal_rule_zm, & - l_call_pdf_closure_twice, & - l_host_applies_sfc_fluxes, & - l_use_cloud_cover - - use grid_class, only: & - gr, & ! Variable(s) - zm2zt, & ! Procedure(s) - zt2zm, & - ddzm - - use numerical_check, only: & - parameterization_check, & ! Procedure(s) - calculate_spurious_source - - use variables_diagnostic_module, only: & - Skw_zt, & ! Variable(s) - Skw_zm, & - sigma_sqd_w_zt, & - wp4, & - thlpthvp, & - rtpthvp, & - rtprcp, & - thlprcp, & - rcp2, & - rsat, & - pdf_params_zm, & - wprtp2, & - wp2rtp, & - wpthlp2, & - wp2thlp, & - wprtpthlp, & - wpthvp, & - wp2thvp, & - wp2rcp, & - thvm, & - em, & - Lscale, & - tau_zm, & - tau_zt, & - Kh_zm, & - Kh_zt, & - vg, & - ug, & - um_ref, & - vm_ref - - use variables_diagnostic_module, only: & - wp2_zt, & - thlp2_zt, & - wpthlp_zt, & - wprtp_zt, & - rtp2_zt, & - rtpthlp_zt, & - up2_zt, & - vp2_zt, & - upwp_zt, & - vpwp_zt, & - rtm_ref, & - thlm_ref - - use variables_diagnostic_module, only: & - wpedsclrp, & - sclrpthvp, & ! sclr'th_v' - sclrprcp, & ! sclr'rc' - wp2sclrp, & ! w'^2 sclr' - wpsclrp2, & ! w'sclr'^2 - wpsclrprtp, & ! w'sclr'rt' - wpsclrpthlp, & ! w'sclr'thl' - wp3_zm, & ! wp3 interpolated to momentum levels - Skw_velocity, & ! Skewness velocity [m/s] - a3_coef, & ! The a3 coefficient [-] - a3_coef_zt ! The a3 coefficient interp. to the zt grid [-] - - use variables_diagnostic_module, only: & - sptp_mellor_1, sptp_mellor_2, & ! Covariance of s and t[(kg/kg)^2] - tp2_mellor_1, tp2_mellor_2, & ! Variance of t [(kg/kg)^2] - corr_st_mellor1, corr_st_mellor2 ! Correlation between s and t [-] - - use variables_diagnostic_module, only: & - wp3_on_wp2, & ! Variable(s) - wp3_on_wp2_zt - - use pdf_parameter_module, only: & - pdf_parameter ! Type - -#ifdef GFDL - use advance_sclrm_Nd_module, only: & ! h1g, 2010-06-16 begin mod - advance_sclrm_Nd_diffusion_OG, & - advance_sclrm_Nd_upwind, & - advance_sclrm_Nd_semi_implicit ! h1g, 2010-06-16 end mod -#endif - - use advance_xm_wpxp_module, only: & - ! Variable(s) - advance_xm_wpxp ! Compute mean/flux terms - - use advance_xp2_xpyp_module, only: & - ! Variable(s) - advance_xp2_xpyp ! Computes variance terms - - use surface_varnce_module, only: & - surface_varnce ! Procedure - - use pdf_closure_module, only: & - ! Procedure - pdf_closure ! Prob. density function - - use mixing_length, only: & - compute_length ! Procedure - - use advance_windm_edsclrm_module, only: & - advance_windm_edsclrm ! Procedure(s) - - use saturation, only: & - ! Procedure - sat_mixrat_liq ! Saturation mixing ratio - - use advance_wp2_wp3_module, only: & - advance_wp2_wp3 ! Procedure - - use clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - - use error_code, only : & - clubb_no_error ! Constant(s) - - use error_code, only : & - clubb_at_least_debug_level, & ! Procedure(s) - reportError, & - fatal_error - - use Skw_module, only: & - Skw_func ! Procedure - - use clip_explicit, only: & - clip_covars_denom ! Procedure(s) - - use T_in_K_module, only: & - ! Read values from namelist - thlm2T_in_K ! Procedure - - use stats_subs, only: & - stats_accumulate ! Procedure - - use stats_type, only: & - stat_update_var_pt, & ! Procedure(s) - stat_update_var, & - stat_begin_update, & - stat_begin_update_pt, & - stat_end_update, & - stat_end_update_pt - - use stats_variables, only: & - irtp2_bt, & ! Variable(s) - ithlp2_bt, & - irtpthlp_bt, & - iwp2_bt, & - iwp3_bt, & - ivp2_bt, & - iup2_bt, & - iwprtp_bt, & - iwpthlp_bt, & - irtm_bt, & - ithlm_bt, & - ivm_bt, & - ium_bt, & - ircp2, & - iwp4, & - irsat, & - irvm, & - irel_humidity, & - iwpthlp_zt, & - iwprtp_zt, & - iup2_zt, & - ivp2_zt, & - iupwp_zt, & - ivpwp_zt, & - ithlp2_sf, & - irtp2_sf, & - irtpthlp_sf, & - iup2_sf, & - ivp2_sf, & - iwp2_sf, & - l_stats_samp, & - l_stats, & - zt, & - zm, & - sfc, & - irtm_spur_src, & - ithlm_spur_src - - use stats_variables, only: & - itp2_mellor_1, & ! Variables - itp2_mellor_2, & - isptp_mellor_1, & - isptp_mellor_2, & - icorr_st_mellor1, & - icorr_st_mellor2, & - iSkw_velocity, & - igamma_Skw_fnc - - use fill_holes, only: & - vertical_integral ! Procedure(s) - - use sigma_sqd_w_module, only: & - compute_sigma_sqd_w ! Procedure(s) - - implicit none - - !!! External - intrinsic :: sqrt, min, max, exp, mod, real - - ! Constant Parameters - logical, parameter :: & - l_avg_Lscale = .true. ! Lscale is calculated in subroutine compute_length; if l_avg_Lscale - ! is true, compute_length is called two additional times with - ! perturbed values of rtm and thlm. An average value of Lscale - ! from the three calls to compute_length is then calculated. - ! This reduces temporal noise in RICO, BOMEX, LBA, and other cases. - - logical, parameter :: & - l_iter_xp2_xpyp = .true. ! Set to true when rtp2/thlp2/rtpthlp, et cetera are prognostic - - !!! Input Variables - logical, intent(in) :: & - l_implemented ! Is this part of a larger host model (T/F) ? - - real(kind=time_precision), intent(in) :: & - dt ! Current timestep duration [s] - - real( kind = core_rknd ), intent(in) :: & - fcor, & ! Coriolis forcing [s^-1] - sfc_elevation ! Elevation of ground level [m AMSL] - - real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & - thlm_forcing, & ! theta_l forcing (thermodynamic levels) [K/s] - rtm_forcing, & ! r_t forcing (thermodynamic levels) [(kg/kg)/s] - um_forcing, & ! u wind forcing (thermodynamic levels) [m/s/s] - vm_forcing, & ! v wind forcing (thermodynamic levels) [m/s/s] - wm_zm, & ! w mean wind component on momentum levels [m/s] - wm_zt, & ! w mean wind component on thermo. levels [m/s] - p_in_Pa, & ! Air pressure (thermodynamic levels) [Pa] - rho_zm, & ! Air density on momentum levels [kg/m^3] - rho, & ! Air density on thermodynamic levels [kg/m^3] - exner, & ! Exner function (thermodynamic levels) [-] - rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] - rho_ds_zt, & ! Dry, static density on thermo. levels [kg/m^3] - invrs_rho_ds_zm, & ! Inv. dry, static density @ momentum levs. [m^3/kg] - invrs_rho_ds_zt, & ! Inv. dry, static density @ thermo. levs. [m^3/kg] - thv_ds_zm, & ! Dry, base-state theta_v on momentum levs. [K] - thv_ds_zt ! Dry, base-state theta_v on thermo. levs. [K] - - real( kind = core_rknd ), intent(in) :: & - wpthlp_sfc, & ! w' theta_l' at surface [(m K)/s] - wprtp_sfc, & ! w' r_t' at surface [(kg m)/( kg s)] - upwp_sfc, & ! u'w' at surface [m^2/s^2] - vpwp_sfc ! v'w' at surface [m^2/s^2] - - ! Passive scalar variables - real( kind = core_rknd ), intent(in), dimension(gr%nz,sclr_dim) :: & - sclrm_forcing ! Passive scalar forcing [{units vary}/s] - - real( kind = core_rknd ), intent(in), dimension(sclr_dim) :: & - wpsclrp_sfc ! Scalar flux at surface [{units vary} m/s] - - ! Eddy passive scalar variables - real( kind = core_rknd ), intent(in), dimension(gr%nz,edsclr_dim) :: & - edsclrm_forcing ! Eddy passive scalar forcing [{units vary}/s] - - real( kind = core_rknd ), intent(in), dimension(edsclr_dim) :: & - wpedsclrp_sfc ! Eddy-Scalar flux at surface [{units vary} m/s] - - !!! Input/Output Variables - ! These are prognostic or are planned to be in the future - real( kind = core_rknd ), intent(inout), dimension(gr%nz) :: & - um, & ! u mean wind component (thermodynamic levels) [m/s] - upwp, & ! u'w' (momentum levels) [m^2/s^2] - vm, & ! v mean wind component (thermodynamic levels) [m/s] - vpwp, & ! v'w' (momentum levels) [m^2/s^2] - up2, & ! u'^2 (momentum levels) [m^2/s^2] - vp2, & ! v'^2 (momentum levels) [m^2/s^2] - rtm, & ! total water mixing ratio, r_t (thermo. levels) [kg/kg] - wprtp, & ! w' r_t' (momentum levels) [(kg/kg) m/s] - thlm, & ! liq. water pot. temp., th_l (thermo. levels) [K] - wpthlp, & ! w' th_l' (momentum levels) [(m/s) K] - rtp2, & ! r_t'^2 (momentum levels) [(kg/kg)^2] - thlp2, & ! th_l'^2 (momentum levels) [K^2] - rtpthlp, & ! r_t' th_l' (momentum levels) [(kg/kg) K] - wp2, & ! w'^2 (momentum levels) [m^2/s^2] - wp3 ! w'^3 (thermodynamic levels) [m^3/s^3] - - ! Passive scalar variables - real( kind = core_rknd ), intent(inout), dimension(gr%nz,sclr_dim) :: & - sclrm, & ! Passive scalar mean (thermo. levels) [units vary] - wpsclrp, & ! w'sclr' (momentum levels) [{units vary} m/s] - sclrp2, & ! sclr'^2 (momentum levels) [{units vary}^2] - sclrprtp, & ! sclr'rt' (momentum levels) [{units vary} (kg/kg)] - sclrpthlp ! sclr'thl' (momentum levels) [{units vary} K] - -#ifdef GFDL - real( kind = core_rknd ), intent(inout), dimension(gr%nz,sclr_dim) :: & ! h1g, 2010-06-16 - sclrm_trsport_only ! Passive scalar concentration due to pure transport [{units vary}/s] -#endif - - ! Eddy passive scalar variable - real( kind = core_rknd ), intent(inout), dimension(gr%nz,edsclr_dim) :: & - edsclrm ! Eddy passive scalar mean (thermo. levels) [units vary] - - ! Variables that need to be output for use in other parts of the CLUBB - ! code, such as microphysics (rcm, pdf_params), forcings (rcm), and/or - ! BUGSrad (cloud_cover). - real( kind = core_rknd ), intent(out), dimension(gr%nz) :: & - rcm, & ! cloud water mixing ratio, r_c (thermo. levels) [kg/kg] - rcm_in_layer, & ! rcm in cloud layer [kg/kg] - cloud_cover ! cloud cover [-] - - type(pdf_parameter), dimension(gr%nz), intent(out) :: & - pdf_params ! PDF parameters [units vary] - - ! Variables that need to be output for use in host models - real( kind = core_rknd ), intent(out), dimension(gr%nz) :: & - wprcp, & ! w'r_c' (momentum levels) [(kg/kg) m/s] - cloud_frac ! cloud fraction (thermodynamic levels) [-] - -#ifdef CLUBB_CAM - real( kind = core_rknd), intent(out), dimension(gr%nz) :: & - khzt, & ! eddy diffusivity on thermo levels - khzm, & ! eddy diffusivity on momentum levels - qclvar ! cloud water variance -#endif - - !!! Output Variable - ! Diagnostic, for if some calculation goes amiss. - integer, intent(inout) :: err_code - -#ifdef GFDL - ! hlg, 2010-06-16 - real( kind = core_rknd ), intent(inOUT), dimension(gr%nz, min(1,sclr_dim) , 2) :: & - RH_crit ! critical relative humidity for droplet and ice nucleation -#endif - - !!! Local Variables - integer :: i, k, & - err_code_pdf_closure, err_code_surface - - real( kind = core_rknd ), dimension(gr%nz) :: & - sigma_sqd_w, & ! PDF width parameter (momentum levels) [-] - sqrt_em_zt, & ! sqrt( em ) on zt levels; where em is TKE [m/s] - gamma_Skw_fnc, & ! Gamma as a function of skewness [???] - Lscale_pert_1, Lscale_pert_2, & ! For avg. calculation of Lscale [m] - thlm_pert_1, thlm_pert_2, & ! For avg. calculation of Lscale [K] - rtm_pert_1, rtm_pert_2 ! For avg. calculation of Lscale [kg/kg] - - ! For pdf_closure - real( kind = core_rknd ), dimension(gr%nz,sclr_dim) :: & - wpsclrp_zt, & ! w' sclr' on thermo. levels - sclrp2_zt, & ! sclr'^2 on thermo. levels - sclrprtp_zt, & ! sclr' r_t' on thermo. levels - sclrpthlp_zt ! sclr' th_l' on thermo. levels - - real( kind = core_rknd ), dimension(gr%nz) :: & - p_in_Pa_zm, & ! Pressure interpolated to momentum levels [Pa] - exner_zm ! Exner interpolated to momentum levels [-] - - integer :: & - wprtp_cl_num, & ! Instance of w'r_t' clipping (1st or 3rd). - wpthlp_cl_num, & ! Instance of w'th_l' clipping (1st or 3rd). - wpsclrp_cl_num, & ! Instance of w'sclr' clipping (1st or 3rd). - upwp_cl_num, & ! Instance of u'w' clipping (1st or 2nd). - vpwp_cl_num ! Instance of v'w' clipping (1st or 2nd). - - ! These local variables are declared because they originally belong on the momentum - ! grid levels, but pdf_closure outputs them on the thermodynamic grid levels. - real( kind = core_rknd ), dimension(gr%nz) :: & - wp4_zt, & ! w'^4 (on thermo. grid) [m^4/s^4] - wpthvp_zt, & ! Buoyancy flux (on thermo. grid) [(K m)/s] - rtpthvp_zt, & ! r_t' th_v' (on thermo. grid) [(kg K)/kg] - thlpthvp_zt, & ! th_l' th_v' (on thermo. grid) [K^2] - wprcp_zt, & ! w' r_c' (on thermo. grid) [(m kg)/(s kg)] - rtprcp_zt, & ! r_t' r_c' (on thermo. grid) [(kg^2)/(kg^2)] - thlprcp_zt, & ! th_l' r_c' (on thermo. grid) [(K kg)/kg] - rcp2_zt ! r_c'^2 (on thermo. grid) [(kg^2)/(kg^2)] - - real( kind = core_rknd ), dimension(gr%nz, sclr_dim) :: & - sclrpthvp_zt, & ! sclr'th_v' (on thermo. grid) - sclrprcp_zt ! sclr'rc' (on thermo. grid) - - real( kind = core_rknd ), dimension(gr%nz) :: & - wprtp2_zm, & ! w'rt'^2 on momentum grid [m kg^2/kg^2] - wp2rtp_zm, & ! w'^2 rt' on momentum grid [m^2 kg/kg] - wpthlp2_zm, & ! w'thl'^2 on momentum grid [m K^2/s] - wp2thlp_zm, & ! w'^2 thl' on momentum grid [m^2 K/s^2] - wprtpthlp_zm, & ! w'rt'thl' on momentum grid [m kg K/kg s] - cloud_frac_zm, & ! Cloud Fraction on momentum grid [-] - rtm_zm, & ! Total water mixing ratio [kg/kg] - thlm_zm, & ! Liquid potential temperature [kg/kg] - rcm_zm, & ! Liquid water mixing ratio on momentum grid [kg/kg] - wp2thvp_zm, & ! w'^2 th_v' on momentum grid [m^2 K/s^2] - wp2rcp_zm ! w'^2 rc' on momentum grid [m^2 kg/kg s^2] - - real( kind = core_rknd ), dimension(gr%nz,sclr_dim) :: & - wpsclrprtp_zm, & ! w'sclr'rt' on momentum grid - wpsclrp2_zm, & ! w'sclr'^2 on momentum grid - wpsclrpthlp_zm, & ! w'sclr'thl' on momentum grid - wp2sclrp_zm, & ! w'^2 sclr' on momentum grid - sclrm_zm ! Passive scalar mean on momentum grid - - real( kind = core_rknd ) :: & - rtm_integral_before, & - rtm_integral_after, & - rtm_integral_forcing, & - rtm_flux_top, & - rtm_flux_sfc, & - rtm_spur_src, & - thlm_integral_before, & - thlm_integral_after, & - thlm_integral_forcing, & - thlm_flux_top, & - thlm_flux_sfc, & - thlm_spur_src, & - mu_pert_1, mu_pert_2 ! For avg. calculation of Lscale [1/m] - - !----- Begin Code ----- - - if ( l_stats .and. l_stats_samp ) then - ! Spurious source will only be calculated if rtm_ma and thlm_ma are zero. - ! Therefore, wm must be zero or l_implemented must be true. - if ( l_implemented .or. ( all( wm_zt == 0._core_rknd ) .and. & - all( wm_zm == 0._core_rknd ) ) ) then - ! Get the vertical integral of rtm and thlm before this function begins - ! so that spurious source can be calculated - rtm_integral_before & - = vertical_integral( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & - rtm(2:gr%nz), gr%invrs_dzt(2:gr%nz) ) - - thlm_integral_before & - = vertical_integral( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & - thlm(2:gr%nz), gr%invrs_dzt(2:gr%nz) ) - end if - end if - - !---------------------------------------------------------------- - ! Test input variables - !---------------------------------------------------------------- - if ( clubb_at_least_debug_level( 2 ) ) then - call parameterization_check & - ( thlm_forcing, rtm_forcing, um_forcing, vm_forcing, & ! intent(in) - wm_zm, wm_zt, p_in_Pa, rho_zm, rho, exner, & ! intent(in) - rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & ! intent(in) - invrs_rho_ds_zt, thv_ds_zm, thv_ds_zt, & ! intent(in) - wpthlp_sfc, wprtp_sfc, upwp_sfc, vpwp_sfc, & ! intent(in) - um, upwp, vm, vpwp, up2, vp2, & ! intent(in) - rtm, wprtp, thlm, wpthlp, & ! intent(in) - wp2, wp3, rtp2, thlp2, rtpthlp, & ! intent(in) - "beginning of ", & ! intent(in) - wpsclrp_sfc, wpedsclrp_sfc, & ! intent(in) - sclrm, wpsclrp, sclrp2, sclrprtp, sclrpthlp, & ! intent(in) - sclrm_forcing, edsclrm, edsclrm_forcing, & ! intent(in) - err_code ) ! Intent(inout) - end if - !----------------------------------------------------------------------- - - ! Set up stats variables. - if ( l_stats_samp ) then - - call stat_begin_update( iwp2_bt, wp2 / real( dt , kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) - call stat_begin_update( ivp2_bt, vp2 / real( dt , kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) - call stat_begin_update( iup2_bt, up2 / real( dt , kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) - call stat_begin_update( iwprtp_bt, wprtp / real( dt , kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) - call stat_begin_update( iwpthlp_bt, wpthlp / real( dt , kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) - call stat_begin_update( irtp2_bt, rtp2 / real( dt , kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) - call stat_begin_update( ithlp2_bt, thlp2 / real( dt , kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) - call stat_begin_update( irtpthlp_bt, rtpthlp / real( dt , kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) - - call stat_begin_update( irtm_bt, rtm / real( dt , kind = core_rknd ), & ! Intent(in) - zt ) ! Intent(inout) - call stat_begin_update( ithlm_bt, thlm / real( dt , kind = core_rknd ), & ! Intent(in) - zt ) ! Intent(inout) - call stat_begin_update( ium_bt, um / real( dt , kind = core_rknd ), & ! Intent(in) - zt ) ! Intent(inout) - call stat_begin_update( ivm_bt, vm / real( dt , kind = core_rknd ), & ! Intent(in) - zt ) ! Intent(inout) - call stat_begin_update( iwp3_bt, wp3 / real( dt , kind = core_rknd ), & ! Intent(in) - zt ) ! Intent(inout) - - end if - - ! SET SURFACE VALUES OF FLUXES (BROUGHT IN) - ! We only do this for host models that do not apply the flux - ! elsewhere in the code (e.g. WRF). In other cases the _sfc variables will - ! only be used to compute the variance at the surface. -dschanen 8 Sept 2009 - if ( .not. l_host_applies_sfc_fluxes ) then - - wpthlp(1) = wpthlp_sfc - wprtp(1) = wprtp_sfc - upwp(1) = upwp_sfc - vpwp(1) = vpwp_sfc - - ! Set fluxes for passive scalars (if enabled) - if ( sclr_dim > 0 ) then - wpsclrp(1,1:sclr_dim) = wpsclrp_sfc(1:sclr_dim) - end if - - if ( edsclr_dim > 0 ) then - wpedsclrp(1,1:edsclr_dim) = wpedsclrp_sfc(1:edsclr_dim) - end if - - else - - wpthlp(1) = 0.0_core_rknd - wprtp(1) = 0.0_core_rknd - upwp(1) = 0.0_core_rknd - vpwp(1) = 0.0_core_rknd - - ! Set fluxes for passive scalars (if enabled) - if ( sclr_dim > 0 ) then - wpsclrp(1,1:sclr_dim) = 0.0_core_rknd - end if - - if ( edsclr_dim > 0 ) then - wpedsclrp(1,1:edsclr_dim) = 0.0_core_rknd - end if - - end if ! ~l_host_applies_sfc_fluxes - - !--------------------------------------------------------------------------- - ! Interpolate wp3 to momentum levels, and wp2 to thermodynamic levels - ! and then compute Skw for m & t grid - !--------------------------------------------------------------------------- - - wp2_zt = max( zm2zt( wp2 ), w_tol_sqd ) ! Positive definite quantity - wp3_zm = zt2zm( wp3 ) - - Skw_zt(1:gr%nz) = Skw_func( wp2_zt(1:gr%nz), wp3(1:gr%nz) ) - Skw_zm(1:gr%nz) = Skw_func( wp2(1:gr%nz), wp3_zm(1:gr%nz) ) - - ! The right hand side of this conjunction is only for reducing cpu time, - ! since the more complicated formula is mathematically equivalent - if ( l_gamma_Skw .and. ( gamma_coef /= gamma_coefb ) ) then - !---------------------------------------------------------------- - ! Compute gamma as a function of Skw - 14 April 06 dschanen - !---------------------------------------------------------------- - - gamma_Skw_fnc = gamma_coefb + (gamma_coef-gamma_coefb) & - *exp( -(1.0_core_rknd/2.0_core_rknd) * (Skw_zm/gamma_coefc)**2 ) - - else - - gamma_Skw_fnc = gamma_coef - - end if - - ! Compute sigma_sqd_w (dimensionless PDF width parameter) - sigma_sqd_w = compute_sigma_sqd_w( gamma_Skw_fnc, wp2, thlp2, rtp2, wpthlp, wprtp ) - - if ( l_stats_samp ) then - call stat_update_var( igamma_Skw_fnc, gamma_Skw_fnc, zm ) - endif - - ! Smooth in the vertical - sigma_sqd_w = zt2zm( zm2zt( sigma_sqd_w ) ) - - ! Interpolate the the zt grid - sigma_sqd_w_zt = max( zm2zt( sigma_sqd_w ), zero_threshold ) ! Pos. def. quantity - - ! Compute the a3 coefficient (formula 25 in `Equations for CLUBB') -! a3_coef = 3.0_core_rknd * sigma_sqd_w*sigma_sqd_w & -! + 6.0_core_rknd*(1.0_core_rknd-sigma_sqd_w)*sigma_sqd_w & -! + (1.0_core_rknd-sigma_sqd_w)*(1.0_core_rknd-sigma_sqd_w) & -! - 3.0_core_rknd - - ! This is a simplified version of the formula above. - a3_coef = -2._core_rknd * ( 1._core_rknd - sigma_sqd_w )**2 - - ! We found we obtain fewer spikes in wp3 when we clip a3 to be no greater - ! than -1.4 -dschanen 4 Jan 2011 - a3_coef = max( a3_coef, -1.4_core_rknd ) ! Known magic number - - a3_coef_zt = zm2zt( a3_coef ) - - !--------------------------------------------------------------------------- - ! Interpolate thlp2, rtp2, and rtpthlp to thermodynamic levels, - !--------------------------------------------------------------------------- - - ! Iterpolate variances to the zt grid (statistics and closure) - thlp2_zt = max( zm2zt( thlp2 ), thl_tol**2 ) ! Positive def. quantity - rtp2_zt = max( zm2zt( rtp2 ), rt_tol**2 ) ! Positive def. quantity - rtpthlp_zt = zm2zt( rtpthlp ) - - ! Compute skewness velocity for stats output purposes - if ( iSkw_velocity > 0 ) then - Skw_velocity = ( 1.0_core_rknd / ( 1.0_core_rknd - sigma_sqd_w(1:gr%nz) ) ) & - * ( wp3_zm(1:gr%nz) / max( wp2(1:gr%nz), w_tol_sqd ) ) - end if - - ! Compute wp3 / wp2 on zt levels. Always use the interpolated value in the - ! denominator since it's less likely to create spikes - wp3_on_wp2_zt = ( wp3(1:gr%nz) / max( wp2_zt(1:gr%nz), w_tol_sqd ) ) - - ! Clip wp3_on_wp2_zt if it's too large - do k=1, gr%nz - if( wp3_on_wp2_zt(k) < 0._core_rknd ) then - wp3_on_wp2_zt = max( -1000._core_rknd, wp3_on_wp2_zt ) - else - wp3_on_wp2_zt = min( 1000._core_rknd, wp3_on_wp2_zt ) - end if - end do - - ! Compute wp3_on_wp2 by interpolating wp3_on_wp2_zt - wp3_on_wp2 = zt2zm( wp3_on_wp2_zt ) - - ! Smooth again as above - wp3_on_wp2_zt = zm2zt( wp3_on_wp2 ) - - !---------------------------------------------------------------- - ! Call closure scheme - !---------------------------------------------------------------- - - ! Put passive scalar input on the t grid for the PDF - do i = 1, sclr_dim, 1 - wpsclrp_zt(:,i) = zm2zt( wpsclrp(:,i) ) - sclrp2_zt(:,i) = max( zm2zt( sclrp2(:,i) ), zero_threshold ) ! Pos. def. quantity - sclrprtp_zt(:,i) = zm2zt( sclrprtp(:,i) ) - sclrpthlp_zt(:,i) = zm2zt( sclrpthlp(:,i) ) - end do ! i = 1, sclr_dim, 1 - - - do k = 1, gr%nz, 1 - - call pdf_closure & - ( p_in_Pa(k), exner(k), thv_ds_zt(k), wm_zt(k), & ! intent(in) - wp2_zt(k), wp3(k), sigma_sqd_w_zt(k), & ! intent(in) - Skw_zt(k), rtm(k), rtp2_zt(k), & ! intent(in) - zm2zt( wprtp, k ), thlm(k), thlp2_zt(k), & ! intent(in) - zm2zt( wpthlp, k ), rtpthlp_zt(k), sclrm(k,:), & ! intent(in) - wpsclrp_zt(k,:), sclrp2_zt(k,:), sclrprtp_zt(k,:), & ! intent(in) - sclrpthlp_zt(k,:), k, & ! intent(in) -#ifdef GFDL - RH_crit(k, : , :), & ! intent(in) h1g, 2010-06-16 -#endif - wp4_zt(k), wprtp2(k), wp2rtp(k), & ! intent(out) - wpthlp2(k), wp2thlp(k), wprtpthlp(k), & ! intent(out) - cloud_frac(k), rcm(k), wpthvp_zt(k), & ! intent(out) - wp2thvp(k), rtpthvp_zt(k), thlpthvp_zt(k), & ! intent(out) - wprcp_zt(k), wp2rcp(k), rtprcp_zt(k), & ! intent(out) - thlprcp_zt(k), rcp2_zt(k), pdf_params(k), & ! intent(out) - err_code_pdf_closure, & ! intent(out) - wpsclrprtp(k,:), wpsclrp2(k,:), sclrpthvp_zt(k,:), & ! intent(out) - wpsclrpthlp(k,:), sclrprcp_zt(k,:), wp2sclrp(k,:), & ! intent(out) - sptp_mellor_1(k), sptp_mellor_2(k), & ! intent(out) - tp2_mellor_1(k), tp2_mellor_2(k), & ! intent(out) - corr_st_mellor1(k), corr_st_mellor2(k) ) ! intent(out) - - ! Subroutine may produce NaN values, and if so, exit - ! gracefully. - ! Joshua Fasching March 2008 - - if ( fatal_error( err_code_pdf_closure ) ) then - - if ( clubb_at_least_debug_level( 1 ) ) then - write(fstderr,*) "At grid level = ",k - end if - - err_code = err_code_pdf_closure - end if - - end do ! k = 1, gr%nz, 1 - - - if ( l_call_pdf_closure_twice ) then - ! Call pdf_closure a second time on momentum levels, to - ! output (rather than interpolate) the variables which - ! belong on the momentum levels. - - ! Interpolate sclrm to the momentum level for use in - ! the second call to pdf_closure - do i = 1, sclr_dim - sclrm_zm(:,i) = zt2zm( sclrm(:,i) ) - ! Clip if extrap. causes sclrm_zm to be less than sclr_tol - sclrm_zm(gr%nz,i) = max( sclrm_zm(gr%nz,i), sclr_tol(i) ) - end do ! i = 1, sclr_dim - - ! Interpolate pressure, p_in_Pa, to momentum levels. - ! The pressure at thermodynamic level k = 1 has been set to be the surface - ! (or model lower boundary) pressure. Since the surface (or model lower - ! boundary) is located at momentum level k = 1, the pressure there is - ! p_sfc, which is p_in_Pa(1). Thus, p_in_Pa_zm(1) = p_in_Pa(1). - p_in_Pa_zm(:) = zt2zm( p_in_Pa ) - p_in_Pa_zm(1) = p_in_Pa(1) - - ! Clip pressure if the extrapolation leads to a negative value of pressure - p_in_Pa_zm(gr%nz) = max( p_in_Pa_zm(gr%nz), 0.5_core_rknd*p_in_Pa(gr%nz) ) - ! Set exner at momentum levels, exner_zm, based on p_in_Pa_zm. - exner_zm(:) = (p_in_Pa_zm(:)/p0)**kappa - - rtm_zm = zt2zm( rtm ) - ! Clip if extrapolation at the top level causes rtm_zm to be < rt_tol - rtm_zm(gr%nz) = max( rtm_zm(gr%nz), rt_tol ) - thlm_zm = zt2zm( thlm ) - ! Clip if extrapolation at the top level causes thlm_zm to be < thl_tol - thlm_zm(gr%nz) = max( thlm_zm(gr%nz), thl_tol ) - - ! Call pdf_closure to output the variables which belong on the momentum grid. - do k = 1, gr%nz, 1 - - call pdf_closure & - ( p_in_Pa_zm(k), exner_zm(k), thv_ds_zm(k), wm_zm(k), & ! intent(in) - wp2(k), wp3_zm(k), sigma_sqd_w(k), & ! intent(in) - Skw_zm(k), rtm_zm(k), rtp2(k), & ! intent(in) - wprtp(k), thlm_zm(k), thlp2(k), & ! intent(in) - wpthlp(k), rtpthlp(k), sclrm_zm(k,:), & ! intent(in) - wpsclrp(k,:), sclrp2(k,:), sclrprtp(k,:), & ! intent(in) - sclrpthlp(k,:), k, & ! intent(in) -#ifdef GFDL - RH_crit(k, : , :), & ! intent(in) h1g, 2010-06-16 -#endif - wp4(k), wprtp2_zm(k), wp2rtp_zm(k), & ! intent(out) - wpthlp2_zm(k), wp2thlp_zm(k), wprtpthlp_zm(k), & ! intent(out) - cloud_frac_zm(k), rcm_zm(k), wpthvp(k), & ! intent(out) - wp2thvp_zm(k), rtpthvp(k), thlpthvp(k), & ! intent(out) - wprcp(k), wp2rcp_zm(k), rtprcp(k), & ! intent(out) - thlprcp(k), rcp2(k), pdf_params_zm(k), & ! intent(out) - err_code_pdf_closure, & ! intent(out) - wpsclrprtp_zm(k,:), wpsclrp2_zm(k,:), sclrpthvp(k,:), & ! intent(out) - wpsclrpthlp_zm(k,:), sclrprcp(k,:), wp2sclrp_zm(k,:), & ! intent(out) - sptp_mellor_1(k), sptp_mellor_2(k), & ! intent(out) - tp2_mellor_1(k), tp2_mellor_2(k), & ! intent(out) - corr_st_mellor1(k), corr_st_mellor2(k) ) ! intent(out) - - ! Subroutine may produce NaN values, and if so, exit - ! gracefully. - ! Joshua Fasching March 2008 - - - if ( fatal_error( err_code_pdf_closure ) ) then - - if ( clubb_at_least_debug_level( 1 ) ) then - write(fstderr,*) "At grid level = ",k - end if - - err_code = err_code_pdf_closure - end if - - end do ! k = 1, gr%nz, 1 - - else ! l_call_pdf_closure_twice is false - - ! Interpolate momentum variables output from the first call to - ! pdf_closure back to momentum grid. - ! Since top momentum level is higher than top thermo level, - ! Set variables at top momentum level to 0. - - ! Only do this for wp4 and rcp2 if we're saving stats, since they are not - ! used elsewhere in the parameterization - if ( iwp4 > 0 ) then - wp4 = max( zt2zm( wp4_zt ), zero_threshold ) ! Pos. def. quantity - wp4(gr%nz) = 0.0_core_rknd - end if - -#ifndef CLUBB_CAM ! CAM-CLUBB needs cloud water variance thus always compute this - if ( ircp2 > 0 ) then -#endif - rcp2 = max( zt2zm( rcp2_zt ), zero_threshold ) ! Pos. def. quantity -#ifndef CLUBB_CAM - rcp2(gr%nz) = 0.0_core_rknd - end if -#endif - - if ( icorr_st_mellor1 > 0 ) then - corr_st_mellor1 = zt2zm( corr_st_mellor1 ) - end if - - if ( icorr_st_mellor2 > 0 ) then - corr_st_mellor2 = zt2zm( corr_st_mellor2 ) - end if - - if ( isptp_mellor_1 > 0 ) then - sptp_mellor_1 = zt2zm( sptp_mellor_1 ) - end if - - if ( isptp_mellor_2 > 0 ) then - sptp_mellor_2 = zt2zm( sptp_mellor_2 ) - end if - - if ( itp2_mellor_1 > 0 ) then - tp2_mellor_1 = max( zt2zm( tp2_mellor_1 ), zero_threshold ) - tp2_mellor_1(gr%nz) = 0.0_core_rknd - end if - - if ( itp2_mellor_2 > 0 ) then - tp2_mellor_2 = max( zt2zm( tp2_mellor_2 ), zero_threshold ) - tp2_mellor_2(gr%nz) = 0.0_core_rknd - end if - - wpthvp = zt2zm( wpthvp_zt ) - wpthvp(gr%nz) = 0.0_core_rknd - thlpthvp = zt2zm( thlpthvp_zt ) - thlpthvp(gr%nz) = 0.0_core_rknd - rtpthvp = zt2zm( rtpthvp_zt ) - rtpthvp(gr%nz) = 0.0_core_rknd - wprcp = zt2zm( wprcp_zt ) - wprcp(gr%nz) = 0.0_core_rknd - rtprcp = zt2zm( rtprcp_zt ) - rtprcp(gr%nz) = 0.0_core_rknd - thlprcp = zt2zm( thlprcp_zt ) - thlprcp(gr%nz) = 0.0_core_rknd - - ! Interpolate passive scalars back onto the m grid - do i = 1, sclr_dim - sclrpthvp(:,i) = zt2zm( sclrpthvp_zt(:,i) ) - sclrpthvp(gr%nz,i) = 0.0_core_rknd - sclrprcp(:,i) = zt2zm( sclrprcp_zt(:,i) ) - sclrprcp(gr%nz,i) = 0.0_core_rknd - end do ! i=1, sclr_dim - - end if ! l_call_pdf_closure_twice - - ! If l_trapezoidal_rule_zt is true, call trapezoidal_rule_zt for - ! thermodynamic-level variables output from pdf_closure. - ! ldgrant June 2009 - if ( l_trapezoidal_rule_zt ) then - call trapezoidal_rule_zt & - ( l_call_pdf_closure_twice, & ! intent(in) - wprtp2, wpthlp2, & ! intent(inout) - wprtpthlp, cloud_frac, rcm, wp2thvp, & ! intent(inout) - wpsclrprtp, wpsclrp2, wpsclrpthlp, & ! intent(inout) - pdf_params, & ! intent(inout) - wprtp2_zm, wpthlp2_zm, & ! intent(inout) - wprtpthlp_zm, cloud_frac_zm, & ! intent(inout) - rcm_zm, wp2thvp_zm, & ! intent(inout) - wpsclrprtp_zm, wpsclrp2_zm, wpsclrpthlp_zm, & ! intent(inout) - pdf_params_zm ) ! intent(inout) - end if ! l_trapezoidal_rule_zt - - ! If l_trapezoidal_rule_zm is true, call trapezoidal_rule_zm for - ! the important momentum-level variabes output from pdf_closure. - ! ldgrant Feb. 2010 - if ( l_trapezoidal_rule_zm ) then - call trapezoidal_rule_zm & - ( wpthvp_zt, thlpthvp_zt, rtpthvp_zt, & ! intent(in) - wpthvp, thlpthvp, rtpthvp ) ! intent(inout) - end if ! l_trapezoidal_rule_zm - - ! Vince Larson clipped rcm in order to prevent rvm < 0. 5 Apr 2008. - ! This code won't work unless rtm >= 0 !!! - ! We do not clip rcm_in_layer because rcm_in_layer only influences - ! radiation, and we do not want to bother recomputing it. - ! Code is duplicated from below to ensure that relative humidity - ! is calculated properly. 3 Sep 2009 - call clip_rcm( rtm, 'rtm < rcm after pdf_closure', & ! intent (in) - rcm ) ! intent (inout) - - ! Compute variables cloud_cover and rcm_in_layer. - ! Added July 2009 - call compute_cloud_cover & - ( pdf_params, cloud_frac, rcm, & ! intent(in) - cloud_cover, rcm_in_layer ) ! intent(out) - - ! Use cloud_cover and rcm_in_layer to help boost cloud_frac and rcm to help - ! increase cloudiness at coarser grid resolutions. - if ( l_use_cloud_cover ) then - cloud_frac = cloud_cover - rcm = rcm_in_layer - end if - - ! Clip cloud fraction here if it still exceeds 1.0 due to round off - cloud_frac = min( 1.0_core_rknd, cloud_frac ) - - !---------------------------------------------------------------- - ! Compute thvm - !---------------------------------------------------------------- - - thvm = thlm + ep1 * thv_ds_zt * rtm & - + ( Lv/(Cp*exner) - ep2 * thv_ds_zt ) * rcm - - !---------------------------------------------------------------- - ! Compute tke (turbulent kinetic energy) - !---------------------------------------------------------------- - - if ( .not. l_tke_aniso ) then - ! tke is assumed to be 3/2 of wp2 - em = three_halves * wp2 ! Known magic number - else - em = 0.5_core_rknd * ( wp2 + vp2 + up2 ) - end if - - !---------------------------------------------------------------- - ! Compute mixing length - !---------------------------------------------------------------- - - if ( l_avg_Lscale ) then - ! Call compute length two additional times with perturbed values - ! of rtm and thlm so that an average value of Lscale may be calculated. - - thlm_pert_1 = thlm + Lscale_pert_coef * sqrt( max( thlp2, thl_tol**2 ) ) - rtm_pert_1 = rtm + Lscale_pert_coef * sqrt( max( rtp2, rt_tol**2 ) ) - mu_pert_1 = mu * Lscale_mu_coef - - thlm_pert_2 = thlm - Lscale_pert_coef * sqrt( max( thlp2, thl_tol**2 ) ) - rtm_pert_2 = rtm - Lscale_pert_coef * sqrt( max( rtp2, rt_tol**2 ) ) - mu_pert_2 = mu / Lscale_mu_coef - - call compute_length( thvm, thlm_pert_1, rtm_pert_1, em, & ! intent(in) - p_in_Pa, exner, thv_ds_zt, mu_pert_1, l_implemented, & ! intent(in) - err_code, & ! intent(inout) - Lscale_pert_1 ) ! intent(out) - - call compute_length( thvm, thlm_pert_2, rtm_pert_2, em, & ! intent(in) - p_in_Pa, exner, thv_ds_zt, mu_pert_2, l_implemented, & ! intent(in) - err_code, & ! intent(inout) - Lscale_pert_2 ) ! intent(out) - - end if ! l_avg_Lscale - - ! ********** NOTE: ********** - ! This call to compute_length must be last. Otherwise, the values of - ! Lscale_up and Lscale_down will not be correctly saved stats. - call compute_length( thvm, thlm, rtm, em, & ! intent(in) - p_in_Pa, exner, thv_ds_zt, mu, l_implemented, & ! intent(in) - err_code, & ! intent(inout) - Lscale ) ! intent(out) - - if ( l_avg_Lscale ) then - Lscale = (1.0_core_rknd/3.0_core_rknd) * ( Lscale + Lscale_pert_1 + Lscale_pert_2 ) - end if - - !---------------------------------------------------------------- - ! Dissipation time - !---------------------------------------------------------------- -! Vince Larson replaced the cutoff of em_min by w_tol**2. 7 Jul 2007 -! This is to prevent tau from being too large (producing little damping) -! in stably stratified layers with little turbulence. -! sqrt_em_zt = SQRT( MAX( em_min, zm2zt( em ) ) ) -! tau_zt = MIN( Lscale / sqrt_em_zt, taumax ) -! tau_zm & -! = MIN( ( zt2zm( Lscale ) / SQRT( MAX( em_min, em ) ) ), taumax ) -! Addition by Brian: Model constant em_min is now set to (3/2)*w_tol_sqd. -! Thus, em_min can replace w_tol_sqd here. - sqrt_em_zt = SQRT( MAX( em_min, zm2zt( em ) ) ) - - tau_zt = MIN( Lscale / sqrt_em_zt, taumax ) - tau_zm = MIN( ( MAX( zt2zm( Lscale ), zero_threshold ) & - / SQRT( MAX( em_min, em ) ) ), taumax ) -! End Vince Larson's replacement. - - ! Modification to damp noise in stable region -! Vince Larson commented out because it may prevent turbulence from -! initiating in unstable regions. 7 Jul 2007 -! do k = 1, gr%nz -! if ( wp2(k) <= 0.005_core_rknd ) then -! tau_zt(k) = taumin -! tau_zm(k) = taumin -! end if -! end do -! End Vince Larson's commenting. - - !---------------------------------------------------------------- - ! Eddy diffusivity coefficient - !---------------------------------------------------------------- - ! c_K is 0.548 usually (Duynkerke and Driedonks 1987) - ! CLUBB uses a smaller value to better fit empirical data. - - Kh_zt = c_K * Lscale * sqrt_em_zt - Kh_zm = c_K * max( zt2zm( Lscale ), zero_threshold ) & - * sqrt( max( em, em_min ) ) - -#ifdef CLUBB_CAM - khzt(:) = Kh_zt(:) - khzm(:) = Kh_zm(:) - qclvar(:) = rcp2_zt(:) -#endif - - !---------------------------------------------------------------- - ! Set Surface variances - !---------------------------------------------------------------- - - ! Surface variances should be set here, before the call to either - ! advance_xp2_xpyp or advance_wp2_wp3. - ! Surface effects should not be included with any case where the lowest - ! level is not the ground level. Brian Griffin. December 22, 2005. - if ( gr%zm(1) == sfc_elevation ) then - - ! Reflect surface varnce changes in budget - if ( l_stats_samp ) then - call stat_begin_update_pt( ithlp2_sf, 1, & ! intent(in) - thlp2(1) / real( dt , kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) - call stat_begin_update_pt( irtp2_sf, 1, & ! intent(in) - rtp2(1) / real( dt , kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) - call stat_begin_update_pt( irtpthlp_sf, 1, & ! intent(in) - rtpthlp(1) / real( dt , kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) - call stat_begin_update_pt( iup2_sf, 1, & ! intent(in) - up2(1) / real( dt , kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) - call stat_begin_update_pt( ivp2_sf, 1, & ! intent(in) - vp2(1) / real( dt , kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) - call stat_begin_update_pt( iwp2_sf, 1, & ! intent(in) - wp2(1) / real( dt , kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) - end if - - call surface_varnce( upwp_sfc, vpwp_sfc, wpthlp_sfc, wprtp_sfc, & ! intent(in) - um(2), vm(2), wpsclrp_sfc, & ! intent(in) - wp2(1), up2(1), vp2(1), & ! intent(out) - thlp2(1), rtp2(1), rtpthlp(1), err_code_surface,& ! intent(out) - sclrp2(1,1:sclr_dim), & ! intent(out) - sclrprtp(1,1:sclr_dim), & ! intent(out) - sclrpthlp(1,1:sclr_dim) ) ! intent(out) - - if ( fatal_error( err_code_surface ) ) then - call reportError( err_code_surface ) - err_code = err_code_surface - end if - - ! Update surface stats - if ( l_stats_samp ) then - call stat_end_update_pt( ithlp2_sf, 1, & ! intent(in) - thlp2(1) / real( dt , kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) - call stat_end_update_pt( irtp2_sf, 1, & ! intent(in) - rtp2(1) / real( dt , kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) - call stat_end_update_pt( irtpthlp_sf, 1, & ! intent(in) - rtpthlp(1) / real( dt , kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) - call stat_end_update_pt( iup2_sf, 1, & ! intent(in) - up2(1) / real( dt , kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) - call stat_end_update_pt( ivp2_sf, 1, & ! intent(in) - vp2(1) / real( dt , kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) - call stat_end_update_pt( iwp2_sf, 1, & ! intent(in) - wp2(1) / real( dt , kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) - end if - - else - - ! Variances for cases where the lowest level is not at the surface. - ! Eliminate surface effects on lowest level variances. - wp2(1) = w_tol_sqd - up2(1) = w_tol_sqd - vp2(1) = w_tol_sqd - thlp2(1) = thl_tol**2 - rtp2(1) = rt_tol**2 - rtpthlp(1) = 0.0_core_rknd - - do i = 1, sclr_dim, 1 - sclrp2(1,i) = 0.0_core_rknd - sclrprtp(1,i) = 0.0_core_rknd - sclrpthlp(1,i) = 0.0_core_rknd - end do - - end if ! gr%zm(1) == sfc_elevation - - - !####################################################################### - !############## ADVANCE PROGNOSTIC VARIABLES ONE TIMESTEP ############## - !####################################################################### - - ! Store the saturation mixing ratio for output purposes. Brian - ! Compute rsat if either rsat or rel_humidity is to be saved. ldgrant - if ( ( irsat > 0 ) .or. ( irel_humidity > 0 ) ) then - rsat = sat_mixrat_liq( p_in_Pa, thlm2T_in_K( thlm, exner, rcm ) ) - end if - - - if ( l_stats_samp ) then - call stat_update_var( irvm, rtm - rcm, zt ) - - ! Output relative humidity (q/q∗ where q∗ is the saturation mixing ratio over liquid) - ! Added an extra check for irel_humidity > 0; otherwise, if both irsat = 0 and - ! irel_humidity = 0, rsat is not computed, leading to a floating-point exception - ! when stat_update_var is called for rel_humidity. ldgrant - if ( irel_humidity > 0 ) then - call stat_update_var( irel_humidity, (rtm - rcm) / rsat, zt) - end if ! irel_humidity > 0 - end if ! l_stats_samp - - !---------------------------------------------------------------- - ! Advance rtm/wprtp and thlm/wpthlp one time step - !---------------------------------------------------------------- - - call advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & ! intent(in) - Lscale, wp3_on_wp2, wp3_on_wp2_zt, & ! intent(in) - Kh_zt, tau_zm, Skw_zm, rtpthvp, rtm_forcing, & ! intent(in) - thlpthvp, rtm_ref, thlm_ref, thlm_forcing, & ! intent(in) - rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & ! intent(in) - invrs_rho_ds_zt, thv_ds_zm, rtp2, thlp2, & ! intent(in) - pdf_params, l_implemented, & ! intent(in) - sclrpthvp, sclrm_forcing, sclrp2, & ! intent(in) - rtm, wprtp, thlm, wpthlp, & ! intent(inout) - err_code, & ! intent(inout) - sclrm, wpsclrp ) ! intent(inout) - - ! Vince Larson clipped rcm in order to prevent rvm < 0. 5 Apr 2008. - ! This code won't work unless rtm >= 0 !!! - ! We do not clip rcm_in_layer because rcm_in_layer only influences - ! radiation, and we do not want to bother recomputing it. 6 Aug 2009 - call clip_rcm( rtm, 'rtm < rcm in advance_xm_wpxp', & ! intent(in) - rcm ) ! intent(inout) - -#ifdef GFDL - call advance_sclrm_Nd_diffusion_OG( dt, sclrm, & ! h1g, 2010-06-16 - sclrm_trsport_only, Kh_zm, cloud_frac, err_code ) -#endif - - !---------------------------------------------------------------- - ! Compute some of the variances and covariances. These include the variance of - ! total water (rtp2), liquid potential termperature (thlp2), their - ! covariance (rtpthlp), and the variance of horizontal wind (up2 and vp2). - ! The variance of vertical velocity is computed later. - !---------------------------------------------------------------- - - ! We found that certain cases require a time tendency to run - ! at shorter timesteps so these are prognosed now. - - ! We found that if we call advance_xp2_xpyp first, we can use a longer timestep. - call advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, & ! intent(in) - thlm, wpthlp, wpthvp, um, vm, & ! intent(in) - wp2, wp2_zt, wp3, upwp, vpwp, & ! intent(in) - sigma_sqd_w, Skw_zm, Kh_zt, & ! intent(in) - rho_ds_zm, rho_ds_zt, & ! intent(in) - invrs_rho_ds_zm, thv_ds_zm, & ! intent(in) - Lscale, wp3_on_wp2, wp3_on_wp2_zt, & ! intent(in) - ! Vince Larson used prognostic timestepping of variances - ! in order to increase numerical stability. 17 Jul 2007 - ! .false., dt, & ! intent(in) - l_iter_xp2_xpyp, dt, & ! intent(in) - sclrm, wpsclrp, & ! intent(in) - rtp2, thlp2, rtpthlp, & ! intent(inout) - up2, vp2, & ! intent(inout) - err_code, & ! intent(inout) - sclrp2, sclrprtp, sclrpthlp ) ! intent(inout) - - !---------------------------------------------------------------- - ! Covariance clipping for wprtp, wpthlp, wpsclrp, upwp, and vpwp - ! after subroutine advance_xp2_xpyp updated xp2. - !---------------------------------------------------------------- - - wprtp_cl_num = 2 ! Second instance of w'r_t' clipping. - wpthlp_cl_num = 2 ! Second instance of w'th_l' clipping. - wpsclrp_cl_num = 2 ! Second instance of w'sclr' clipping. - upwp_cl_num = 1 ! First instance of u'w' clipping. - vpwp_cl_num = 1 ! First instance of v'w' clipping. - - call clip_covars_denom( dt, rtp2, thlp2, up2, vp2, wp2, & ! intent(in) - sclrp2, wprtp_cl_num, wpthlp_cl_num, & ! intent(in) - wpsclrp_cl_num, upwp_cl_num, vpwp_cl_num, & ! intent(in) - wprtp, wpthlp, upwp, vpwp, wpsclrp ) ! intent(inout) - - - !---------------------------------------------------------------- - ! Advance 2nd and 3rd order moment of vertical velocity (wp2 / wp3) - ! by one timestep - !---------------------------------------------------------------- - - call advance_wp2_wp3 & - ( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & ! intent(in) - a3_coef, a3_coef_zt, wp3_on_wp2, & ! intent(in) - wpthvp, wp2thvp, um, vm, upwp, vpwp, & ! intent(in) - up2, vp2, Kh_zm, Kh_zt, tau_zm, tau_zt, & ! intent(in) - Skw_zm, Skw_zt, rho_ds_zm, rho_ds_zt, & ! intent(in) - invrs_rho_ds_zm, invrs_rho_ds_zt, & ! intent(in) - thv_ds_zm, thv_ds_zt, pdf_params%mixt_frac, & ! intent(in) - wp2, wp3, wp3_zm, wp2_zt, err_code ) ! intent(inout) - - !---------------------------------------------------------------- - ! Covariance clipping for wprtp, wpthlp, wpsclrp, upwp, and vpwp - ! after subroutine advance_wp2_wp3 updated wp2. - !---------------------------------------------------------------- - - wprtp_cl_num = 3 ! Third instance of w'r_t' clipping. - wpthlp_cl_num = 3 ! Third instance of w'th_l' clipping. - wpsclrp_cl_num = 3 ! Third instance of w'sclr' clipping. - upwp_cl_num = 2 ! Second instance of u'w' clipping. - vpwp_cl_num = 2 ! Second instance of v'w' clipping. - - call clip_covars_denom( dt, rtp2, thlp2, up2, vp2, wp2, & ! intent(in) - sclrp2, wprtp_cl_num, wpthlp_cl_num, & ! intent(in) - wpsclrp_cl_num, upwp_cl_num, vpwp_cl_num, & ! intent(in) - wprtp, wpthlp, upwp, vpwp, wpsclrp ) ! intent(inout) - - !---------------------------------------------------------------- - ! Advance the horizontal mean of the wind in the x-y directions - ! (i.e. um, vm) and the mean of the eddy-diffusivity scalars - ! (i.e. edsclrm) by one time step - !---------------------------------------------------------------- - - call advance_windm_edsclrm( dt, wm_zt, Kh_zm, ug, vg, um_ref, vm_ref, & ! Intent(in) - wp2, up2, vp2, um_forcing, vm_forcing, & ! Intent(in) - edsclrm_forcing, & ! Intent(in) - rho_ds_zm, invrs_rho_ds_zt, & ! Intent(in) - fcor, l_implemented, & ! Intent(in) - um, vm, edsclrm, & ! Intent(inout) - upwp, vpwp, wpedsclrp, & ! Intent(inout) - err_code ) ! Intent(inout) - - !####################################################################### - !############# ACCUMULATE STATISTICS ############# - !####################################################################### - - if ( l_stats_samp ) then - - call stat_end_update( iwp2_bt, wp2 / real( dt , kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) - call stat_end_update( ivp2_bt, vp2 / real( dt , kind = core_rknd ),& ! Intent(in) - zm ) ! Intent(inout) - call stat_end_update( iup2_bt, up2 / real( dt , kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) - call stat_end_update( iwprtp_bt, wprtp / real( dt , kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) - call stat_end_update( iwpthlp_bt, wpthlp / real( dt , kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) - call stat_end_update( irtp2_bt, rtp2 / real( dt , kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) - call stat_end_update( ithlp2_bt, thlp2 / real( dt , kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) - call stat_end_update( irtpthlp_bt, rtpthlp / real( dt , kind = core_rknd ), &! Intent(in) - zm ) ! Intent(inout) - - call stat_end_update( irtm_bt, rtm / real( dt , kind = core_rknd ), & ! Intent(in) - zt ) ! Intent(inout) - call stat_end_update( ithlm_bt, thlm / real( dt , kind = core_rknd ), & ! Intent(in) - zt ) ! Intent(inout) - call stat_end_update( ium_bt, um / real( dt , kind = core_rknd ), & ! Intent(in) - zt ) ! Intent(inout) - call stat_end_update( ivm_bt, vm / real( dt , kind = core_rknd ), & ! Intent(in) - zt ) ! Intent(inout) - call stat_end_update( iwp3_bt, wp3 / real( dt , kind = core_rknd ), & ! Intent(in) - zt ) ! Intent(inout) - - end if ! l_stats_samp - - - if ( iwpthlp_zt > 0 ) then - wpthlp_zt = zm2zt( wpthlp ) - end if - - if ( iwprtp_zt > 0 ) then - wprtp_zt = zm2zt( wprtp ) - end if - - if ( iup2_zt > 0 ) then - up2_zt = max( zm2zt( up2 ), w_tol_sqd ) - end if - - if (ivp2_zt > 0 ) then - vp2_zt = max( zm2zt( vp2 ), w_tol_sqd ) - end if - - if ( iupwp_zt > 0 ) then - upwp_zt = zm2zt( upwp ) - end if - - if ( ivpwp_zt > 0 ) then - vpwp_zt = zm2zt( vpwp ) - end if - - call stats_accumulate & - ( um, vm, upwp, vpwp, up2, vp2, & ! intent(in) - thlm, rtm, wprtp, wpthlp, & ! intent(in) - wp2, wp3, rtp2, thlp2, rtpthlp, & ! intent(in) - p_in_Pa, exner, rho, rho_zm, & ! intent(in) - rho_ds_zm, rho_ds_zt, thv_ds_zm, & ! intent(in) - thv_ds_zt, wm_zt, wm_zm, rcm, wprcp, & ! intent(in) - rcm_zm, rtm_zm, thlm_zm, cloud_frac, & ! intent(in) - cloud_frac_zm, rcm_in_layer, cloud_cover, & ! intent(in) - sigma_sqd_w, pdf_params, & ! intent(in) - sclrm, sclrp2, sclrprtp, sclrpthlp, sclrm_forcing, & ! intent(in) - wpsclrp, edsclrm, edsclrm_forcing ) ! intent(in) - - - if ( clubb_at_least_debug_level( 2 ) ) then - call parameterization_check & - ( thlm_forcing, rtm_forcing, um_forcing, vm_forcing, & ! intent(in) - wm_zm, wm_zt, p_in_Pa, rho_zm, rho, exner, & ! intent(in) - rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & ! intent(in) - invrs_rho_ds_zt, thv_ds_zm, thv_ds_zt, & ! intent(in) - wpthlp_sfc, wprtp_sfc, upwp_sfc, vpwp_sfc, & ! intent(in) - um, upwp, vm, vpwp, up2, vp2, & ! intent(in) - rtm, wprtp, thlm, wpthlp, & ! intent(in) - wp2, wp3, rtp2, thlp2, rtpthlp, & ! intent(in) - "end of ", & ! intent(in) - wpsclrp_sfc, wpedsclrp_sfc, & ! intent(in) - sclrm, wpsclrp, sclrp2, sclrprtp, sclrpthlp, & ! intent(in) - sclrm_forcing, edsclrm, edsclrm_forcing, & ! intent(in) - err_code ) ! intent(inout) - end if - - if ( l_stats .and. l_stats_samp ) then - ! Spurious source will only be calculated if rtm_ma and thlm_ma are zero. - ! Therefore, wm must be zero or l_implemented must be true. - if ( l_implemented .or. ( all( wm_zt == 0._core_rknd ) .and. & - all( wm_zm == 0._core_rknd ) ) ) then - ! Calculate the spurious source for rtm - rtm_flux_top = rho_ds_zm(gr%nz) * wprtp(gr%nz) - - if ( .not. l_host_applies_sfc_fluxes ) then - rtm_flux_sfc = rho_ds_zm(1) * wprtp_sfc - else - rtm_flux_sfc = 0.0_core_rknd - end if - - rtm_integral_after & - = vertical_integral( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & - rtm(2:gr%nz), gr%invrs_dzt(2:gr%nz) ) - - rtm_integral_forcing & - = vertical_integral( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & - rtm_forcing(2:gr%nz), gr%invrs_dzt(2:gr%nz) ) - - rtm_spur_src & - = calculate_spurious_source( rtm_integral_after, & - rtm_integral_before, & - rtm_flux_top, rtm_flux_sfc, & - rtm_integral_forcing, & - real( dt , kind = core_rknd ) ) - - ! Calculate the spurious source for thlm - thlm_flux_top = rho_ds_zm(gr%nz) * wpthlp(gr%nz) - - if ( .not. l_host_applies_sfc_fluxes ) then - thlm_flux_sfc = rho_ds_zm(1) * wpthlp_sfc - else - thlm_flux_sfc = 0.0_core_rknd - end if - - thlm_integral_after & - = vertical_integral( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & - thlm(2:gr%nz), gr%invrs_dzt(2:gr%nz) ) - - thlm_integral_forcing & - = vertical_integral( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & - thlm_forcing(2:gr%nz), gr%invrs_dzt(2:gr%nz) ) - - thlm_spur_src & - = calculate_spurious_source( thlm_integral_after, & - thlm_integral_before, & - thlm_flux_top, thlm_flux_sfc, & - thlm_integral_forcing, & - real( dt , kind = core_rknd ) ) - else ! If l_implemented is false, we don't want spurious source output - rtm_spur_src = -9999.0_core_rknd - thlm_spur_src = -9999.0_core_rknd - end if - - ! Write the var to stats - call stat_update_var_pt( irtm_spur_src, 1, & - rtm_spur_src, sfc ) - call stat_update_var_pt( ithlm_spur_src, 1, & - thlm_spur_src, sfc ) - end if - - return - end subroutine advance_clubb_core - - !----------------------------------------------------------------------- - subroutine setup_clubb_core & - ( nzmax, T0_in, ts_nudge_in, & ! In - hydromet_dim_in, sclr_dim_in, & ! In - sclr_tol_in, edsclr_dim_in, params, & ! In - l_host_applies_sfc_fluxes, & ! In - l_uv_nudge, saturation_formula, & ! In -#ifdef GFDL - I_sat_sphum, & ! intent(in) h1g, 2010-06-16 -#endif - l_implemented, grid_type, deltaz, zm_init, zm_top, & ! In - momentum_heights, thermodynamic_heights, & ! In - host_dx, host_dy, sfc_elevation, & ! In -#ifdef GFDL - cloud_frac_min , & ! intent(in) h1g, 2010-06-16 -#endif - err_code ) ! Out - ! - ! Description: - ! Subroutine to set up the model for execution. - ! - ! References: - ! None - !------------------------------------------------------------------------- - use grid_class, only: & - setup_grid, & ! Procedure - gr ! Variable(s) - - use parameter_indices, only: & - nparams ! Variable(s) - - use parameters_tunable, only: & - setup_parameters ! Procedure - - use parameters_model, only: & - setup_parameters_model ! Procedure - - use variables_diagnostic_module, only: & - setup_diagnostic_variables ! Procedure - - use variables_prognostic_module, only: & - setup_prognostic_variables ! Procedure - - use constants_clubb, only: & - fstderr ! Variable(s) - - use error_code, only: & - clubb_no_error ! Constant(s) - - use model_flags, only: & - setup_model_flags, & ! Subroutine - l_gmres ! Variable - -#ifdef MKL - use csr_matrix_class, only: & - initialize_csr_class, & ! Subroutine - intlc_5d_5d_ja_size ! Variable - - use gmres_wrap, only: & - gmres_init ! Subroutine - - use gmres_cache, only: & - gmres_cache_temp_init, & ! Subroutine - gmres_idx_wp2wp3 ! Variable -#endif /* MKL */ - - use clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! Input Variables - - ! Grid definition - integer, intent(in) :: nzmax ! Vertical grid levels [#] - ! Only true when used in a host model - ! CLUBB determines what nzmax should be - ! given zm_init and zm_top when - ! running in standalone mode. - - real( kind = core_rknd ), intent(in) :: & - sfc_elevation ! Elevation of ground level [m AMSL] - - ! Flag to see if CLUBB is running on it's own, - ! or if it's implemented as part of a host model. - logical, intent(in) :: l_implemented ! (T/F) - - ! If CLUBB is running on it's own, this option determines - ! if it is using: - ! 1) an evenly-spaced grid, - ! 2) a stretched (unevenly-spaced) grid entered on the - ! thermodynamic grid levels (with momentum levels set - ! halfway between thermodynamic levels), or - ! 3) a stretched (unevenly-spaced) grid entered on the - ! momentum grid levels (with thermodynamic levels set - ! halfway between momentum levels). - integer, intent(in) :: grid_type - - ! If the CLUBB model is running by itself, and is using an - ! evenly-spaced grid (grid_type = 1), it needs the vertical - ! grid spacing, momentum-level starting altitude, and maximum - ! altitude as input. - real( kind = core_rknd ), intent(in) :: & - deltaz, & ! Change in altitude per level [m] - zm_init, & ! Initial grid altitude (momentum level) [m] - zm_top ! Maximum grid altitude (momentum level) [m] - - ! If the CLUBB parameterization is implemented in a host model, - ! it needs to use the host model's momentum level altitudes - ! and thermodynamic level altitudes. - ! If the CLUBB model is running by itself, but is using a - ! stretched grid entered on thermodynamic levels (grid_type = 2), - ! it needs to use the thermodynamic level altitudes as input. - ! If the CLUBB model is running by itself, but is using a - ! stretched grid entered on momentum levels (grid_type = 3), - ! it needs to use the momentum level altitudes as input. - real( kind = core_rknd ), intent(in), dimension(nzmax) :: & - momentum_heights, & ! Momentum level altitudes (input) [m] - thermodynamic_heights ! Thermodynamic level altitudes (input) [m] - - ! Host model horizontal grid spacing, if part of host model. - real( kind = core_rknd ), intent(in) :: & - host_dx, & ! East-West horizontal grid spacing [m] - host_dy ! North-South horizontal grid spacing [m] - - ! Model parameters - real( kind = core_rknd ), intent(in) :: & - T0_in, ts_nudge_in - - integer, intent(in) :: & - hydromet_dim_in, & ! Number of hydrometeor species - sclr_dim_in, & ! Number of passive scalars - edsclr_dim_in ! Number of eddy-diff. passive scalars - - real( kind = core_rknd ), intent(in), dimension(sclr_dim_in) :: & - sclr_tol_in ! Thresholds for passive scalars - - real( kind = core_rknd ), intent(in), dimension(nparams) :: & - params ! Including C1, nu1, nu2, etc. - - ! Flags - logical, intent(in) :: & - l_uv_nudge, & ! Wind nudging - l_host_applies_sfc_fluxes ! Whether to apply for the surface flux - - character(len=*), intent(in) :: & - saturation_formula ! Approximation for saturation vapor pressure - -#ifdef GFDL - logical, intent(in) :: & ! h1g, 2010-06-16 begin mod - I_sat_sphum - - real( kind = core_rknd ), intent(in) :: & - cloud_frac_min ! h1g, 2010-06-16 end mod -#endif - - ! Output variables - integer, intent(out) :: & - err_code ! Diagnostic for a problem with the setup - - ! Local variables - real( kind = core_rknd ) :: Lscale_max - integer :: begin_height, end_height - - !----- Begin Code ----- - - ! Sanity check for the saturation formula - select case ( trim( saturation_formula ) ) - case ( "bolton", "Bolton" ) - ! Using the Bolton 1980 approximations for SVP over vapor/ice - - case ( "flatau", "Flatau" ) - ! Using the Flatau, et al. polynomial approximation for SVP over vapor/ice - - case ( "gfdl", "GFDL" ) ! h1g, 2010-06-16 - ! Using the GFDL SVP formula (Goff-Gratch) - - ! Add new saturation formulas after this - - case default - write(fstderr,*) "Error in setup_clubb_core." - write(fstderr,*) "Unknown approx. of saturation vapor pressure: "// & - trim( saturation_formula ) - stop - end select - - ! Setup grid - call setup_grid( nzmax, sfc_elevation, l_implemented, & ! intent(in) - grid_type, deltaz, zm_init, zm_top, & ! intent(in) - momentum_heights, thermodynamic_heights, & ! intent(in) - begin_height, end_height ) ! intent(out) - - ! Setup flags -#ifdef GFDL - call setup_model_flags & - ( l_host_applies_sfc_fluxes, & ! intent(in) - l_uv_nudge, saturation_formula, & ! intent(in) - I_sat_sphum ) ! intent(in) h1g, 2010-06-16 - -#else - call setup_model_flags & - ( l_host_applies_sfc_fluxes, & ! intent(in) - l_uv_nudge, saturation_formula ) ! intent(in) -#endif - - ! Determine the maximum allowable value for Lscale (in meters). - call set_Lscale_max( l_implemented, host_dx, host_dy, & ! Intent(in) - Lscale_max ) ! Intent(out) - - ! Define model constant parameters -#ifdef GFDL - call setup_parameters_model( T0_in, ts_nudge_in, & ! In - hydromet_dim_in, & ! in - sclr_dim_in, sclr_tol_in, edsclr_dim_in, &! In - Lscale_max, cloud_frac_min ) ! In h1g, 2010-06-16 -#else - call setup_parameters_model( T0_in, ts_nudge_in, & ! In - hydromet_dim_in, & ! in - sclr_dim_in, sclr_tol_in, edsclr_dim_in, &! In - Lscale_max ) ! In -#endif - - ! Define tunable constant parameters - call setup_parameters & - ( deltaz, params, gr%nz, & ! intent(in) - grid_type, momentum_heights(begin_height:end_height), & ! intent(in) - thermodynamic_heights(begin_height:end_height), & ! intent(in) - err_code ) ! intent(out) - - ! Error Report - ! Joshua Fasching February 2008 - if ( err_code /= clubb_no_error ) then - - write(fstderr,*) "Error in setup_clubb_core" - - write(fstderr,*) "Intent(in)" - - write(fstderr,*) "deltaz = ", deltaz - write(fstderr,*) "zm_init = ", zm_init - write(fstderr,*) "zm_top = ", zm_top - write(fstderr,*) "momentum_heights = ", momentum_heights - write(fstderr,*) "thermodynamic_heights = ", & - thermodynamic_heights - write(fstderr,*) "T0_in = ", T0_in - write(fstderr,*) "ts_nudge_in = ", ts_nudge_in - write(fstderr,*) "params = ", params - - return - - end if - -#ifdef GFDL -! setup prognostic_variables - call setup_prognostic_variables( gr%nz ) ! intent(in) h1g, 2010-06-16 -#else - if ( .not. l_implemented ) then - call setup_prognostic_variables( gr%nz ) ! intent(in) - end if -#endif - - ! The diagnostic variables need to be - ! declared, allocated, initialized, and deallocated whether CLUBB - ! is part of a larger model or not. - call setup_diagnostic_variables( gr%nz ) - -#ifdef MKL - ! Initialize the CSR matrix class. - if ( l_gmres ) then - call initialize_csr_class - end if - - if ( l_gmres ) then - call gmres_cache_temp_init( gr%nz ) - call gmres_init( (2 * gr%nz), intlc_5d_5d_ja_size ) - end if -#endif /* MKL */ - - return - end subroutine setup_clubb_core - - !---------------------------------------------------------------------------- - subroutine cleanup_clubb_core( l_implemented ) - ! - ! Description: - ! Frees memory used by the model itself. - ! - ! References: - ! None - !--------------------------------------------------------------------------- - use parameters_model, only: sclr_tol ! Variable - - use variables_diagnostic_module, only: & - cleanup_diagnostic_variables ! Procedure - - use variables_prognostic_module, only: & - cleanup_prognostic_variables ! Procedure - - use grid_class, only: & - cleanup_grid ! Procedure - - use parameters_tunable, only: & - cleanup_nu ! Procedure - - implicit none - - ! Flag to see if CLUBB is running on it's own, - ! or if it's implemented as part of a host model. - logical, intent(in) :: l_implemented ! (T/F) - - !----- Begin Code ----- -#ifdef GFDL - ! cleanup prognostic_variables - call cleanup_prognostic_variables( ) ! h1g, 2010-06-16 -#else - if ( .not. l_implemented ) then - call cleanup_prognostic_variables( ) - end if -#endif - - ! The diagnostic variables need to be - ! declared, allocated, initialized, and deallocated whether CLUBB - ! is part of a larger model or not. - call cleanup_diagnostic_variables( ) - - ! De-allocate the array for the passive scalar tolerances - deallocate( sclr_tol ) - - ! De-allocate the arrays for the grid - call cleanup_grid( ) - - ! De-allocate the arrays for nu - call cleanup_nu( ) - - return - end subroutine cleanup_clubb_core - - !----------------------------------------------------------------------- - subroutine trapezoidal_rule_zt & - ( l_call_pdf_closure_twice, & ! intent(in) - wprtp2, wpthlp2, & ! intent(inout) - wprtpthlp, cloud_frac, rcm, wp2thvp, & ! intent(inout) - wpsclrprtp, wpsclrp2, wpsclrpthlp, & ! intent(inout) - pdf_params, & ! intent(inout) - wprtp2_zm, wpthlp2_zm, & ! intent(inout) - wprtpthlp_zm, cloud_frac_zm, & ! intent(inout) - rcm_zm, wp2thvp_zm, & ! intent(inout) - wpsclrprtp_zm, wpsclrp2_zm, wpsclrpthlp_zm, & ! intent(inout) - pdf_params_zm ) ! intent(inout) - ! - ! Description: - ! This subroutine takes the output variables on the thermo. - ! grid and either: interpolates them to the momentum grid, or uses the - ! values output from the second call to pdf_closure on momentum levels if - ! l_call_pdf_closure_twice is true. It then calls the function - ! trapezoid_zt to recompute the variables on the thermo. grid. - ! - ! ldgrant June 2009 - ! - ! Note: - ! The argument variables in the last 5 lines of the subroutine - ! (wprtp2_zm through pdf_params_zm) are declared intent(inout) because - ! if l_call_pdf_closure_twice is true, these variables will already have - ! values from pdf_closure on momentum levels and will not be altered in - ! this subroutine. However, if l_call_pdf_closure_twice is false, these - ! variables will not have values yet and will be interpolated to - ! momentum levels in this subroutine. - ! References: - ! None - !----------------------------------------------------------------------- - - use stats_variables, only: & - iwprtp2, & ! Varibles - iwprtpthlp, & - iwpthlp2, & - iwprtp2, & - iwpsclrp2, & - iwpsclrprtp, & - iwpsclrpthlp, & - l_stats - - use grid_class, only: & - gr, & ! Variable - zt2zm ! Procedure - - use parameters_model, only: & - sclr_dim ! Number of passive scalar variables - - use pdf_parameter_module, only: & - pdf_parameter ! Derived data type - - use clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! Input variables - logical, intent(in) :: l_call_pdf_closure_twice - - ! Input/Output variables - ! Thermodynamic level variables output from the first call to pdf_closure - real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & - wprtp2, & ! w'rt'^2 [m kg^2/kg^2] - wpthlp2, & ! w'thl'^2 [m K^2/s] - wprtpthlp, & ! w'rt'thl' [m kg K/kg s] - cloud_frac, & ! Cloud Fraction [-] - rcm, & ! Liquid water mixing ratio [kg/kg] - wp2thvp ! w'^2 th_v' [m^2 K/s^2] - - real( kind = core_rknd ), dimension(gr%nz,sclr_dim), intent(inout) :: & - wpsclrprtp, & ! w'sclr'rt' - wpsclrp2, & ! w'sclr'^2 - wpsclrpthlp ! w'sclr'thl' - - type (pdf_parameter), dimension(gr%nz), intent(inout) :: & - pdf_params ! PDF parameters [units vary] - - ! Thermo. level variables brought to momentum levels either by - ! interpolation (in subroutine trapezoidal_rule_zt) or by - ! the second call to pdf_closure (in subroutine advance_clubb_core) - real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & - wprtp2_zm, & ! w'rt'^2 on momentum grid [m kg^2/kg^2] - wpthlp2_zm, & ! w'thl'^2 on momentum grid [m K^2/s] - wprtpthlp_zm, & ! w'rt'thl' on momentum grid [m kg K/kg s] - cloud_frac_zm, & ! Cloud Fraction on momentum grid [-] - rcm_zm, & ! Liquid water mixing ratio on momentum grid [kg/kg] - wp2thvp_zm ! w'^2 th_v' on momentum grid [m^2 K/s^2] - - real( kind = core_rknd ), dimension(gr%nz,sclr_dim), intent(inout) :: & - wpsclrprtp_zm, & ! w'sclr'rt' on momentum grid - wpsclrp2_zm, & ! w'sclr'^2 on momentum grid - wpsclrpthlp_zm ! w'sclr'thl' on momentum grid - - type (pdf_parameter), dimension(gr%nz), intent(inout) :: & - pdf_params_zm ! PDF parameters on momentum grid [units vary] - - ! Local variables - integer :: i - - ! Components of PDF_parameters on the momentum grid (_zm) and on the thermo. grid (_zt) - real( kind = core_rknd ), dimension(gr%nz) :: & - w1_zt, & ! Mean of w for 1st normal distribution [m/s] - w1_zm, & ! Mean of w for 1st normal distribution [m/s] - w2_zm, & ! Mean of w for 2nd normal distribution [m/s] - w2_zt, & ! Mean of w for 2nd normal distribution [m/s] - varnce_w1_zm, & ! Variance of w for 1st normal distribution [m^2/s^2] - varnce_w1_zt, & ! Variance of w for 1st normal distribution [m^2/s^2] - varnce_w2_zm, & ! Variance of w for 2nd normal distribution [m^2/s^2] - varnce_w2_zt, & ! Variance of w for 2nd normal distribution [m^2/s^2] - rt1_zm, & ! Mean of r_t for 1st normal distribution [kg/kg] - rt1_zt, & ! Mean of r_t for 1st normal distribution [kg/kg] - rt2_zm, & ! Mean of r_t for 2nd normal distribution [kg/kg] - rt2_zt, & ! Mean of r_t for 2nd normal distribution [kg/kg] - varnce_rt1_zm, & ! Variance of r_t for 1st normal distribution [kg^2/kg^2] - varnce_rt1_zt, & ! Variance of r_t for 1st normal distribution [kg^2/kg^2] - varnce_rt2_zm, & ! Variance of r_t for 2nd normal distribution [kg^2/kg^2] - varnce_rt2_zt, & ! Variance of r_t for 2nd normal distribution [kg^2/kg^2] - crt1_zm, & ! Coefficient for s' [-] - crt1_zt, & ! Coefficient for s' [-] - crt2_zm, & ! Coefficient for s' [-] - crt2_zt, & ! Coefficient for s' [-] - cthl1_zm, & ! Coefficient for s' [1/K] - cthl1_zt, & ! Coefficient for s' [1/K] - cthl2_zm, & ! Coefficient for s' [1/K] - cthl2_zt, & ! Coefficient for s' [1/K] - thl1_zm, & ! Mean of th_l for 1st normal distribution [K] - thl1_zt, & ! Mean of th_l for 1st normal distribution [K] - thl2_zm, & ! Mean of th_l for 2nd normal distribution [K] - thl2_zt, & ! Mean of th_l for 2nd normal distribution - varnce_thl1_zm, & ! Variance of th_l for 1st normal distribution [K^2] - varnce_thl1_zt, & ! Variance of th_l for 1st normal distribution [K^2] - varnce_thl2_zm, & ! Variance of th_l for 2nd normal distribution [K^2] - varnce_thl2_zt ! Variance of th_l for 2nd normal distribution [K^2] - - real( kind = core_rknd ), dimension(gr%nz) :: & - mixt_frac_zm, & ! Weight of 1st normal distribution (Sk_w dependent) [-] - mixt_frac_zt, & ! Weight of 1st normal distribution (Sk_w dependent) [-] - rc1_zm, & ! Mean of r_c for 1st normal distribution [kg/kg] - rc1_zt, & ! Mean of r_c for 1st normal distribution [kg/kg] - rc2_zm, & ! Mean of r_c for 2nd normal distribution [kg/kg] - rc2_zt, & ! Mean of r_c for 2nd normal distribution [kg/kg] - rsl1_zm, & ! Mean of r_sl for 1st normal distribution [kg/kg] - rsl1_zt, & ! Mean of r_sl for 1st normal distribution [kg/kg] - rsl2_zm, & ! Mean of r_sl for 2nd normal distribution [kg/kg] - rsl2_zt, & ! Mean of r_sl for 2nd normal distribution [kg/kg] - cloud_frac1_zm, & ! Cloud fraction for 1st normal distribution [-] - cloud_frac1_zt, & ! Cloud fraction for 1st normal distribution [-] - cloud_frac2_zm, & ! Cloud fraction for 2nd normal distribution [-] - cloud_frac2_zt, & ! Cloud fraction for 2nd normal distribution [-] - s1_zm, & ! Mean of s for 1st normal distribution [kg/kg] - s1_zt, & ! Mean of s for 1st normal distribution [kg/kg] - s2_zm, & ! Mean of s for 2nd normal distribution [kg/kg] - s2_zt, & ! Mean of s for 2nd normal distribution [kg/kg] - stdev_s1_zm, & ! Standard deviation of s for 1st normal distribution [kg/kg] - stdev_s1_zt, & ! Standard deviation of s for 1st normal distribution [kg/kg] - stdev_s2_zm, & ! Standard deviation of s for 2nd normal distribution [kg/kg] - stdev_s2_zt, & ! Standard deviation of s for 2nd normal distribution [kg/kg] - rrtthl_zm, & ! Within-a-normal correlation of r_t and th_l [-] - rrtthl_zt, & ! Within-a-normal correlation of r_t and th_l [-] - alpha_thl_zm, & ! Factor relating to normalized variance for th_l [-] - alpha_thl_zt, & ! Factor relating to normalized variance for th_l [-] - alpha_rt_zm, & ! Factor relating to normalized variance for r_t [-] - alpha_rt_zt ! Factor relating to normalized variance for r_t [-] - - !----------------------- Begin Code ----------------------------- - - ! Store components of pdf_params in the locally declared variables - w1_zt = pdf_params%w1 - w2_zt = pdf_params%w2 - varnce_w1_zt = pdf_params%varnce_w1 - varnce_w2_zt = pdf_params%varnce_w2 - rt1_zt = pdf_params%rt1 - rt2_zt = pdf_params%rt2 - varnce_rt1_zt = pdf_params%varnce_rt1 - varnce_rt2_zt = pdf_params%varnce_rt2 - crt1_zt = pdf_params%crt1 - crt2_zt = pdf_params%crt2 - cthl1_zt = pdf_params%cthl1 - cthl2_zt = pdf_params%cthl2 - thl1_zt = pdf_params%thl1 - thl2_zt = pdf_params%thl2 - varnce_thl1_zt = pdf_params%varnce_thl1 - varnce_thl2_zt = pdf_params%varnce_thl2 - mixt_frac_zt = pdf_params%mixt_frac - rc1_zt = pdf_params%rc1 - rc2_zt = pdf_params%rc2 - rsl1_zt = pdf_params%rsl1 - rsl2_zt = pdf_params%rsl2 - cloud_frac1_zt = pdf_params%cloud_frac1 - cloud_frac2_zt = pdf_params%cloud_frac2 - s1_zt = pdf_params%s1 - s2_zt = pdf_params%s2 - stdev_s1_zt = pdf_params%stdev_s1 - stdev_s2_zt = pdf_params%stdev_s2 - rrtthl_zt = pdf_params%rrtthl - alpha_thl_zt = pdf_params%alpha_thl - alpha_rt_zt = pdf_params%alpha_rt - - ! If l_call_pdf_closure_twice is true, the _zm variables already have - ! values from the second call to pdf_closure in advance_clubb_core. - ! If it is false, the variables are interpolated to the _zm levels. - if ( l_call_pdf_closure_twice ) then - - ! Store, in locally declared variables, the pdf_params output - ! from the second call to pdf_closure - w1_zm = pdf_params_zm%w1 - w2_zm = pdf_params_zm%w2 - varnce_w1_zm = pdf_params_zm%varnce_w1 - varnce_w2_zm = pdf_params_zm%varnce_w2 - rt1_zm = pdf_params_zm%rt1 - rt2_zm = pdf_params_zm%rt2 - varnce_rt1_zm = pdf_params_zm%varnce_rt1 - varnce_rt2_zm = pdf_params_zm%varnce_rt2 - crt1_zm = pdf_params_zm%crt1 - crt2_zm = pdf_params_zm%crt2 - cthl1_zm = pdf_params_zm%cthl1 - cthl2_zm = pdf_params_zm%cthl2 - thl1_zm = pdf_params_zm%thl1 - thl2_zm = pdf_params_zm%thl2 - varnce_thl1_zm = pdf_params_zm%varnce_thl1 - varnce_thl2_zm = pdf_params_zm%varnce_thl2 - mixt_frac_zm = pdf_params_zm%mixt_frac - rc1_zm = pdf_params_zm%rc1 - rc2_zm = pdf_params_zm%rc2 - rsl1_zm = pdf_params_zm%rsl1 - rsl2_zm = pdf_params_zm%rsl2 - cloud_frac1_zm = pdf_params_zm%cloud_frac1 - cloud_frac2_zm = pdf_params_zm%cloud_frac2 - s1_zm = pdf_params_zm%s1 - s2_zm = pdf_params_zm%s2 - stdev_s1_zm = pdf_params_zm%stdev_s1 - stdev_s2_zm = pdf_params_zm%stdev_s2 - rrtthl_zm = pdf_params_zm%rrtthl - alpha_thl_zm = pdf_params_zm%alpha_thl - alpha_rt_zm = pdf_params_zm%alpha_rt - - else - - ! Interpolate thermodynamic variables to the momentum grid. - ! Since top momentum level is higher than top thermo. level, - ! set variables at top momentum level to 0. - wprtp2_zm = zt2zm( wprtp2 ) - wprtp2_zm(gr%nz) = 0.0_core_rknd - wpthlp2_zm = zt2zm( wpthlp2 ) - wpthlp2_zm(gr%nz) = 0.0_core_rknd - wprtpthlp_zm = zt2zm( wprtpthlp ) - wprtpthlp_zm(gr%nz) = 0.0_core_rknd - cloud_frac_zm = zt2zm( cloud_frac ) - cloud_frac_zm(gr%nz) = 0.0_core_rknd - rcm_zm = zt2zm( rcm ) - rcm_zm(gr%nz) = 0.0_core_rknd - wp2thvp_zm = zt2zm( wp2thvp ) - wp2thvp_zm(gr%nz) = 0.0_core_rknd - - do i = 1, sclr_dim - wpsclrprtp_zm(:,i) = zt2zm( wpsclrprtp(:,i) ) - wpsclrprtp_zm(gr%nz,i) = 0.0_core_rknd - wpsclrp2_zm(:,i) = zt2zm( wpsclrp2(:,i) ) - wpsclrp2_zm(gr%nz,i) = 0.0_core_rknd - wpsclrpthlp_zm(:,i) = zt2zm( wpsclrpthlp(:,i) ) - wpsclrpthlp_zm(gr%nz,i) = 0.0_core_rknd - end do ! i = 1, sclr_dim - - w1_zm = zt2zm( pdf_params%w1 ) - w1_zm(gr%nz) = 0.0_core_rknd - w2_zm = zt2zm( pdf_params%w2 ) - w2_zm(gr%nz) = 0.0_core_rknd - varnce_w1_zm = zt2zm( pdf_params%varnce_w1 ) - varnce_w1_zm(gr%nz) = 0.0_core_rknd - varnce_w2_zm = zt2zm( pdf_params%varnce_w2 ) - varnce_w2_zm(gr%nz) = 0.0_core_rknd - rt1_zm = zt2zm( pdf_params%rt1 ) - rt1_zm(gr%nz) = 0.0_core_rknd - rt2_zm = zt2zm( pdf_params%rt2 ) - rt2_zm(gr%nz) = 0.0_core_rknd - varnce_rt1_zm = zt2zm( pdf_params%varnce_rt1 ) - varnce_rt1_zm(gr%nz) = 0.0_core_rknd - varnce_rt2_zm = zt2zm( pdf_params%varnce_rt2 ) - varnce_rt2_zm(gr%nz) = 0.0_core_rknd - crt1_zm = zt2zm( pdf_params%crt1 ) - crt1_zm(gr%nz) = 0.0_core_rknd - crt2_zm = zt2zm( pdf_params%crt2 ) - crt2_zm(gr%nz) = 0.0_core_rknd - cthl1_zm = zt2zm( pdf_params%cthl1 ) - cthl1_zm(gr%nz) = 0.0_core_rknd - cthl2_zm = zt2zm( pdf_params%cthl2 ) - cthl2_zm(gr%nz) = 0.0_core_rknd - thl1_zm = zt2zm( pdf_params%thl1 ) - thl1_zm(gr%nz) = 0.0_core_rknd - thl2_zm = zt2zm( pdf_params%thl2 ) - thl2_zm(gr%nz) = 0.0_core_rknd - varnce_thl1_zm = zt2zm( pdf_params%varnce_thl1 ) - varnce_thl1_zm(gr%nz) = 0.0_core_rknd - varnce_thl2_zm = zt2zm( pdf_params%varnce_thl2 ) - varnce_thl2_zm(gr%nz) = 0.0_core_rknd - mixt_frac_zm = zt2zm( pdf_params%mixt_frac ) - mixt_frac_zm(gr%nz) = 0.0_core_rknd - rc1_zm = zt2zm( pdf_params%rc1 ) - rc1_zm(gr%nz) = 0.0_core_rknd - rc2_zm = zt2zm( pdf_params%rc2 ) - rc2_zm(gr%nz) = 0.0_core_rknd - rsl1_zm = zt2zm( pdf_params%rsl1 ) - rsl1_zm(gr%nz) = 0.0_core_rknd - rsl2_zm = zt2zm( pdf_params%rsl2 ) - rsl2_zm(gr%nz) = 0.0_core_rknd - cloud_frac1_zm = zt2zm( pdf_params%cloud_frac1 ) - cloud_frac1_zm(gr%nz) = 0.0_core_rknd - cloud_frac2_zm = zt2zm( pdf_params%cloud_frac2 ) - cloud_frac2_zm(gr%nz) = 0.0_core_rknd - s1_zm = zt2zm( pdf_params%s1 ) - s1_zm(gr%nz) = 0.0_core_rknd - s2_zm = zt2zm( pdf_params%s2 ) - s2_zm(gr%nz) = 0.0_core_rknd - stdev_s1_zm = zt2zm( pdf_params%stdev_s1 ) - stdev_s1_zm(gr%nz) = 0.0_core_rknd - stdev_s2_zm = zt2zm( pdf_params%stdev_s2 ) - stdev_s2_zm(gr%nz) = 0.0_core_rknd - rrtthl_zm = zt2zm( pdf_params%rrtthl ) - rrtthl_zm(gr%nz) = 0.0_core_rknd - alpha_thl_zm = zt2zm( pdf_params%alpha_thl ) - alpha_thl_zm(gr%nz) = 0.0_core_rknd - alpha_rt_zm = zt2zm( pdf_params%alpha_rt ) - alpha_rt_zm(gr%nz) = 0.0_core_rknd - end if ! l_call_pdf_closure_twice - - if ( l_stats ) then - ! Use the trapezoidal rule to recompute the variables on the zt level - if ( iwprtp2 > 0 ) then - wprtp2 = trapezoid_zt( wprtp2, wprtp2_zm ) - end if - if ( iwpthlp2 > 0 ) then - wpthlp2 = trapezoid_zt( wpthlp2, wpthlp2_zm ) - end if - if ( iwprtpthlp > 0 ) then - wprtpthlp = trapezoid_zt( wprtpthlp, wprtpthlp_zm ) - end if - - do i = 1, sclr_dim - if ( iwpsclrprtp(i) > 0 ) then - wpsclrprtp(:,i) = trapezoid_zt( wpsclrprtp(:,i), wpsclrprtp_zm(:,i) ) - end if - if ( iwpsclrpthlp(i) > 0 ) then - wpsclrpthlp(:,i) = trapezoid_zt( wpsclrpthlp(:,i), wpsclrpthlp_zm(:,i) ) - end if - if ( iwpsclrp2(i) > 0 ) then - wpsclrp2(:,i) = trapezoid_zt( wpsclrp2(:,i), wpsclrp2_zm(:,i) ) - end if - end do ! i = 1, sclr_dim - end if - - cloud_frac = trapezoid_zt( cloud_frac, cloud_frac_zm ) - rcm = trapezoid_zt( rcm, rcm_zm ) - wp2thvp = trapezoid_zt( wp2thvp, wp2thvp_zm ) - - pdf_params%w1 = trapezoid_zt( w1_zt, w1_zm ) - pdf_params%w2 = trapezoid_zt( w2_zt, w2_zm ) - pdf_params%varnce_w1 = trapezoid_zt( varnce_w1_zt, varnce_w1_zm ) - pdf_params%varnce_w2 = trapezoid_zt( varnce_w2_zt, varnce_w2_zm ) - pdf_params%rt1 = trapezoid_zt( rt1_zt, rt1_zm ) - pdf_params%rt2 = trapezoid_zt( rt2_zt, rt2_zm ) - pdf_params%varnce_rt1 = trapezoid_zt( varnce_rt1_zt, varnce_rt1_zm ) - pdf_params%varnce_rt2 = trapezoid_zt( varnce_rt2_zt, varnce_rt2_zm ) - pdf_params%crt1 = trapezoid_zt( crt1_zt, crt1_zm ) - pdf_params%crt2 = trapezoid_zt( crt2_zt, crt2_zm ) - pdf_params%cthl1 = trapezoid_zt( cthl1_zt, cthl1_zm ) - pdf_params%cthl2 = trapezoid_zt( cthl2_zt, cthl2_zm ) - pdf_params%thl1 = trapezoid_zt( thl1_zt, thl1_zm ) - pdf_params%thl2 = trapezoid_zt( thl2_zt, thl2_zm ) - pdf_params%varnce_thl1 = trapezoid_zt( varnce_thl1_zt, varnce_thl1_zm ) - pdf_params%varnce_thl2 = trapezoid_zt( varnce_thl2_zt, varnce_thl2_zm ) - pdf_params%mixt_frac = trapezoid_zt( mixt_frac_zt, mixt_frac_zm ) - pdf_params%rc1 = trapezoid_zt( rc1_zt, rc1_zm ) - pdf_params%rc2 = trapezoid_zt( rc2_zt, rc2_zm ) - pdf_params%rsl1 = trapezoid_zt( rsl1_zt, rsl1_zm ) - pdf_params%rsl2 = trapezoid_zt( rsl2_zt, rsl2_zm ) - pdf_params%cloud_frac1 = trapezoid_zt( cloud_frac1_zt, cloud_frac1_zm ) - pdf_params%cloud_frac2 = trapezoid_zt( cloud_frac2_zt, cloud_frac2_zm ) - pdf_params%s1 = trapezoid_zt( s1_zt, s1_zm ) - pdf_params%s2 = trapezoid_zt( s2_zt, s2_zm ) - pdf_params%stdev_s1 = trapezoid_zt( stdev_s1_zt, stdev_s1_zm ) - pdf_params%stdev_s2 = trapezoid_zt( stdev_s2_zt, stdev_s2_zm ) - pdf_params%rrtthl = trapezoid_zt( rrtthl_zt, rrtthl_zm ) - pdf_params%alpha_thl = trapezoid_zt( alpha_thl_zt, alpha_thl_zm ) - pdf_params%alpha_rt = trapezoid_zt( alpha_rt_zt, alpha_rt_zm ) - ! End of trapezoidal rule - - return - end subroutine trapezoidal_rule_zt - - !----------------------------------------------------------------------- - subroutine trapezoidal_rule_zm & - ( wpthvp_zt, thlpthvp_zt, rtpthvp_zt, & ! intent(in) - wpthvp, thlpthvp, rtpthvp ) ! intent(inout) - ! - ! Description: - ! This subroutine recomputes three variables on the - ! momentum grid from pdf_closure -- wpthvp, thlpthvp, and - ! rtpthvp -- by calling the function trapezoid_zm. Only these three - ! variables are used in this subroutine because they are the only - ! pdf_closure momentum variables used elsewhere in CLUBB. - ! - ! The _zt variables are output from the first call to pdf_closure. - ! The _zm variables are output from the second call to pdf_closure - ! on the momentum levels. - ! This is done before the call to this subroutine. - ! - ! ldgrant Feb. 2010 - ! - ! References: - ! None - !----------------------------------------------------------------------- - - use grid_class, only: gr ! Variable - - use clubb_precision, only: & - core_rknd ! variable(s) - - implicit none - - ! Input variables - real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & - wpthvp_zt, & ! Buoyancy flux (on thermo. grid) [(K m)/s] - thlpthvp_zt, & ! th_l' th_v' (on thermo. grid) [K^2] - rtpthvp_zt ! r_t' th_v' (on thermo. grid) [(kg K)/kg] - - ! Input/Output variables - real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & - wpthvp, & ! Buoyancy flux [(K m)/s] - thlpthvp, & ! th_l' th_v' [K^2] - rtpthvp ! r_t' th_v' [(kg K)/kg] - - !----------------------- Begin Code ----------------------------- - - ! Use the trapezoidal rule to recompute the variables on the zm level - wpthvp = trapezoid_zm( wpthvp, wpthvp_zt ) - thlpthvp = trapezoid_zm( thlpthvp, thlpthvp_zt ) - rtpthvp = trapezoid_zm( rtpthvp, rtpthvp_zt ) - - return - end subroutine trapezoidal_rule_zm - - !----------------------------------------------------------------------- - pure function trapezoid_zt( variable_zt, variable_zm ) - ! - ! Description: - ! Function which uses the trapezoidal rule from calculus - ! to recompute the values for the variables on the thermo. grid which - ! are output from the first call to pdf_closure in module clubb_core. - ! - ! ldgrant June 2009 - !-------------------------------------------------------------------- - - use grid_class, only: gr ! Variable - - use clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! Input Variables - real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & - variable_zt, & ! Variable on the zt grid - variable_zm ! Variable on the zm grid - - ! Result - real( kind = core_rknd ), dimension(gr%nz) :: trapezoid_zt - - ! Local Variable - integer :: k ! Loop index - - !------------ Begin Code -------------- - - ! Boundary condition: trapezoidal rule not valid at zt level 1 - trapezoid_zt(1) = variable_zt(1) - - do k = 2, gr%nz - ! Trapezoidal rule from calculus - trapezoid_zt(k) = 0.5_core_rknd * ( variable_zm(k) + variable_zt(k) ) & - * ( gr%zm(k) - gr%zt(k) ) * gr%invrs_dzt(k) & - + 0.5_core_rknd * ( variable_zt(k) + variable_zm(k-1) ) & - * ( gr%zt(k) - gr%zm(k-1) ) * gr%invrs_dzt(k) - end do ! k = 2, gr%nz - - return - end function trapezoid_zt - - !----------------------------------------------------------------------- - pure function trapezoid_zm( variable_zm, variable_zt ) - ! - ! Description: - ! Function which uses the trapezoidal rule from calculus - ! to recompute the values for the important variables on the momentum - ! grid which are output from pdf_closure in module clubb_core. - ! These momentum variables only include wpthvp, thlpthvp, and rtpthvp. - ! - ! ldgrant Feb. 2010 - !-------------------------------------------------------------------- - - use grid_class, only: gr ! Variable - - use clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! Input Variables - real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & - variable_zm, & ! Variable on the zm grid - variable_zt ! Variable on the zt grid - - ! Result - real( kind = core_rknd ), dimension(gr%nz) :: trapezoid_zm - - ! Local Variable - integer :: k ! Loop index - - !------------ Begin Code -------------- - - ! Boundary conditions: trapezoidal rule not valid at top zm level, nzmax. - ! Trapezoidal rule also not used at zm level 1. - trapezoid_zm(1) = variable_zm(1) - trapezoid_zm(gr%nz) = variable_zm(gr%nz) - - do k = 2, gr%nz-1 - ! Trapezoidal rule from calculus - trapezoid_zm(k) = 0.5_core_rknd * ( variable_zt(k+1) + variable_zm(k) ) & - * ( gr%zt(k+1) - gr%zm(k) ) * gr%invrs_dzm(k) & - + 0.5_core_rknd * ( variable_zm(k) + variable_zt(k) ) & - * ( gr%zm(k) - gr%zt(k) ) * gr%invrs_dzm(k) - end do ! k = 2, gr%nz-1 - - return - end function trapezoid_zm - - !----------------------------------------------------------------------- - subroutine compute_cloud_cover & - ( pdf_params, cloud_frac, rcm, & ! intent(in) - cloud_cover, rcm_in_layer ) ! intent(out) - ! - ! Description: - ! Subroutine to compute cloud cover (the amount of sky - ! covered by cloud) and rcm in layer (liquid water mixing ratio in - ! the portion of the grid box filled by cloud). - ! - ! References: - ! Definition of 's' comes from: - ! ``The Gaussian Cloud Model Relations'' G. L. Mellor (1977) - ! JAS, Vol. 34, pp. 356--358. - ! - ! Notes: - ! Added July 2009 - !--------------------------------------------------------------------- - - use constants_clubb, only: & - rc_tol, & ! Variable(s) - fstderr - - use grid_class, only: gr ! Variable - - use pdf_parameter_module, only: & - pdf_parameter ! Derived data type - - use error_code, only: & - clubb_at_least_debug_level ! Procedure - - use clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! External functions - intrinsic :: abs, min, max - - ! Input variables - real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & - cloud_frac, & ! Cloud fraction [-] - rcm ! Liquid water mixing ratio [kg/kg] - - type (pdf_parameter), dimension(gr%nz), intent(in) :: & - pdf_params ! PDF Parameters [units vary] - - ! Output variables - real( kind = core_rknd ), dimension(gr%nz), intent(out) :: & - cloud_cover, & ! Cloud cover [-] - rcm_in_layer ! Liquid water mixing ratio in cloud layer [kg/kg] - - ! Local variables - real( kind = core_rknd ), dimension(gr%nz) :: & - s_mean, & ! Mean extended cloud water mixing ratio of the - ! two Gaussian distributions - vert_cloud_frac_upper, & ! Fraction of cloud in top half of grid box - vert_cloud_frac_lower, & ! Fraction of cloud in bottom half of grid box - vert_cloud_frac ! Fraction of cloud filling the grid box in the vertical - - integer :: k - - ! ------------ Begin code --------------- - - do k = 1, gr%nz - - s_mean(k) = pdf_params(k)%mixt_frac * pdf_params(k)%s1 + & - (1.0_core_rknd-pdf_params(k)%mixt_frac) * pdf_params(k)%s2 - - end do - - do k = 2, gr%nz-1, 1 - - if ( rcm(k) < rc_tol ) then ! No cloud at this level - - cloud_cover(k) = cloud_frac(k) - rcm_in_layer(k) = rcm(k) - - else if ( ( rcm(k+1) >= rc_tol ) .and. ( rcm(k-1) >= rc_tol ) ) then - ! There is cloud above and below, - ! so assume cloud fills grid box from top to bottom - - cloud_cover(k) = cloud_frac(k) - rcm_in_layer(k) = rcm(k) - - else if ( ( rcm(k+1) < rc_tol ) .or. ( rcm(k-1) < rc_tol) ) then - ! Cloud may fail to reach gridbox top or base or both - - ! First let the cloud fill the entire grid box, then overwrite - ! vert_cloud_frac_upper(k) and/or vert_cloud_frac_lower(k) - ! for a cloud top, cloud base, or one-point cloud. - vert_cloud_frac_upper(k) = 0.5_core_rknd - vert_cloud_frac_lower(k) = 0.5_core_rknd - - if ( rcm(k+1) < rc_tol ) then ! Cloud top - - vert_cloud_frac_upper(k) = & - ( ( 0.5_core_rknd / gr%invrs_dzm(k) ) / ( gr%zm(k) - gr%zt(k) ) ) & - * ( rcm(k) / ( rcm(k) + abs( s_mean(k+1) ) ) ) - - vert_cloud_frac_upper(k) = min( 0.5_core_rknd, vert_cloud_frac_upper(k) ) - - ! Make the transition in cloudiness more gradual than using - ! the above min statement alone. - vert_cloud_frac_upper(k) = vert_cloud_frac_upper(k) + & - ( ( rcm(k+1)/rc_tol )*( 0.5_core_rknd -vert_cloud_frac_upper(k) ) ) - - else - - vert_cloud_frac_upper(k) = 0.5_core_rknd - - end if - - if ( rcm(k-1) < rc_tol ) then ! Cloud base - - vert_cloud_frac_lower(k) = & - ( ( 0.5_core_rknd / gr%invrs_dzm(k-1) ) / ( gr%zt(k) - gr%zm(k-1) ) ) & - * ( rcm(k) / ( rcm(k) + abs( s_mean(k-1) ) ) ) - - vert_cloud_frac_lower(k) = min( 0.5_core_rknd, vert_cloud_frac_lower(k) ) - - ! Make the transition in cloudiness more gradual than using - ! the above min statement alone. - vert_cloud_frac_lower(k) = vert_cloud_frac_lower(k) + & - ( ( rcm(k-1)/rc_tol )*( 0.5_core_rknd -vert_cloud_frac_lower(k) ) ) - - else - - vert_cloud_frac_lower(k) = 0.5_core_rknd - - end if - - vert_cloud_frac(k) = & - vert_cloud_frac_upper(k) + vert_cloud_frac_lower(k) - - vert_cloud_frac(k) = & - max( cloud_frac(k), min( 1.0_core_rknd, vert_cloud_frac(k) ) ) - - cloud_cover(k) = cloud_frac(k) / vert_cloud_frac(k) - rcm_in_layer(k) = rcm(k) / vert_cloud_frac(k) - - else - - if ( clubb_at_least_debug_level( 1 ) ) then - - write(fstderr,*) & - "Error: Should not arrive here in computation of cloud_cover" - - write(fstderr,*) "At grid level k = ", k - write(fstderr,*) "pdf_params(k)%mixt_frac = ", pdf_params(k)%mixt_frac - write(fstderr,*) "pdf_params(k)%s1 = ", pdf_params(k)%s1 - write(fstderr,*) "pdf_params(k)%s2 = ", pdf_params(k)%s2 - write(fstderr,*) "cloud_frac(k) = ", cloud_frac(k) - write(fstderr,*) "rcm(k) = ", rcm(k) - write(fstderr,*) "rcm(k+1) = ", rcm(k+1) - write(fstderr,*) "rcm(k-1) = ", rcm(k-1) - - end if - - return - - end if ! rcm(k) < rc_tol - - end do ! k = 2, gr%nz-1, 1 - - cloud_cover(1) = cloud_frac(1) - cloud_cover(gr%nz) = cloud_frac(gr%nz) - - rcm_in_layer(1) = rcm(1) - rcm_in_layer(gr%nz) = rcm(gr%nz) - - return - end subroutine compute_cloud_cover - !----------------------------------------------------------------------- - subroutine clip_rcm & - ( rtm, message, & ! intent(in) - rcm ) ! intent(inout) - ! - ! Description: - ! Subroutine that reduces cloud water (rcm) whenever - ! it exceeds total water (rtm = vapor + liquid). - ! This avoids negative values of rvm = water vapor mixing ratio. - ! However, it will not ensure that rcm <= rtm if rtm <= 0. - ! - ! References: - ! None - !--------------------------------------------------------------------- - - - use grid_class, only: gr ! Variable - - use error_code, only : & - clubb_at_least_debug_level ! Procedure(s) - - use constants_clubb, only: & - fstderr, & ! Variable(s) - zero_threshold - - use clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! External functions - intrinsic :: max, epsilon - - ! Input variables - real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & - rtm ! Total water mixing ratio [kg/kg] - - character(len= * ), intent(in) :: message - - real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & - rcm ! Cloud water mixing ratio [kg/kg] - - integer :: k - - ! ------------ Begin code --------------- - - ! Vince Larson clipped rcm in order to prevent rvm < 0. 5 Apr 2008. - ! This code won't work unless rtm >= 0 !!! - ! We do not clip rcm_in_layer because rcm_in_layer only influences - ! radiation, and we do not want to bother recomputing it. 6 Aug 2009 - do k = 1, gr%nz - if ( rtm(k) < rcm(k) ) then - - if ( clubb_at_least_debug_level(1) ) then - write(fstderr,*) message, ' at k=', k, 'rcm(k) = ', rcm(k), & - 'rtm(k) = ', rtm(k), '.', ' Clipping rcm.' - - end if ! clubb_at_least_debug_level(1) - - rcm(k) = max( zero_threshold, rtm(k) - epsilon( rtm(k) ) ) - - end if ! rtm(k) < rcm(k) - - end do ! k=1..gr%nz - - return - end subroutine clip_rcm - - !----------------------------------------------------------------------------- - subroutine set_Lscale_max( l_implemented, host_dx, host_dy, & - Lscale_max ) - - ! Description: - ! This subroutine sets the value of Lscale_max, which is the maximum - ! allowable value of Lscale. For standard CLUBB, it is set to a very large - ! value so that Lscale will not be limited. However, when CLUBB is running - ! as part of a host model, the value of Lscale_max is dependent on the size - ! of the host model's horizontal grid spacing. The smaller the host model's - ! horizontal grid spacing, the smaller the value of Lscale_max. When Lscale - ! is limited to a small value, the value of time-scale Tau is reduced, which - ! in turn produces greater damping on CLUBB's turbulent parameters. This - ! is the desired effect on turbulent parameters for a host model with small - ! horizontal grid spacing, for small areas usually contain much less - ! variation in meteorological quantities than large areas. - - ! References: - ! None - !----------------------------------------------------------------------- - - use clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! Input Variables - logical, intent(in) :: & - l_implemented ! Flag to see if CLUBB is running on it's own, - ! or if it's implemented as part of a host model. - - real( kind = core_rknd ), intent(in) :: & - host_dx, & ! Host model's east-west horizontal grid spacing [m] - host_dy ! Host model's north-south horizontal grid spacing [m] - - ! Output Variable - real( kind = core_rknd ), intent(out) :: & - Lscale_max ! Maximum allowable value for Lscale [m] - - ! ---- Begin Code ---- - - ! Determine the maximum allowable value for Lscale (in meters). - if ( l_implemented ) then - Lscale_max = 0.25_core_rknd * min( host_dx, host_dy ) - else - Lscale_max = 1.0e5_core_rknd - end if - - return - end subroutine set_Lscale_max - -!=============================================================================== - -end module clubb_core -! vim: set expandtab tabstop=2 shiftwidth=2 textwidth=100 autoindent: diff --git a/models/atm/cam/src/physics/clubb/clubb_precision.F90 b/models/atm/cam/src/physics/clubb/clubb_precision.F90 index 802a278d137e..1d2554beb266 100644 --- a/models/atm/cam/src/physics/clubb/clubb_precision.F90 +++ b/models/atm/cam/src/physics/clubb/clubb_precision.F90 @@ -1,13 +1,21 @@ !------------------------------------------------------------------------------- -! $Id: clubb_precision.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +! $Id: clubb_precision.F90 6849 2014-04-22 21:52:30Z charlass@uwm.edu $ +!=============================================================================== module clubb_precision implicit none - public :: stat_nknd, stat_rknd, time_precision, dp, sp, core_rknd + public :: stat_nknd, stat_rknd, time_precision, dp, core_rknd private ! Default scope + ! This definition of double precision must use a real type that is 64 bits + ! wide, because (at least) the LAPACK routines depend on this definition being + ! accurate. Otherwise, LAPACK must be recompiled, or some other trickery must + ! be done. + integer, parameter :: & + dp = selected_real_kind( p=12 ) ! double precision + ! The precisions below are arbitrary, and could be adjusted as ! needed for long simulations or time averaging. Note that on ! most machines 12 digits of precision will use a data type @@ -16,8 +24,6 @@ module clubb_precision stat_nknd = selected_int_kind( 8 ), & stat_rknd = selected_real_kind( p=12 ), & time_precision = selected_real_kind( p=12 ), & - dp = selected_real_kind( p=12 ), & ! double precision - sp = selected_real_kind( p=5 ), & ! single precision core_rknd = CLUBB_REAL_TYPE ! Value from the preprocessor directive end module clubb_precision diff --git a/models/atm/cam/src/physics/clubb/constants_clubb.F90 b/models/atm/cam/src/physics/clubb/constants_clubb.F90 index bd8f4eaa4f29..f0e7f2350007 100644 --- a/models/atm/cam/src/physics/clubb/constants_clubb.F90 +++ b/models/atm/cam/src/physics/clubb/constants_clubb.F90 @@ -1,5 +1,5 @@ !----------------------------------------------------------------------------- -! $Id: constants_clubb.F90 5641 2012-01-19 21:11:17Z bmg2@uwm.edu $ +! $Id: constants_clubb.F90 7140 2014-07-31 19:14:05Z betlej@uwm.edu $ !============================================================================= module constants_clubb @@ -11,8 +11,7 @@ module constants_clubb !--------------------------------------------------------------------------- use clubb_precision, only: & - time_precision, & ! Variable(s) - dp, & + dp, & ! Variable(s) core_rknd #ifdef CLUBB_CAM /* Set constants as they're set in CAM */ @@ -21,6 +20,22 @@ module constants_clubb shr_const_mwwv, shr_const_stebol, shr_const_tkfrz, & shr_const_mwdair, shr_const_g, shr_const_karman, & shr_const_rhofw +#elif GFDL + ! use GFDL constants, and then rename them to avoid confusion in case + ! that the constants share the same names between GFDL and CLUBB + use constants_mod, only: pi_gfdl => PI, & + radians_per_deg_dp_gfdl => DEG_TO_RAD, & + Cp_gfdl => CP_AIR, & + Lv_gfdl => HLV, & + Ls_gfdl => HLS, & + Lf_gfdl => HLF, & + Rd_gfdl => RDGAS, & + Rv_gfdl => RVGAS, & + stefan_boltzmann_gfdl => STEFAN, & + T_freeze_K_gfdl => TFREEZE, & + grav_gfdl => GRAV, & + vonk_gfdl => VONKARM, & + rho_lw_gfdl => DENS_H2O #endif implicit none @@ -53,9 +68,9 @@ module constants_clubb ! The largest allowable magnitude of the input to the parabolic cylinder ! function (before overflow occurs) is dependent on the order of parabolic ! cylinder function. However, after a lot of testing, it was determined that - ! an absolute value of 375 works well for an order of 12 or less. + ! an absolute value of 49 works well for an order of 12 or less. real( kind = core_rknd ), parameter, public :: & - parab_cyl_max_input = 375._core_rknd ! Largest allowable input to parab. cyl. fnct. + parab_cyl_max_input = 49.0_core_rknd ! Largest allowable input to parab. cyl. fnct. ! "Over-implicit" weighted time step. ! @@ -105,11 +120,20 @@ module constants_clubb real( kind = dp ), parameter, public :: & pi_dp = 3.14159265358979323846_dp +#ifdef GFDL + real( kind = core_rknd ), parameter, public :: & + pi = pi_gfdl ! The ratio of radii to their circumference + + real( kind = dp ), parameter, public :: & + radians_per_deg_dp = radians_per_deg_dp_gfdl +#else + real( kind = core_rknd ), parameter, public :: & pi = 3.141592654_core_rknd ! The ratio of radii to their circumference real( kind = dp ), parameter, public :: & radians_per_deg_dp = pi_dp / 180._dp +#endif real( kind = core_rknd ), parameter, public :: & sqrt_2pi = 2.5066282746310005024_core_rknd, & ! sqrt(2*pi) @@ -180,6 +204,45 @@ module constants_clubb vonk = shr_const_karman, & ! Accepted value is 0.40 (+/-) 0.01 [-] rho_lw = shr_const_rhofw ! Density of liquid water [kg/m^3] + +#elif GFDL + real( kind = core_rknd ), parameter, public :: & + Cp = Cp_gfdl, & ! Dry air specific heat at constant p [J/kg/K] + Lv = Lv_gfdl, & ! Latent heat of vaporization [J/kg] + Ls = Ls_gfdl, & ! Latent heat of sublimation [J/kg] + Lf = Lf_gfdl, & ! Latent heat of fusion [J/kg] + Rd = Rd_gfdl, & ! Dry air gas constant [J/kg/K] + Rv = Rv_gfdl ! Water vapor gas constant [J/kg/K] + + + real( kind = core_rknd ), parameter, public :: & + stefan_boltzmann = stefan_boltzmann_gfdl ! Stefan-Boltzmann constant [W/(m^2 K^4)] + + real( kind = core_rknd ), parameter, public :: & + T_freeze_K = T_freeze_K_gfdl ! Freezing point of water [K] + + ! Useful combinations of Rd and Rv + real( kind = core_rknd ), parameter, public :: & + ep = Rd / Rv, & ! ep = 0.622 [-] + ep1 = (1.0-ep)/ep,& ! ep1 = 0.61 [-] + ep2 = 1.0/ep ! ep2 = 1.61 [-] + + real( kind = core_rknd ), parameter, public :: & + kappa = Rd / Cp ! kappa [-] + + ! Changed g to grav to make it easier to find in the code 5/25/05 + ! real, parameter :: grav = 9.80665 ! Gravitational acceleration [m/s^2] + real( kind = core_rknd ), parameter, public :: & + grav = grav_gfdl, & ! Gravitational acceleration [m/s^2] + p0 = 1.0e5 ! Reference pressure [Pa] + + ! Von Karman's constant + ! Constant of the logarithmic wind profile in the surface layer + real( kind = core_rknd ), parameter, public :: & + vonk = vonk_gfdl, & ! Accepted value is 0.40 (+/-) 0.01 [-] + rho_lw = rho_lw_gfdl ! Density of liquid water [kg/m^3] + + #else real( kind = core_rknd ), parameter, public :: & @@ -220,12 +283,16 @@ module constants_clubb #endif + real( kind = core_rknd ), parameter, public :: & + rho_ice = 917.0_core_rknd ! Density of ice [kg/m^3] + ! Tolerances below which we consider moments to be zero real( kind = core_rknd ), parameter, public :: & - w_tol = 2.e-2_core_rknd, & ! [m/s] - thl_tol = 1.e-2_core_rknd, & ! [K] - rt_tol = 1.e-8_core_rknd, & ! [kg/kg] - s_mellor_tol = 1.e-8_core_rknd ! [kg/kg] + w_tol = 2.e-2_core_rknd, & ! [m/s] + thl_tol = 1.e-2_core_rknd, & ! [K] + rt_tol = 1.e-8_core_rknd, & ! [kg/kg] + chi_tol = 1.e-8_core_rknd, & ! [kg/kg] + eta_tol = chi_tol ! [kg/kg] ! Tolerances for use by the monatonic flux limiter. ! rt_tol_mfl is larger than rt_tol. rt_tol is extremely small @@ -255,17 +322,59 @@ module constants_clubb ! still officially have a cloud at that level. This is figured to be about ! 1.0_core_rknd x 10^-7 kg/kg. Brian; February 10, 2007. real( kind = core_rknd ), parameter, public :: & - rc_tol = 1.0E-6_core_rknd, & ! [kg/kg] - Nc_tol = 1.0E-10_core_rknd, & ! [#/kg] - rr_tol = 1.0E-10_core_rknd, & ! [kg/kg] - Nr_tol = 1.0E-10_core_rknd ! [#/kg] + rc_tol = 1.0E-6_core_rknd, & ! Tolerance value for r_c [kg/kg] + Nc_tol = 1.0E+2_core_rknd, & ! Tolerance value for N_c [#/kg] + Ncn_tol = 1.0E+2_core_rknd ! Tolerance value for N_cn [#/kg] + + real( kind = core_rknd ), parameter, public :: & + mvr_cloud_max = 1.6E-5_core_rknd ! Max. avg. mean vol. rad. cloud [m] + + real( kind = core_rknd ), parameter, public :: & + Nc_in_cloud_min = 2.0e+4_core_rknd + + ! Precipitating hydrometeor tolerances for mixing ratios. + real( kind = core_rknd ), parameter, public :: & + rr_tol = 1.0E-10_core_rknd, & ! Tolerance value for r_r [kg/kg] + ri_tol = 1.0E-10_core_rknd, & ! Tolerance value for r_i [kg/kg] + rs_tol = 1.0E-10_core_rknd, & ! Tolerance value for r_s [kg/kg] + rg_tol = 1.0E-10_core_rknd ! Tolerance value for r_g [kg/kg] + + ! Maximum allowable values for the average mean volume radius of the various + ! hydrometeor species. + real( kind = core_rknd ), parameter, public :: & + mvr_rain_max = 5.0E-3_core_rknd, & ! Max. avg. mean vol. rad. rain [m] + mvr_ice_max = 1.3E-4_core_rknd, & ! Max. avg. mean vol. rad. ice [m] + mvr_snow_max = 1.0E-2_core_rknd, & ! Max. avg. mean vol. rad. snow [m] + mvr_graupel_max = 2.0E-2_core_rknd ! Max. avg. mean vol. rad. graupel [m] + + ! Precipitating hydrometeor tolerances for concentrations. + ! Tolerance value for N_r [#/kg] + real( kind = core_rknd ), parameter, public :: & + Nr_tol = ( one / ( four_thirds * pi * rho_lw * mvr_rain_max**3 ) ) & + * rr_tol + + ! Tolerance value for N_i [#/kg] + real( kind = core_rknd ), parameter, public :: & + Ni_tol = ( one / ( four_thirds * pi * rho_ice * mvr_ice_max**3 ) ) & + * ri_tol + + ! Tolerance value for N_s [#/kg] + real( kind = core_rknd ), parameter, public :: & + Ns_tol = ( one / ( four_thirds * pi * rho_ice * mvr_snow_max**3 ) ) & + * rs_tol + + ! Tolerance value for N_s [#/kg] + real( kind = core_rknd ), parameter, public :: & + Ng_tol = ( one / ( four_thirds * pi * rho_ice * mvr_graupel_max**3 ) ) & + * rg_tol ! Minimum value for em (turbulence kinetic energy) ! If anisotropic TKE is enabled, em = (1/2) * ( up2 + vp2 + wp2 ); ! otherwise, em = (3/2) * wp2. Since up2, vp2, and wp2 all have ! the same minimum threshold value of w_tol_sqd, em cannot be less ! than (3/2) * w_tol_sqd. Thus, em_min = (3/2) * w_tol_sqd. - real( kind = core_rknd ), parameter, public :: em_min = 1.5_core_rknd * w_tol_sqd ! [m^2/s^2] + real( kind = core_rknd ), parameter, public :: & + em_min = 1.5_core_rknd * w_tol_sqd ! [m^2/s^2] real( kind = core_rknd ), parameter, public :: & eps = 1.0e-10_core_rknd ! Small value to prevent a divide by zero @@ -285,11 +394,11 @@ module constants_clubb !----------------------------------------------------------------------------- ! Useful conversion factors. !----------------------------------------------------------------------------- - real(kind=time_precision), parameter, public :: & - sec_per_day = 86400.0_time_precision, & ! Seconds in a day. - sec_per_hr = 3600.0_time_precision, & ! Seconds in an hour. - sec_per_min = 60.0_time_precision, & ! Seconds in a minute. - min_per_hr = 60.0_time_precision ! Minutes in an hour. + real(kind=core_rknd), parameter, public :: & + sec_per_day = 86400.0_core_rknd, & ! Seconds in a day. + sec_per_hr = 3600.0_core_rknd, & ! Seconds in an hour. + sec_per_min = 60.0_core_rknd, & ! Seconds in a minute. + min_per_hr = 60.0_core_rknd ! Minutes in an hour. real( kind = core_rknd ), parameter, public :: & g_per_kg = 1000.0_core_rknd ! Grams in a kilogram. @@ -298,10 +407,16 @@ module constants_clubb pascal_per_mb = 100.0_core_rknd ! Pascals per Millibar real( kind = core_rknd ), parameter, public :: & - cm3_per_m3 = 1.e6_core_rknd, & ! Cubic centimeters per cubic meter - micron_per_m = 1.e6_core_rknd, & ! Micrometers per meter - cm_per_m = 100._core_rknd, & ! Centimeters per meter - mm_per_m = 1000._core_rknd ! Millimeters per meter + cm3_per_m3 = 1.e6_core_rknd, & ! Cubic centimeters per cubic meter + micron_per_m = 1.e6_core_rknd, & ! Micrometers per meter + cm_per_m = 100._core_rknd, & ! Centimeters per meter + mm_per_m = 1000._core_rknd ! Millimeters per meter + + !----------------------------------------------------------------------------- + ! Unused variable + !----------------------------------------------------------------------------- + real( kind = core_rknd ), parameter, public :: & + unused_var = -999._core_rknd ! The standard value for unused variables !============================================================================= diff --git a/models/atm/cam/src/physics/clubb/corr_varnce_module.F90 b/models/atm/cam/src/physics/clubb/corr_varnce_module.F90 new file mode 100644 index 000000000000..b754f2343f41 --- /dev/null +++ b/models/atm/cam/src/physics/clubb/corr_varnce_module.F90 @@ -0,0 +1,960 @@ +!----------------------------------------------------------------------- +!$Id: corr_varnce_module.F90 7130 2014-07-29 23:29:54Z raut@uwm.edu $ +!------------------------------------------------------------------------------- +module corr_varnce_module + + use clubb_precision, only: & + core_rknd + + implicit none + + type sigma2_on_mu2_ratios_type + + ! In CLUBB standalone, these parameters can be set based on the value for a + ! given case in the CASE_model.in file. + + ! Prescribed parameters for hydrometeor in-precip values of + ! sigma_hm_i^2 / mu_hm_i^2 at grid levels that have some cloud. + ! They can be set based on values for a given case in the CASE_model.in file. + real( kind = core_rknd ) :: & + rr_sigma2_on_mu2_ip_cloud = 1.0_core_rknd, & ! sigma_rr_i^2/mu_rr_i^2 [-] + Nr_sigma2_on_mu2_ip_cloud = 1.0_core_rknd ! sigma_Nr_i^2/mu_Nr_i^2 [-] + + ! Prescribed parameters for hydrometeor in-precip values of + ! sigma_hm_i^2 / mu_hm_i^2 at grid levels that are entirely clear. + ! They can be set based on values for a given case in the CASE_model.in file. + real( kind = core_rknd ) :: & + rr_sigma2_on_mu2_ip_below = 1.0_core_rknd, & ! sigma_rr_i^2/mu_rr_i^2 [-] + Nr_sigma2_on_mu2_ip_below = 1.0_core_rknd ! sigma_Nr_i^2/mu_Nr_i^2 [-] + + ! Parameters added for ice microphysics and latin hypercube sampling + real( kind = core_rknd ) :: & + rs_sigma2_on_mu2_ip_cloud = 1.0_core_rknd, & ! sigma_rs_i^2/mu_rs_i^2 [-] + Ns_sigma2_on_mu2_ip_cloud = 1.0_core_rknd, & ! sigma_Ns_i^2/mu_Ns_i^2 [-] + ri_sigma2_on_mu2_ip_cloud = 1.0_core_rknd, & ! sigma_ri_i^2/mu_ri_i^2 [-] + Ni_sigma2_on_mu2_ip_cloud = 1.0_core_rknd, & ! sigma_Ni_i^2/mu_Ni_i^2 [-] + rg_sigma2_on_mu2_ip_cloud = 1.0_core_rknd, & ! sigma_rg_i^2/mu_rg_i^2 [-] + Ng_sigma2_on_mu2_ip_cloud = 1.0_core_rknd ! sigma_Ng_i^2/mu_Ng_i^2 [-] + + ! Parameters added for ice microphysics and latin hypercube sampling + real( kind = core_rknd ) :: & + rs_sigma2_on_mu2_ip_below = 1.0_core_rknd, & ! sigma_rs_i^2/mu_rs_i^2 [-] + Ns_sigma2_on_mu2_ip_below = 1.0_core_rknd, & ! sigma_Ns_i^2/mu_Ns_i^2 [-] + ri_sigma2_on_mu2_ip_below = 1.0_core_rknd, & ! sigma_ri_i^2/mu_ri_i^2 [-] + Ni_sigma2_on_mu2_ip_below = 1.0_core_rknd, & ! sigma_Ni_i^2/mu_Ni_i^2 [-] + rg_sigma2_on_mu2_ip_below = 1.0_core_rknd, & ! sigma_rg_i^2/mu_rg_i^2 [-] + Ng_sigma2_on_mu2_ip_below = 1.0_core_rknd ! sigma_Ng_i^2/mu_Ng_i^2 [-] + + ! Prescribed parameter for / ^2 at any grid level. + ! NOTE: In the case that l_const_Nc_in_cloud is true, Ncn is constant + ! throughout the entire grid box, so the parameter below should be + ! ignored. + real( kind = core_rknd ) :: & + Ncnp2_on_Ncnm2 = 1.0_core_rknd ! Prescribed ratio /^2 [-] + + end type sigma2_on_mu2_ratios_type + + ! Latin hypercube indices / Correlation array indices + integer, public :: & + iiPDF_chi = -1, & + iiPDF_eta = -1, & + iiPDF_w = -1 +!$omp threadprivate(iiPDF_chi, iiPDF_eta, iiPDF_w) + + integer, public :: & + iiPDF_rr = -1, & + iiPDF_rs = -1, & + iiPDF_ri = -1, & + iiPDF_rg = -1 +!$omp threadprivate(iiPDF_rr, iiPDF_rs, iiPDF_ri, iiPDF_rg) + + integer, public :: & + iiPDF_Nr = -1, & + iiPDF_Ns = -1, & + iiPDF_Ni = -1, & + iiPDF_Ng = -1, & + iiPDF_Ncn = -1 +!$omp threadprivate(iiPDF_Nr, iiPDF_Ns, iiPDF_Ni, iiPDF_Ng, iiPDF_Ncn) + + integer, parameter, public :: & + d_var_total = 12 ! Size of the default correlation arrays + + integer, public :: & + d_variables +!$omp threadprivate(d_variables) + + real( kind = core_rknd ), public, dimension(:), allocatable :: & + sigma2_on_mu2_ip_array_cloud, & + sigma2_on_mu2_ip_array_below + + real( kind = core_rknd ), public, dimension(:,:), allocatable :: & + corr_array_cloud, & + corr_array_below +!$omp threadprivate(sigma2_on_mu2_ip_array_cloud, sigma2_on_mu2_ip_array_below, & +!$omp corr_array_cloud, corr_array_below) + + real( kind = core_rknd ), public, dimension(:,:), allocatable :: & + corr_array_cloud_def, & + corr_array_below_def +!$omp threadprivate( corr_array_cloud_def, corr_array_below_def ) + + + private + + public :: sigma2_on_mu2_ratios_type, read_correlation_matrix, setup_pdf_indices, & + setup_corr_varnce_array, cleanup_corr_matrix_arrays, & + assert_corr_symmetric, print_corr_matrix + + private :: get_corr_var_index, return_pdf_index, def_corr_idx + + + contains + + !----------------------------------------------------------------------------- + subroutine init_default_corr_arrays( ) + + ! Description: + ! Initializes the default correlation arrays. + !--------------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + zero + + implicit none + + integer:: indx + + ! This "renaming" is used to shorten the matrix declarations below. + integer, parameter :: c = core_rknd + + ! ---- Begin Code ---- + + ! Allocate Arrays. + allocate( corr_array_cloud_def(d_var_total,d_var_total) ) + allocate( corr_array_below_def(d_var_total,d_var_total) ) + + ! Initialize all values to 0. + corr_array_cloud_def = zero + corr_array_below_def = zero + + ! Set the correlation of any variable with itself to 1. + do indx = 1, d_var_total, 1 + corr_array_cloud_def(indx,indx) = one + corr_array_below_def(indx,indx) = one + enddo + + ! Set up default correlation arrays. + ! The default correlation arrays used here are the correlation arrays used + ! for the ARM 97 case. Any changes should be made concurrently here and in + ! ../../input/case_setups/arm_97_corr_array_cloud.in (for "in-cloud") and + ! in ../../input/case_setups/arm_97_corr_array_cloud.in (for "below-cloud"). + corr_array_cloud_def = reshape( & + +(/1._c, -.6_c, .09_c , .09_c , .5_c , .5_c , .2_c , .2_c , .2_c , .2_c , .2_c, .2_c, &! chi + 0._c, 1._c , .027_c, .027_c, .0726_c, .0855_c, -.024_c, .084_c, .018_c, .012_c, 0._c, 0._c, &! eta + 0._c, 0._c , 1._c , .34_c , 0.2_c , 0.2_c , .1_c , .15_c , 0._c , 0._c , 0._c, 0._c, &! w + 0._c, 0._c , 0._c , 1._c , 0._c , 0._c , .39_c , .29_c , .14_c , .21_c , 0._c, 0._c, &! Ncn + 0._c, 0._c , 0._c , 0._c , 1._c , .7_c , 0._c , 0._c , .1_c , .1_c , .2_c, .2_c, &! rr + 0._c, 0._c , 0._c , 0._c , 0._c , 1._c , .1_c , .1_c , 0._c , 0._c , .2_c, .2_c, &! Nr + 0._c, 0._c , 0._c , 0._c , 0._c , 0._c , 1._c , .7_c , .5_c , .5_c , .3_c, .3_c, &! ri + 0._c, 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 1._c , .5_c , .5_c , .3_c, .3_c, &! Ni + 0._c, 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 1._c , .7_c , .4_c, .4_c, &! rs + 0._c, 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 1._c , .4_c, .4_c, &! Ns + 0._c, 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 1._c, .7_c, &! rg + 0._c, 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c, 1._c/),&!Ng + + shape(corr_array_cloud_def) ) +! chi eta w Ncn rr Nr ri Ni rs Ns rg Ng + + corr_array_cloud_def = transpose( corr_array_cloud_def ) + + + corr_array_below_def = reshape( & + +(/1._c, .3_c , .09_c , .09_c , .5_c , .5_c , .2_c , .2_c , .2_c , .2_c , .2_c, .2_c, &! chi + 0._c, 1._c , .027_c, .027_c, .0726_c, .0855_c, -.024_c, .084_c, .018_c, .012_c, 0._c, 0._c, &! eta + 0._c, 0._c , 1._c , .34_c , 0.2_c , 0.2_c , .1_c , .15_c , 0._c , 0._c , 0._c, 0._c, &! w + 0._c, 0._c , 0._c , 1._c , 0._c , 0._c , .39_c , .29_c , .14_c , .21_c , 0._c, 0._c, &! Ncn + 0._c, 0._c , 0._c , 0._c , 1._c , .7_c , 0._c , 0._c , .1_c , .1_c , .2_c, .2_c, &! rr + 0._c, 0._c , 0._c , 0._c , 0._c , 1._c , .1_c , .1_c , 0._c , 0._c , .2_c, .2_c, &! Nr + 0._c, 0._c , 0._c , 0._c , 0._c , 0._c , 1._c , .7_c , .5_c , .5_c , .3_c, .3_c, &! ri + 0._c, 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 1._c , .5_c , .5_c , .3_c, .3_c, &! Ni + 0._c, 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 1._c , .7_c , .4_c, .4_c, &! rs + 0._c, 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 1._c , .4_c, .4_c, &! Ns + 0._c, 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 1._c, .7_c, &! rg + 0._c, 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c, 1._c/),&!Ng + + shape(corr_array_below_def) ) +! chi eta w Ncn rr Nr ri Ni rs Ns rg Ng + + corr_array_below_def = transpose( corr_array_below_def ) + + + return + + end subroutine init_default_corr_arrays + + !----------------------------------------------------------------------------- + pure function def_corr_idx( iiPDF_x ) result(ii_def_corr) + + ! Description: + ! Map from a iiPDF index to the corresponding index in the default + ! correlation arrays. + !----------------------------------------------------------------------------- + + implicit none + + ! Constant Parameters + + ! Indices that represent the order in the default corr arrays + ! (chi (old s), eta (old t), w, Ncn, rr, Nr, ri, Ni, rs, Ns, rg, Ng) + integer, parameter :: & + ii_chi = 1, & + ii_eta = 2, & + ii_w = 3, & + ii_Ncn = 4, & + ii_rr = 5, & + ii_Nr = 6, & + ii_ri = 7, & + ii_Ni = 8, & + ii_rs = 9, & + ii_Ns = 10, & + ii_rg = 11, & + ii_Ng = 12 + + ! Input Variables + + integer, intent(in) :: iiPDF_x + + ! Return Variable + + integer :: ii_def_corr + + ! ---- Begin Code ---- + + ii_def_corr = -1 + + if (iiPDF_x == iiPDF_chi) then + ii_def_corr = ii_chi + + elseif (iiPDF_x == iiPDF_eta) then + ii_def_corr = ii_eta + + elseif (iiPDF_x == iiPDF_w) then + ii_def_corr = ii_w + + elseif (iiPDF_x == iiPDF_Ncn) then + ii_def_corr = ii_Ncn + + elseif (iiPDF_x == iiPDF_rr) then + ii_def_corr = ii_rr + + elseif (iiPDF_x == iiPDF_Nr) then + ii_def_corr = ii_Nr + + elseif (iiPDF_x == iiPDF_ri) then + ii_def_corr = ii_ri + + elseif (iiPDF_x == iiPDF_Ni) then + ii_def_corr = ii_Ni + + elseif (iiPDF_x == iiPDF_rs) then + ii_def_corr = ii_rs + + elseif (iiPDF_x == iiPDF_Ns) then + ii_def_corr = ii_Ns + + elseif (iiPDF_x == iiPDF_rg) then + ii_def_corr = ii_rg + + elseif (iiPDF_x == iiPDF_Ng) then + ii_def_corr = ii_Ng + + endif + end function def_corr_idx + + !----------------------------------------------------------------------------- + subroutine set_corr_arrays_to_default( ) + + ! Description: + ! If there are no corr_array.in files for the current case, default + ! correlations are used. + !----------------------------------------------------------------------------- + + use constants_clubb, only: & + zero, & + one + + implicit none + + ! Local Variables + integer :: i, j ! Loop iterators + + + ! ---- Begin Code ---- + + corr_array_cloud = zero + corr_array_below = zero + + do i = 1, d_variables + corr_array_cloud(i,i) = one + corr_array_below(i,i) = one + enddo + + do i = 1, d_variables-1 + do j = i+1, d_variables + if ( def_corr_idx(i) > def_corr_idx(j) ) then + corr_array_cloud(j, i) = corr_array_cloud_def(def_corr_idx(j), def_corr_idx(i)) + corr_array_below(j, i) = corr_array_below_def(def_corr_idx(j), def_corr_idx(i)) + else + corr_array_cloud(j, i) = corr_array_cloud_def(def_corr_idx(i), def_corr_idx(j)) + corr_array_below(j, i) = corr_array_below_def(def_corr_idx(i), def_corr_idx(j)) + endif + enddo + enddo + + end subroutine set_corr_arrays_to_default + + + !----------------------------------------------------------------------------- + subroutine read_correlation_matrix( iunit, input_file, d_variables, & + corr_array ) + + ! Description: + ! Reads a correlation variance array from a file and stores it in an array. + !----------------------------------------------------------------------------- + + use input_reader, only: & + one_dim_read_var, & ! Variable(s) + read_one_dim_file, deallocate_one_dim_vars, count_columns ! Procedure(s) + + use matrix_operations, only: set_lower_triangular_matrix ! Procedure(s) + + use constants_clubb, only: fstderr ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variable(s) + integer, intent(in) :: & + iunit, & ! File I/O unit + d_variables ! number of variables in the array + + character(len=*), intent(in) :: input_file ! Path to the file + + ! Input/Output Variable(s) + real( kind = core_rknd ), dimension(d_variables,d_variables), intent(inout) :: & + corr_array ! Correlation variance array + + ! Local Variable(s) + + type(one_dim_read_var), allocatable, dimension(:) :: & + retVars ! stores the variables read in from the corr_varnce.in file + + integer :: & + var_index1, & ! variable index + var_index2, & ! variable index + nCols, & ! the number of columns in the file + i, j ! Loop index + + + !--------------------------- BEGIN CODE ------------------------- + + nCols = count_columns( iunit, input_file ) + + ! Allocate all arrays based on d_variables + allocate( retVars(1:nCols) ) + + ! Initializing to zero means that correlations we don't have are assumed to be 0. + corr_array(:,:) = 0.0_core_rknd + + ! Set main diagonal to 1 + do i=1, d_variables + corr_array(i,i) = 1.0_core_rknd + end do + + ! Read the values from the specified file + call read_one_dim_file( iunit, nCols, input_file, retVars ) + + if( size( retVars(1)%values ) /= nCols ) then + write(fstderr, *) "Correlation matrix must have an equal number of rows and cols in file ", & + input_file + stop "Bad data in correlation file." + end if + + ! Start at 2 because the first index is always just 1.0 in the first row + ! and the rest of the rows are ignored + do i=2, nCols + var_index1 = get_corr_var_index( retVars(i)%name ) + if( var_index1 > -1 ) then + do j=1, (i-1) + var_index2 = get_corr_var_index( retVars(j)%name ) + if( var_index2 > -1 ) then + call set_lower_triangular_matrix & + ( d_variables, var_index1, var_index2, retVars(i)%values(j), & + corr_array ) + end if + end do + end if + end do + + call deallocate_one_dim_vars( nCols, retVars ) + + return + end subroutine read_correlation_matrix + + !-------------------------------------------------------------------------- + function get_corr_var_index( var_name ) result( i ) + + ! Definition: + ! Returns the index for a variable based on its name. + !-------------------------------------------------------------------------- + + implicit none + + character(len=*), intent(in) :: var_name ! The name of the variable + + ! Output variable + integer :: i + + !------------------ BEGIN CODE ----------------------------- + i = -1 + + select case( trim(var_name) ) + + case( "chi" ) + i = iiPDF_chi + + case( "eta" ) + i = iiPDF_eta + + case( "w" ) + i = iiPDF_w + + case( "Ncn" ) + i = iiPDF_Ncn + + case( "rr" ) + i = iiPDF_rr + + case( "Nr" ) + i = iiPDF_Nr + + case( "ri" ) + i = iiPDF_ri + + case( "Ni" ) + i = iiPDF_Ni + + case( "rs" ) + i = iiPDF_rs + + case( "Ns" ) + i = iiPDF_Ns + + case( "rg" ) + i = iiPDF_rg + + case( "Ng" ) + i = iiPDF_Ng + + end select + + return + + end function get_corr_var_index + + !----------------------------------------------------------------------- + subroutine setup_pdf_indices( hydromet_dim, iirrm, iiNrm, & + iirim, iiNim, iirsm, iiNsm, & + iirgm, iiNgm ) + + ! Description: + ! + ! Setup for the iiPDF indices. These indices are used to address chi(s), eta(t), w + ! and the hydrometeors in the mean/stdev/corr arrays + ! + ! References: + !----------------------------------------------------------------------- + + implicit none + + ! Input Variables + integer, intent(in) :: & + hydromet_dim ! Total number of hydrometeor species. + + integer, intent(in) :: & + iirrm, & ! Index of rain water mixing ratio + iiNrm, & ! Index of rain drop concentration + iirim, & ! Index of ice mixing ratio + iiNim, & ! Index of ice crystal concentration + iirsm, & ! Index of snow mixing ratio + iiNsm, & ! Index of snow flake concentration + iirgm, & ! Index of graupel mixing ratio + iiNgm ! Index of graupel concentration + + ! Local Variables + integer :: & + pdf_count, & ! Count number of PDF variables + i ! Hydrometeor loop index + + !----------------------------------------------------------------------- + + !----- Begin Code ----- + + iiPDF_chi = 1 ! Extended liquid water mixing ratio, chi + iiPDF_eta = 2 ! 'eta' orthogonal to 'chi' + iiPDF_w = 3 ! vertical velocity + iiPDF_Ncn = 4 ! Simplified cloud nuclei concentration or extended Nc. + + pdf_count = iiPDF_Ncn + + ! Loop over hydrometeors. + ! Hydrometeor indices in the PDF arrays should be in the same order as + ! found in the hydrometeor arrays. + if ( hydromet_dim > 0 ) then + + do i = 1, hydromet_dim, 1 + + if ( i == iirrm ) then + pdf_count = pdf_count + 1 + iiPDF_rr = pdf_count + endif + + if ( i == iiNrm ) then + pdf_count = pdf_count + 1 + iiPDF_Nr = pdf_count + endif + + if ( i == iirim ) then + pdf_count = pdf_count + 1 + iiPDF_ri = pdf_count + endif + + if ( i == iiNim ) then + pdf_count = pdf_count + 1 + iiPDF_Ni = pdf_count + endif + + if ( i == iirsm ) then + pdf_count = pdf_count + 1 + iiPDF_rs = pdf_count + endif + + if ( i == iiNsm ) then + pdf_count = pdf_count + 1 + iiPDF_Ns = pdf_count + endif + + if ( i == iirgm ) then + pdf_count = pdf_count + 1 + iiPDF_rg = pdf_count + endif + + if ( i == iiNgm ) then + pdf_count = pdf_count + 1 + iiPDF_Ng = pdf_count + endif + + enddo ! i = 1, hydromet_dim, 1 + + endif ! hydromet_dim > 0 + + d_variables = pdf_count + + + return + + end subroutine setup_pdf_indices + !----------------------------------------------------------------------- + + !------------------------------------------------------------------------------- + subroutine return_pdf_index( hydromet_index, pdf_count, pdf_index ) + + ! Description: + ! Set the Latin hypercube variable index if the hydrometeor exists + ! References: + ! None + !------------------------------------------------------------------------- + + implicit none + + ! Input Variables + integer, intent(in) :: & + hydromet_index + + ! Input/Output Variables + integer, intent(inout) :: & + pdf_count + + ! Output Variables + integer, intent(out) :: & + pdf_index + + ! ---- Begin Code ---- + + if ( hydromet_index > 0 ) then + pdf_count = pdf_count + 1 + pdf_index = pdf_count + else + pdf_index = -1 + end if + + return + end subroutine return_pdf_index + +!=============================================================================== + subroutine setup_corr_varnce_array( input_file_cloud, input_file_below, & + iunit, sigma2_on_mu2_ratios ) + +! Description: +! Setup an array with the x'^2/xm^2 variables on the diagonal and the other +! elements to be correlations between various variables. + +! References: +! None. +!------------------------------------------------------------------------------- + + use model_flags, only: & + l_fix_chi_eta_correlations, & ! Variable(s) + l_const_Nc_in_cloud + + use matrix_operations, only: mirror_lower_triangular_matrix ! Procedure + + use constants_clubb, only: & + fstderr, & ! Constant(s) + zero + + use error_code, only: & + clubb_debug, & ! Procedure(s) + clubb_at_least_debug_level + + implicit none + + ! External + intrinsic :: max, epsilon, trim + + character(len=*), intent(in) :: & + input_file_cloud, & ! Path to the in cloud correlation file + input_file_below ! Path to the out of cloud correlation file + + ! Input Variables + integer, intent(in) :: & + iunit ! The file unit + + type(sigma2_on_mu2_ratios_type), intent(in) :: & + sigma2_on_mu2_ratios ! Prescribed sigma^2 / mu^2 terms + + ! Local variables + logical :: l_warning, corr_file_exist + integer :: i + + ! ---- Begin Code ---- + + allocate( corr_array_cloud(d_variables,d_variables) ) + allocate( corr_array_below(d_variables,d_variables) ) + + allocate( sigma2_on_mu2_ip_array_cloud(d_variables) ) + allocate( sigma2_on_mu2_ip_array_below(d_variables) ) + + sigma2_on_mu2_ip_array_cloud(:) = zero + sigma2_on_mu2_ip_array_below(:) = zero + + ! corr_file_exist is true if the *_corr_array_cloud.in file exists + ! Note: It is assumed that if the *_corr_array_cloud.in file exists + ! then *_corr_array_below.in also exists + inquire( file = input_file_cloud, exist = corr_file_exist ) + + if ( corr_file_exist ) then + + call read_correlation_matrix( iunit, trim( input_file_cloud ), d_variables, & ! In + corr_array_cloud ) ! Out + + call read_correlation_matrix( iunit, trim( input_file_below ), d_variables, & ! In + corr_array_below ) ! Out + + else ! Read in default correlation matrices + + call clubb_debug( 1, "Warning: "//trim( input_file_cloud )//" was not found! " // & + "The default correlation arrays will be used." ) + + call init_default_corr_arrays( ) + + call set_corr_arrays_to_default( ) + + endif + + ! Mirror the correlation matrices + call mirror_lower_triangular_matrix( d_variables, corr_array_cloud ) + call mirror_lower_triangular_matrix( d_variables, corr_array_below ) + + ! Sanity check to avoid confusing non-convergence results. + if ( clubb_at_least_debug_level( 2 ) ) then + + if ( .not. l_fix_chi_eta_correlations .and. iiPDF_Ncn > 0 ) then + l_warning = .false. + do i = 1, d_variables + if ( ( corr_array_cloud(i,iiPDF_Ncn) /= zero .or. & + corr_array_below(i,iiPDF_Ncn) /= zero ) .and. & + i /= iiPDF_Ncn ) then + l_warning = .true. + end if + end do ! 1..d_variables + if ( l_warning ) then + write(fstderr,*) "Warning: the specified correlations for chi" & + // " (old s) and Ncn are non-zero." + write(fstderr,*) "The latin hypercube code will not converge to" & + // " the analytic solution using these settings." + end if + end if ! l_fix_chi_eta_correlations .and. iiPDF_Ncn > 0 + + end if ! clubb_at_least_debug_level( 2 ) + + if ( iiPDF_Ncn > 0 ) then + + if ( l_const_Nc_in_cloud ) then + ! Ncn is constant throughout every grid box! + sigma2_on_mu2_ip_array_cloud(iiPDF_Ncn) = zero + sigma2_on_mu2_ip_array_below(iiPDF_Ncn) = zero + else + sigma2_on_mu2_ip_array_cloud(iiPDF_Ncn) = sigma2_on_mu2_ratios%Ncnp2_on_Ncnm2 + sigma2_on_mu2_ip_array_below(iiPDF_Ncn) = sigma2_on_mu2_ratios%Ncnp2_on_Ncnm2 + end if + + end if + + if ( iiPDF_rr > 0 ) then + sigma2_on_mu2_ip_array_cloud(iiPDF_rr) = sigma2_on_mu2_ratios%rr_sigma2_on_mu2_ip_cloud + if ( iiPDF_Nr > 0 ) then + sigma2_on_mu2_ip_array_cloud(iiPDF_Nr) = sigma2_on_mu2_ratios%Nr_sigma2_on_mu2_ip_cloud + end if ! iiPDF_Nr > 0 + end if ! iiPDF_rr > 0 + + if ( iiPDF_rs > 0 ) then + sigma2_on_mu2_ip_array_cloud(iiPDF_rs) = sigma2_on_mu2_ratios%rs_sigma2_on_mu2_ip_cloud + + + if ( iiPDF_Ns > 0 ) then + sigma2_on_mu2_ip_array_cloud(iiPDF_Ns) = sigma2_on_mu2_ratios%Ns_sigma2_on_mu2_ip_cloud + + + end if ! iiPDF_Ns > 0 + end if ! iiPDF_rs > 0 + + if ( iiPDF_ri > 0 ) then + sigma2_on_mu2_ip_array_cloud(iiPDF_ri) = sigma2_on_mu2_ratios%ri_sigma2_on_mu2_ip_cloud + + + if ( iiPDF_Ni > 0 ) then + sigma2_on_mu2_ip_array_cloud(iiPDF_Ni) = sigma2_on_mu2_ratios%Ni_sigma2_on_mu2_ip_cloud + + end if ! iiPDF_Ni > 0 + end if ! iiPDF_ri > 0 + + ! Sampling for graupel (disabled) + if ( iiPDF_rg > 0 ) then + sigma2_on_mu2_ip_array_cloud(iiPDF_rg) = sigma2_on_mu2_ratios%rg_sigma2_on_mu2_ip_cloud + + + if ( iiPDF_Ng > 0 ) then + sigma2_on_mu2_ip_array_cloud(iiPDF_Ng) = sigma2_on_mu2_ratios%Ng_sigma2_on_mu2_ip_cloud + + + end if ! iiPDF_Ng > 0 + end if ! iiPDF_rg > 0 + + if ( iiPDF_rr > 0 ) then + sigma2_on_mu2_ip_array_below(iiPDF_rr) = sigma2_on_mu2_ratios%rr_sigma2_on_mu2_ip_below + + + + if ( iiPDF_Nr > 0 ) then + sigma2_on_mu2_ip_array_below(iiPDF_Nr) = sigma2_on_mu2_ratios%Nr_sigma2_on_mu2_ip_below + + + end if ! iiPDF_Nr > 0 + end if ! iiPDF_rr > 0 + + if ( iiPDF_rs > 0 ) then + sigma2_on_mu2_ip_array_below(iiPDF_rs) = sigma2_on_mu2_ratios%rs_sigma2_on_mu2_ip_below + + + if ( iiPDF_Ns > 0 ) then + sigma2_on_mu2_ip_array_below(iiPDF_Ns) = sigma2_on_mu2_ratios%Ns_sigma2_on_mu2_ip_below + + end if ! iiPDF_Ns > 0 + end if ! iiPDF_rs > 0 + + if ( iiPDF_ri > 0 ) then + sigma2_on_mu2_ip_array_below(iiPDF_ri) = sigma2_on_mu2_ratios%ri_sigma2_on_mu2_ip_below + + + if ( iiPDF_Ni > 0 ) then + sigma2_on_mu2_ip_array_below(iiPDF_Ni) = sigma2_on_mu2_ratios%Ni_sigma2_on_mu2_ip_below + end if ! iiPDF_Ni > 0 + + end if ! iiPDF_ri > 0 + + if ( iiPDF_rg > 0 ) then + sigma2_on_mu2_ip_array_below(iiPDF_rg) = sigma2_on_mu2_ratios%rg_sigma2_on_mu2_ip_below + + + if ( iiPDF_Ng > 0 ) then + sigma2_on_mu2_ip_array_below(iiPDF_Ng) = sigma2_on_mu2_ratios%Ng_sigma2_on_mu2_ip_below + + + end if ! iiPDF_Ng > 0 + end if ! iiPDF_rg > 0 + + return + end subroutine setup_corr_varnce_array + + !----------------------------------------------------------------------------- + subroutine cleanup_corr_matrix_arrays( ) + + ! Description: + ! De-allocate latin hypercube arrays + ! References: + ! None + !--------------------------------------------------------------------------- + implicit none + + ! External + intrinsic :: allocated + + ! ---- Begin Code ---- + + if ( allocated( corr_array_cloud ) ) then + deallocate( corr_array_cloud ) + end if + + if ( allocated( corr_array_below ) ) then + deallocate( corr_array_below ) + end if + + if ( allocated( sigma2_on_mu2_ip_array_cloud ) ) then + deallocate( sigma2_on_mu2_ip_array_cloud ) + end if + + if ( allocated( sigma2_on_mu2_ip_array_below ) ) then + deallocate( sigma2_on_mu2_ip_array_below ) + end if + + if ( allocated( corr_array_cloud_def ) ) then + deallocate( corr_array_cloud_def ) + end if + + if ( allocated( corr_array_below_def ) ) then + deallocate( corr_array_below_def ) + end if + + return + end subroutine cleanup_corr_matrix_arrays + + !----------------------------------------------------------------------------- + subroutine assert_corr_symmetric( corr_array, & ! intent(in) + d_variables ) ! intent(in) + + ! Description: + ! Asserts that corr_matrix(i,j) == corr_matrix(j,i) for all indeces + ! in the correlation array. If this is not the case, stops the program. + ! References: + ! None + !--------------------------------------------------------------------------- + + use constants_clubb, only: fstderr ! Constant(s) + + implicit none + + ! Input Variables + integer, intent(in) :: & + d_variables ! Number of variables in the correlation array + + real( kind = core_rknd ), dimension(d_variables, d_variables), & + intent(in) :: corr_array ! Correlation array to be checked + + ! Local Variables + + ! tolerance used for real precision testing + real( kind = core_rknd ), parameter :: tol = 1.0e-6_core_rknd + + integer :: n_row, n_col !indeces + + logical :: l_error !error found between the two arrays + + !----- Begin Code ----- + + l_error = .false. + + !Do the check + do n_col = 1, d_variables + do n_row = 1, d_variables + if (abs(corr_array(n_col, n_row) - corr_array(n_row, n_col)) > tol) then + l_error = .true. + end if + if (n_col == n_row .and. corr_array(n_col, n_row) /= 1.0_core_rknd) then + l_error = .true. + end if + end do + end do + + !Report if any errors are found + if (l_error) then + write(fstderr,*) "Error: Correlation array is non symmetric or formatted incorrectly." + write(fstderr,*) corr_array + stop + end if + + end subroutine assert_corr_symmetric + + !----------------------------------------------------------------------------- + subroutine print_corr_matrix( d_variables, & ! intent(in) + corr_array ) ! intent(in) + + ! Description: + ! Prints the correlation matrix to the console. + ! References: + ! None + !--------------------------------------------------------------------------- + + use clubb_precision, only: core_rknd + + implicit none + + ! Input Variables + integer, intent(in) :: & + d_variables ! Number of variables in the correlation array + + real( kind = core_rknd ), dimension(d_variables, d_variables), & + intent(in) :: corr_array ! Correlation array to be printed + + ! Local Variables + integer :: n, & ! Loop indeces + m, & + current_character_index ! keeps track of the position in the string + + character(LEN=72) :: current_line ! The current line to be printed + character(LEN=10) :: str_array_value + + !----- Begin Code ----- + + current_character_index = 0 + + do n = 1, d_variables + do m = 1, d_variables + write(str_array_value,'(F5.2)') corr_array(m,n) + current_line = current_line(1:current_character_index)//str_array_value + current_character_index = current_character_index + 6 + end do + write(*, *) current_line + current_line = "" + current_character_index = 0 + end do + + end subroutine print_corr_matrix + !----------------------------------------------------------------------------- + +end module corr_varnce_module diff --git a/models/atm/cam/src/physics/clubb/csr_matrix_class_3array.F90 b/models/atm/cam/src/physics/clubb/csr_matrix_module.F90 similarity index 96% rename from models/atm/cam/src/physics/clubb/csr_matrix_class_3array.F90 rename to models/atm/cam/src/physics/clubb/csr_matrix_module.F90 index 46b68fb5bc6a..63a4f8e41a34 100644 --- a/models/atm/cam/src/physics/clubb/csr_matrix_class_3array.F90 +++ b/models/atm/cam/src/physics/clubb/csr_matrix_module.F90 @@ -1,7 +1,7 @@ !----------------------------------------------------------------------- -! $Id: csr_matrix_class_3array.F90 5529 2011-11-29 19:49:15Z connork@uwm.edu $ +! $Id: csr_matrix_module.F90 7012 2014-07-07 14:18:31Z schemena@uwm.edu $ !=============================================================================== -module csr_matrix_class +module csr_matrix_module ! Description: ! This module contains some of the matrix description arrays required by @@ -66,7 +66,7 @@ module csr_matrix_class public :: csr_tridiag_ia, csr_tridiag_ja, & csr_banddiag5_135_ia, csr_banddiag5_135_ja, & csr_banddiag5_12345_ia, csr_banddiag5_12345_ja, & - initialize_csr_class, & + initialize_csr_matrix, & ia_size, tridiag_ja_size, band12345_ja_size, band135_ja_size, & csr_intlc_s3b_f5b_ia, csr_intlc_s3b_f5b_ja, & csr_intlc_trid_5b_ia, csr_intlc_trid_5b_ja, & @@ -109,20 +109,20 @@ module csr_matrix_class intlc_5d_5d_ja_size, & ! Size of the interlaced 5-diag+5-diag ja arrays. intlc_td_5d_ja_size ! Size of the interlaced tridiag+5-diag ja arrays. -!$omp threadprivate( csr_tridiag_ia, csr_tridiag_ja) -!$omp threadprivate(csr_banddiag5_135_ia, csr_banddiag5_135_ja) -!$omp threadprivate(csr_banddiag5_12345_ia, csr_banddiag5_12345_ja) -!$omp threadprivate(ia_size, tridiag_ja_size, band12345_ja_size, band135_ja_size) -!$omp threadprivate(csr_intlc_s3b_f5b_ia, csr_intlc_s3b_f5b_ja) -!$omp threadprivate(csr_intlc_trid_5b_ia, csr_intlc_trid_5b_ja) -!$omp threadprivate(csr_intlc_5b_5b_ia, csr_intlc_5b_5b_ja) -!$omp threadprivate(intlc_ia_size, intlc_s3d_5d_ja_size, intlc_5d_5d_ja_size) -!$omp threadprivate(intlc_td_5d_ja_size) +!$omp threadprivate (csr_tridiag_ia, csr_tridiag_ja) +!$omp threadprivate (csr_banddiag5_135_ia, csr_banddiag5_135_ja) +!$omp threadprivate (csr_banddiag5_12345_ia, csr_banddiag5_12345_ja) +!$omp threadprivate (ia_size, tridiag_ja_size, band12345_ja_size, band135_ja_size) +!$omp threadprivate (csr_intlc_s3b_f5b_ia, csr_intlc_s3b_f5b_ja) +!$omp threadprivate (csr_intlc_trid_5b_ia, csr_intlc_trid_5b_ja) +!$omp threadprivate (csr_intlc_5b_5b_ia, csr_intlc_5b_5b_ja) +!$omp threadprivate (intlc_ia_size, intlc_s3d_5d_ja_size, intlc_5d_5d_ja_size) +!$omp threadprivate (intlc_td_5d_ja_size) contains !============================================================================ - subroutine initialize_csr_class + subroutine initialize_csr_matrix ! Description: ! PARDISO matrix array initialization @@ -527,6 +527,6 @@ subroutine initialize_csr_class end do end if ! l_print_ia_ja - end subroutine initialize_csr_class + end subroutine initialize_csr_matrix -end module csr_matrix_class +end module csr_matrix_module diff --git a/models/atm/cam/src/physics/clubb/diagnose_correlations_module.F90 b/models/atm/cam/src/physics/clubb/diagnose_correlations_module.F90 new file mode 100644 index 000000000000..52189773ef23 --- /dev/null +++ b/models/atm/cam/src/physics/clubb/diagnose_correlations_module.F90 @@ -0,0 +1,1041 @@ +!----------------------------------------------------------------------- +! $Id: diagnose_correlations_module.F90 7309 2014-09-20 17:06:28Z betlej@uwm.edu $ +!=============================================================================== +module diagnose_correlations_module + + use clubb_precision, only: & + core_rknd + + implicit none + + public :: calc_mean, calc_varnce, calc_w_corr, & + calc_cholesky_corr_mtx_approx, & + cholesky_to_corr_mtx_approx, setup_corr_cholesky_mtx, & + diagnose_correlations + + + private :: diagnose_corr, rearrange_corr_array, & + corr_array_assertion_checks + + private ! Default scope + contains + +!----------------------------------------------------------------------- + subroutine diagnose_correlations( d_variables, corr_array_pre, & ! Intent(in) + corr_array ) ! Intent(out) + ! Description: + ! This subroutine diagnoses the correlation matrix in order to feed it + ! into SILHS microphysics. + + ! References: + ! Larson et al. (2011), J. of Geophysical Research, Vol. 116, D00T02 + ! (see CLUBB Trac ticket#514) + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + +! use corr_varnce_module, only: & +! iiPDF_w ! Variable(s) + + use constants_clubb, only: & + zero + + use model_flags, only: & + l_calc_w_corr ! Flag(s) + + implicit none + + intrinsic :: max, sqrt, transpose + + ! Input Variables + integer, intent(in) :: & + d_variables ! number of diagnosed correlations + + real( kind = core_rknd ), dimension(d_variables, d_variables), intent(in) :: & + corr_array_pre ! Prescribed correlations + + ! Output variables + real( kind = core_rknd ), dimension(d_variables, d_variables), intent(out) :: & + corr_array + + ! Local Variables + real( kind = core_rknd ), dimension(d_variables, d_variables) :: & + corr_array_pre_swapped, & + corr_array_swapped + + ! We actually don't need this right now + real( kind = core_rknd ), dimension(d_variables) :: & + sigma2_on_mu2_ip_array ! Ratios: sigma_x^2/mu_x^2 (ith PDF comp.) ip [-] + + integer :: i ! Loop iterator + + !-------------------- Begin code -------------------- + + ! Initialize sigma2_on_mu2_ip_array + do i = 1, d_variables + sigma2_on_mu2_ip_array(i) = zero + end do + + ! Swap the w-correlations to the first row for the prescribed correlations + call rearrange_corr_array( d_variables, corr_array_pre, & ! Intent(in) + corr_array_pre_swapped) ! Intent(inout) + + ! diagnose correlations + + if ( .not. l_calc_w_corr ) then + corr_array_swapped = corr_array_pre_swapped + endif + + call diagnose_corr( d_variables, sqrt(sigma2_on_mu2_ip_array), & + corr_array_pre_swapped, & + corr_array_swapped ) + + ! Swap rows back + call rearrange_corr_array( d_variables, corr_array_swapped, & ! Intent(in) + corr_array) ! Intent(out) + + end subroutine diagnose_correlations + + + !----------------------------------------------------------------------- + subroutine diagnose_corr( n_variables, sqrt_sigma2_on_mu2_ip, & ! intent(in) + corr_matrix_prescribed, & !intent(in) + corr_matrix_approx ) ! intent(inout) + + ! Description: + ! This subroutine diagnoses the correlation matrix for each timestep. + + ! References: + ! Larson et al. (2011), J. of Geophysical Research, Vol. 116, D00T02 + ! (see CLUBB Trac ticket#514) + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + +! use parameters_tunable, only: & +! alpha_corr ! Constant(s) + + use constants_clubb, only: & + max_mag_correlation + + implicit none + + intrinsic :: & + sqrt, abs, sign + + ! Input Variables + integer, intent(in) :: & + n_variables ! number of variables in the correlation matrix [-] + + real( kind = core_rknd ), dimension(n_variables), intent(in) :: & + sqrt_sigma2_on_mu2_ip ! sqrt of sigma_x^2/mu_x^2 (ith PDF comp.) ip [-] + + real( kind = core_rknd ), dimension(n_variables,n_variables), intent(in) :: & + corr_matrix_prescribed ! correlation matrix [-] + + ! Input/Output Variables + real( kind = core_rknd ), dimension(n_variables,n_variables), intent(inout) :: & + corr_matrix_approx ! correlation matrix [-] + + + ! Local Variables + integer :: i, j ! Loop iterator + + real( kind = core_rknd ) :: & + f_ij +! f_ij_o + + real( kind = core_rknd ), dimension(n_variables) :: & + s_1j ! s_1j = sqrt(1-c_1j^2) + + + !-------------------- Begin code -------------------- + + ! Remove compiler warnings about unused variables. + if ( .false. ) then + print *, "sqrt_sigma2_on_mu2_ip = ", sqrt_sigma2_on_mu2_ip + endif + + ! calculate all square roots + do i = 1, n_variables + + s_1j(i) = sqrt(1._core_rknd-corr_matrix_approx(i,1)**2) + + end do + + + ! Diagnose the missing correlations (upper triangle) + do j = 2, (n_variables-1) + do i = (j+1), n_variables + + ! formula (16) in the ref. paper (Larson et al. (2011)) + !f_ij = alpha_corr * sqrt_sigma2_on_mu2_ip(i) * sqrt_sigma2_on_mu2_ip(j) & + ! * sign(1.0_core_rknd,corr_matrix_approx(1,i)*corr_matrix_approx(1,j)) + + ! If the predicting c1i's are small then cij will be closer to the prescribed value. If + ! the c1i's are bigger, then cij will be closer to formular (15) from the ref. paper. See + ! clubb:ticket:514:comment:61 for details. + !f_ij = (1-abs(corr_matrix_approx(1,i)*corr_matrix_approx(1,j)))*corr_matrix_prescribed(i,j) & + ! + abs(corr_matrix_approx(1,i)*corr_matrix_approx(1,j))*f_ij_o + + f_ij = corr_matrix_prescribed(i,j) + + ! make sure -1 < f_ij < 1 + if ( f_ij < -max_mag_correlation ) then + + f_ij = -max_mag_correlation + + else if ( f_ij > max_mag_correlation ) then + + f_ij = max_mag_correlation + + end if + + + ! formula (15) in the ref. paper (Larson et al. (2011)) + corr_matrix_approx(i,j) = corr_matrix_approx(i,1) * corr_matrix_approx(j,1) & + + f_ij * s_1j(i) * s_1j(j) + + end do ! do j + end do ! do i + + end subroutine diagnose_corr + + + !----------------------------------------------------------------------- + subroutine approx_w_corr( nz, d_variables, pdf_params, & ! Intent(in) + rrm, Nrm, Ncnm, & + stdev_w, sigma_rr_1, & + sigma_Nr_1, sigma_Ncn_1, & + corr_array) ! Intent(out) + ! Description: + ! Approximate the correlations of w with the hydrometeors. + + ! References: + ! clubb:ticket:514 + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use pdf_parameter_module, only: & + pdf_parameter ! Type + + use constants_clubb, only: & + one, & ! Constant(s) + rr_tol, & + Nr_tol, & + Ncn_tol, & + w_tol, & ! [m/s] + chi_tol ! [kg/kg] + + implicit none + + ! Input Variables + integer, intent(in) :: & + d_variables, & ! Number of diagnosed correlations + nz ! Number of model vertical grid levels + + type(pdf_parameter), dimension(nz), intent(in) :: & + pdf_params ! PDF parameters [units vary] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + rrm, & ! Mean rain water mixing ratio, < r_r > [kg/kg] + Nrm, & ! Mean rain drop concentration, < N_r > [num/kg] + Ncnm, & ! Mean cloud nuclei conc., < N_cn > [num/kg] + stdev_w ! Standard deviation of w [m/s] + + real( kind = core_rknd ), intent(in) :: & + sigma_Ncn_1, & ! Standard deviation of Ncn (1st PDF component) [num/kg] + sigma_Nr_1, & ! Standard deviation of Nr (2nd PDF component) [num/kg] + sigma_rr_1 ! Standard dev. of ln rr (1st PDF comp.) ip [ln(kg/kg)] + + ! Output Variables + real( kind = core_rknd ), dimension(d_variables, d_variables, nz), intent(out) :: & + corr_array + + ! Local Variables + real( kind = core_rknd ), dimension(nz) :: & + corr_chi_w, & ! Correlation between w and chi(s_mellor) (both components) [-] + corr_wrr, & ! Correlation between w and rr (both components) [-] + corr_wNr, & ! Correlation between w and Nr (both components) [-] + corr_wNcn ! Correlation between w and Ncn (both components) [-] + + real( kind = core_rknd ), dimension(nz) :: & + wpchip_zt, & ! Covariance of chi and w on the zt-grid [(m/s)(kg/kg)] + wprrp_zt, & ! Covariance of r_r and w on the zt-grid [(m/s)(kg/kg)] + wpNrp_zt, & ! Covariance of N_r and w on the zt-grid [(m/s)(#/kg)] + wpNcnp_zt ! Covariance of N_cn and w on the zt-grid [(m/s)(#/kg)] + + real( kind = core_rknd ) :: & + chi_m, & ! Mean of chi (s_mellor) [kg/kg] + stdev_chi ! Standard deviation of chi (s_mellor) [kg/kg] + + integer :: k ! vertical loop iterator + + ! ----- Begin Code ----- + + call approx_w_covar( nz, pdf_params, rrm, Nrm, Ncnm, & ! Intent(in) + wpchip_zt, wprrp_zt, wpNrp_zt, wpNcnp_zt ) ! Intent(out) + + do k = 1, nz + + chi_m & + = calc_mean( pdf_params(k)%mixt_frac, pdf_params(k)%chi_1, & + pdf_params(k)%chi_2 ) + + stdev_chi & + = sqrt( pdf_params(k)%mixt_frac & + * ( ( pdf_params(k)%chi_1 - chi_m )**2 & + + pdf_params(k)%stdev_chi_1**2 ) & + + ( one - pdf_params(k)%mixt_frac ) & + * ( ( pdf_params(k)%chi_2 - chi_m )**2 & + + pdf_params(k)%stdev_chi_2**2 ) & + ) + + corr_chi_w(k) & + = calc_w_corr( wpchip_zt(k), stdev_w(k), stdev_chi, & + w_tol, chi_tol ) + + corr_wrr(k) & + = calc_w_corr( wprrp_zt(k), stdev_w(k), sigma_rr_1, w_tol, rr_tol ) + + corr_wNr(k) & + = calc_w_corr( wpNrp_zt(k), stdev_w(k), sigma_Nr_1, w_tol, Nr_tol ) + + corr_wNcn(k) & + = calc_w_corr( wpNcnp_zt(k), stdev_w(k), sigma_Ncn_1, w_tol, Ncn_tol ) + + enddo + + call set_w_corr( nz, d_variables, & ! Intent(in) + corr_chi_w, corr_wrr, corr_wNr, corr_wNcn, & + corr_array ) ! Intent(inout) + + end subroutine approx_w_corr + + + !----------------------------------------------------------------------- + subroutine approx_w_covar( nz, pdf_params, rrm, Nrm, Ncnm, & ! Intent(in) + wpchip_zt, wprrp_zt, wpNrp_zt, wpNcnp_zt ) ! Intent(out) + ! Description: + ! Approximate the covariances of w with the hydrometeors using Eddy + ! diffusivity. + + ! References: + ! clubb:ticket:514 + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use grid_class, only: & + gr, & ! Variable(s) + zm2zt, & ! Procedure(s) + zt2zm + + use pdf_parameter_module, only: & + pdf_parameter ! Type + + use parameters_tunable, only: & + c_K_hm ! Variable(s) + + use constants_clubb, only: & + one ! Constant(s) + + use advance_windm_edsclrm_module, only: & + xpwp_fnc ! Procedure(s) + + use variables_diagnostic_module, only: & + Kh_zm ! Variable(s) + + implicit none + + ! Input Variables + integer, intent(in) :: & + nz ! Number of model vertical grid levels + + type(pdf_parameter), dimension(nz), intent(in) :: & + pdf_params ! PDF parameters [units vary] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + rrm, & ! Mean rain water mixing ratio, < r_r > [kg/kg] + Nrm, & ! Mean rain drop concentration, < N_r > [num/kg] + Ncnm ! Mean cloud nuclei concentration, < N_cn > [num/kg] + + ! Output Variables + real( kind = core_rknd ), dimension(nz), intent(out) :: & + wpchip_zt, & ! Covariance of chi(s) and w on the zt-grid [(m/s)(kg/kg)] + wprrp_zt, & ! Covariance of r_r and w on the zt-grid [(m/s)(kg/kg)] + wpNrp_zt, & ! Covariance of N_r and w on the zt-grid [(m/s)(#/kg)] + wpNcnp_zt ! Covariance of N_cn and w on the zt-grid [(m/s)(#/kg)] + + ! Local Variables + real( kind = core_rknd ), dimension(nz) :: & + wpchip_zm, & ! Covariance of chi(s) and w on the zm-grid [(m/s)(kg/kg)] + wprrp_zm, & ! Covariance of r_r and w on the zm-grid [(m/s)(kg/kg)] + wpNrp_zm, & ! Covariance of N_r and w on the zm-grid [(m/s)(#/kg)] + wpNcnp_zm ! Covariance of N_cn and w on the zm-grid [(m/s)(#/kg)] + + integer :: k ! vertical loop iterator + + ! ----- Begin Code ----- + + ! calculate the covariances of w with the hydrometeors + do k = 1, nz + wpchip_zm(k) = pdf_params(k)%mixt_frac & + * ( one - pdf_params(k)%mixt_frac ) & + * ( pdf_params(k)%chi_1 - pdf_params(k)%chi_2 ) & + * ( pdf_params(k)%w_1 - pdf_params(k)%w_2 ) + enddo + +! same for wpNrp +! wprrp_zm(1:nz-1) & +! = xpwp_fnc( -c_K_hm * Kh_zm(1:nz-1), & +! rrm(1:nz-1) / max( precip_frac(1:nz-1), eps ), & +! rrm(2:nz) / max( precip_frac(2:nz), eps ), & +! gr%invrs_dzm(1:nz-1) ) + + wprrp_zm(1:nz-1) & + = xpwp_fnc( -c_K_hm * Kh_zm(1:nz-1), & + rrm(1:nz-1), rrm(2:nz), & + gr%invrs_dzm(1:nz-1) ) + + wpNrp_zm(1:nz-1) & + = xpwp_fnc( -c_K_hm * Kh_zm(1:nz-1), & + Nrm(1:nz-1), Nrm(2:nz), & + gr%invrs_dzm(1:nz-1) ) + + wpNcnp_zm(1:nz-1) = xpwp_fnc( -c_K_hm * Kh_zm(1:nz-1), Ncnm(1:nz-1), & + Ncnm(2:nz), gr%invrs_dzm(1:nz-1) ) + + ! Boundary conditions; We are assuming constant flux at the top. + wprrp_zm(nz) = wprrp_zm(nz-1) + wpNrp_zm(nz) = wpNrp_zm(nz-1) + wpNcnp_zm(nz) = wpNcnp_zm(nz-1) + + ! interpolate back to zt-grid + wpchip_zt = zm2zt(wpchip_zm) + wprrp_zt = zm2zt(wprrp_zm) + wpNrp_zt = zm2zt(wpNrp_zm) + wpNcnp_zt = zm2zt(wpNcnp_zm) + + end subroutine approx_w_covar + + !----------------------------------------------------------------------- + function calc_w_corr( wpxp, stdev_w, stdev_x, w_tol, x_tol ) + ! Description: + ! Compute the correlations of w with the hydrometeors. + + ! References: + ! clubb:ticket:514 + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use constants_clubb, only: & + max_mag_correlation + + implicit none + + intrinsic :: max + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + stdev_w, & ! standard deviation of w [m/s] + stdev_x, & ! standard deviation of x [units vary] + wpxp, & ! Covariances of w with the hydrometeors [units vary] + w_tol, & ! tolerance for w [m/s] + x_tol ! tolerance for x [units vary] + + real( kind = core_rknd ) :: & + calc_w_corr + + ! --- Begin Code --- + + calc_w_corr = wpxp / ( max(stdev_x, x_tol) * max(stdev_w, w_tol) ) + + ! Make sure the correlation is in [-1,1] + if ( calc_w_corr < -max_mag_correlation ) then + + calc_w_corr = -max_mag_correlation + + else if ( calc_w_corr > max_mag_correlation ) then + + calc_w_corr = max_mag_correlation + + end if + + end function calc_w_corr + + + !----------------------------------------------------------------------- + function calc_varnce( mixt_frac, x1, x2, xm, x1p2, x2p2 ) + + ! Description: + ! Calculate the variance xp2 from the components x1, x2. + + ! References: + ! Larson et al. (2011), J. of Geophysical Research, Vol. 116, D00T02, + ! page 3535 + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + mixt_frac, & ! mixing ratio [-] + x1, & ! first component of the double gaussian [units vary] + x2, & ! second component of the double gaussian [units vary] + xm, & ! mean of x [units vary] + x1p2, & ! variance of the first component [units vary] + x2p2 ! variance of the second component [units vary] + + ! Return Variable + real( kind = core_rknd ) :: & + calc_varnce ! variance of x (both components) [units vary] + + ! --- Begin Code --- + + calc_varnce & + = mixt_frac * ( ( x1 - xm )**2 + x1p2 ) & + + ( 1.0_core_rknd - mixt_frac ) * ( ( x2 - xm )**2 + x2p2 ) + + return + end function calc_varnce + + !----------------------------------------------------------------------- + function calc_mean( mixt_frac, x1, x2 ) + + ! Description: + ! Calculate the mean xm from the components x1, x2. + + ! References: + ! Larson et al. (2011), J. of Geophysical Research, Vol. 116, D00T02, + ! page 3535 + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + mixt_frac, & ! mixing ratio [-] + x1, & ! first component of the double gaussian [units vary] + x2 ! second component of the double gaussian [units vary] + + ! Return Variable + real( kind = core_rknd ) :: & + calc_mean ! mean of x (both components) [units vary] + + ! --- Begin Code --- + + calc_mean = mixt_frac * x1 + (1.0_core_rknd - mixt_frac) * x2 + + return + end function calc_mean + + + !----------------------------------------------------------------------- + subroutine calc_cholesky_corr_mtx_approx & + ( n_variables, corr_matrix, & ! intent(in) + corr_cholesky_mtx, corr_mtx_approx ) ! intent(out) + + ! Description: + ! This subroutine calculates the transposed correlation cholesky matrix + ! from the correlation matrix + ! + ! References: + ! 1 Larson et al. (2011), J. of Geophysical Research, Vol. 116, D00T02 + ! 2 CLUBB Trac ticket#514 + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use constants_clubb, only: & + zero ! Variable(s) + + implicit none + + ! Input Variables + integer, intent(in) :: & + n_variables ! number of variables in the correlation matrix [-] + + real( kind = core_rknd ), dimension(n_variables,n_variables), intent(in) :: & + corr_matrix ! correlation matrix [-] + + ! Output Variables + + ! correlation cholesky matrix transposed L', C = LL'; see reference 1 formula 10 + real( kind = core_rknd ), dimension(n_variables,n_variables), intent(out) :: & + corr_cholesky_mtx, & ! Transposed correlation cholesky matrix [-] + corr_mtx_approx ! Approximated correlation matrix (C = LL') [-] + + ! Local Variables + integer :: i, j ! Loop iterators + + ! Swapped means that the w-correlations are swapped to the first row + real( kind = core_rknd ), dimension(n_variables,n_variables) :: & + corr_cholesky_mtx_swap, & ! Swapped correlation cholesky matrix [-] + corr_mtx_approx_swap, & ! Swapped correlation matrix (approx.) [-] + corr_mtx_swap ! Swapped correlation matrix [-] + + !-------------------- Begin code -------------------- + + call rearrange_corr_array( n_variables, corr_matrix, & ! Intent(in) + corr_mtx_swap ) ! Intent(inout) + + call setup_corr_cholesky_mtx( n_variables, corr_mtx_swap, & ! intent(in) + corr_cholesky_mtx_swap ) ! intent(out) + + call rearrange_corr_array( n_variables, corr_cholesky_mtx_swap, & ! Intent(in) + corr_cholesky_mtx ) ! Intent(inout) + + call cholesky_to_corr_mtx_approx( n_variables, corr_cholesky_mtx_swap, & ! intent(in) + corr_mtx_approx_swap ) ! intent(out) + + call rearrange_corr_array( n_variables, corr_mtx_approx_swap, & ! Intent(in) + corr_mtx_approx ) ! Intent(inout) + + call corr_array_assertion_checks( n_variables, corr_mtx_approx ) + + ! Set lower triangle to zero for conformity + do i = 2, n_variables + do j = 1, i-1 + corr_mtx_approx(j,i) = zero + end do + end do + + return + + end subroutine calc_cholesky_corr_mtx_approx + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + subroutine setup_corr_cholesky_mtx( n_variables, corr_matrix, & ! intent(in) + corr_cholesky_mtx_t ) ! intent(out) + + ! Description: + ! This subroutine calculates the transposed correlation cholesky matrix + ! from the correlation matrix + ! + ! References: + ! 1 Larson et al. (2011), J. of Geophysical Research, Vol. 116, D00T02 + ! 2 CLUBB Trac ticket#514 + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use constants_clubb, only: & + zero, & ! Variable(s) + one + + implicit none + + intrinsic :: sqrt + + ! Input Variables + integer, intent(in) :: & + n_variables ! number of variables in the correlation matrix [-] + + real( kind = core_rknd ), dimension(n_variables,n_variables), intent(in) :: & + corr_matrix ! correlation matrix [-] + + ! Output Variables + + ! correlation cholesky matrix transposed L', C = LL'; see reference 1 formula 10 + real( kind = core_rknd ), dimension(n_variables,n_variables), intent(out) :: & + corr_cholesky_mtx_t ! transposed correlation cholesky matrix [-] + + ! Local Variables + integer :: i, j, k ! Loop iterators + + real( kind = core_rknd ), dimension(n_variables, n_variables) :: & + s ! s(i,j) = sqrt(1-c(i,j)^2); see ref 1 + + !-------------------- Begin code -------------------- + + ! calculate all necessary square roots + do i = 1, n_variables-1 + do j = i+1, n_variables + + s(j,i) = sqrt(1._core_rknd - corr_matrix(j,i)**2) + + end do + end do + + !!! calculate transposed correlation cholesky matrix; ref 1 formula 10 + + ! initialize matrix to zero + do i = 1, n_variables + do j = 1, n_variables + + corr_cholesky_mtx_t(j,i) = zero + + end do + end do + + ! initialize upper triangle and diagonal to one + do i = 1, n_variables + do j = i, n_variables + + corr_cholesky_mtx_t(j,i) = one + + end do + end do + + ! set diagonal elements + do j = 2, n_variables + do i = 1, j-1 + + corr_cholesky_mtx_t(j,j) = corr_cholesky_mtx_t(j,j)*s(j,i) + ! print *, "s(", j, ",", i, ") = ", s(j,i) + + end do + end do + + ! set first row + do j = 2, n_variables + + corr_cholesky_mtx_t(j,1) = corr_matrix(j,1) + + end do + + ! set upper triangle + do i = 2, n_variables-1 + do j = i+1, n_variables + do k = 1, i-1 + + corr_cholesky_mtx_t(j,i) = corr_cholesky_mtx_t(j,i)*s(j,k) + + end do + + corr_cholesky_mtx_t(j,i) = corr_cholesky_mtx_t(j,i)*corr_matrix(j,i) + + end do + end do + + return + + end subroutine setup_corr_cholesky_mtx + !----------------------------------------------------------------------- + + + !----------------------------------------------------------------------- + subroutine cholesky_to_corr_mtx_approx( n_variables, corr_cholesky_mtx_t, & ! intent(in) + corr_matrix_approx ) ! intent(out) + + ! Description: + ! This subroutine approximates the correlation matrix from the correlation + ! cholesky matrix + ! + ! References: + ! 1 Larson et al. (2011), J. of Geophysical Research, Vol. 116, D00T02 + ! 2 CLUBB Trac ticket#514 + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + intrinsic :: matmul, transpose + + ! Input Variables + integer, intent(in) :: & + n_variables ! number of variables in the correlation matrix [-] + + real( kind = core_rknd ), dimension(n_variables,n_variables), intent(in) :: & + corr_cholesky_mtx_t ! transposed correlation cholesky matrix [-] + + ! Output Variables + real( kind = core_rknd ), dimension(n_variables,n_variables), intent(out) :: & + corr_matrix_approx ! correlation matrix [-] + + !-------------------- Begin code -------------------- + + ! approximate the correlation matrix; see ref 1 formula (8) + corr_matrix_approx = matmul(corr_cholesky_mtx_t, transpose(corr_cholesky_mtx_t)) + + return + + end subroutine cholesky_to_corr_mtx_approx + !----------------------------------------------------------------------- + + + !----------------------------------------------------------------------- + subroutine corr_array_assertion_checks( n_variables, corr_array ) + + ! Description: + ! This subroutine does the assertion checks for the corr_array. + + ! References: + ! + ! + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use constants_clubb, only: & + max_mag_correlation ! Variable(s) + + use constants_clubb, only: & + one ! Variable(s) + + use error_code, only: & + clubb_at_least_debug_level ! Procedure(s) + + implicit none + + ! Input Variables + integer, intent(in) :: & + n_variables ! number of variables in the correlation matrix [-] + + real( kind = core_rknd ), dimension(n_variables,n_variables), intent(in) :: & + corr_array ! correlation matrix [-] + + ! Local Variables + integer :: i, j ! Loop iterator + + real( kind = core_rknd ), parameter :: & + tol = 1.e-6_core_rknd ! Maximum acceptable tolerance for the difference of the diagonal + ! elements of corr_array to one + + !-------------------- Begin code -------------------- + + if ( clubb_at_least_debug_level( 1 ) ) then + + do i = 1, n_variables - 1 + do j = i+1, n_variables + + ! Check if upper and lower triangle values are within the correlation boundaries + if ( ( corr_array(i,j) < -max_mag_correlation ) & + .or. ( corr_array(i,j) > max_mag_correlation ) & + .or. ( corr_array(j,i) < -max_mag_correlation ) & + .or. ( corr_array(j,i) > max_mag_correlation ) ) & + then + + stop "Error: A value in the correlation matrix is out of range." + + endif + + enddo + enddo + + endif + + if ( clubb_at_least_debug_level( 2 ) ) then + + do i = 1, n_variables + ! Check if the diagonal elements are one (up to a tolerance) + if ( ( corr_array(i,i) > one + tol ) .or. (corr_array(i,i) < one - tol ) ) then + + stop "Error: Diagonal element(s) of the correlation matrix are unequal to one." + + endif + enddo + + endif + + return + + end subroutine corr_array_assertion_checks + + +!----------------------------------------------------------------------- + subroutine rearrange_corr_array( d_variables, corr_array, & ! Intent(in) + corr_array_swapped) ! Intent(out) + ! Description: + ! This subroutine swaps the w-correlations to the first row if the input + ! matrix is in the same order as the *_corr_array_cloud.in files. It swaps + ! the rows back to the order of the *_corr_array_cloud.in files if the + ! input matrix is already swapped (first row w-correlations). + ! + ! References: + ! + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use corr_varnce_module, only: & + iiPDF_w ! Variable(s) + + implicit none + + intrinsic :: max, sqrt, transpose + + ! Input Variables + integer, intent(in) :: & + d_variables ! number of diagnosed correlations + + real( kind = core_rknd ), dimension(d_variables, d_variables), intent(in) :: & + corr_array ! Correlation matrix + + ! Output variables + real( kind = core_rknd ), dimension(d_variables, d_variables), intent(out) :: & + corr_array_swapped ! Swapped correlation matrix + + ! Local Variables + real( kind = core_rknd ), dimension(d_variables) :: & + swap_array + + !-------------------- Begin code -------------------- + + + ! Swap the w-correlations to the first row for the prescribed correlations + corr_array_swapped = corr_array + swap_array = corr_array_swapped (:,1) + corr_array_swapped(1:iiPDF_w, 1) = corr_array_swapped(iiPDF_w, iiPDF_w:1:-1) + corr_array_swapped((iiPDF_w+1):d_variables, 1) = corr_array_swapped( & + (iiPDF_w+1):d_variables, iiPDF_w) + corr_array_swapped(iiPDF_w, 1:iiPDF_w) = swap_array(iiPDF_w:1:-1) + corr_array_swapped((iiPDF_w+1):d_variables, iiPDF_w) = swap_array((iiPDF_w+1):d_variables) + + return + + end subroutine rearrange_corr_array + !----------------------------------------------------------------------- + + + !----------------------------------------------------------------------- + subroutine set_w_corr( nz, d_variables, & ! Intent(in) + corr_chi_w, corr_wrr, corr_wNr, corr_wNcn, & + corr_array ) ! Intent(inout) + + ! Description: + ! Set the first row of corr_array to the according w-correlations. + + ! References: + ! clubb:ticket:514 + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use corr_varnce_module, only: & + iiPDF_w, & ! Variable(s) + iiPDF_chi, & + iiPDF_rr, & + iiPDF_Nr, & + iiPDF_Ncn + + implicit none + + ! Input Variables + integer, intent(in) :: & + nz, & ! Number of model vertical grid levels + d_variables ! Number of Variables to be diagnosed + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + corr_chi_w, & ! Correlation between chi (s) & w (both components) [-] + corr_wrr, & ! Correlation between rr & w (both components) [-] + corr_wNr, & ! Correlation between Nr & w (both components) [-] + corr_wNcn ! Correlation between Ncn & w (both components) [-] + + ! Input/Output Variables + real( kind = core_rknd ), dimension(d_variables, d_variables, nz), & + intent(inout) :: & + corr_array + + ! ----- Begin Code ----- + + corr_array(iiPDF_w, iiPDF_chi, :) = corr_chi_w + corr_array(iiPDF_w, iiPDF_rr, :) = corr_wrr + corr_array(iiPDF_w, iiPDF_Nr, :) = corr_wNr + corr_array(iiPDF_w, iiPDF_Ncn, :) = corr_wNcn + + end subroutine set_w_corr + + !============================================================================= + subroutine unpack_correlations( d_variables, corr_array, & ! Intent(in) + corr_w_chi, corr_wrr, corr_wNr, corr_wNcn, & + corr_chi_eta, corr_chi_rr, corr_chi_Nr, corr_chi_Ncn, & + corr_eta_rr, corr_eta_Nr, corr_eta_Ncn, corr_rrNr ) + + ! Description: + + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use corr_varnce_module, only: & + iiPDF_w, & ! Variable(s) + iiPDF_chi, & + iiPDF_eta, & + iiPDF_rr, & + iiPDF_Nr, & + iiPDF_Ncn + + implicit none + + intrinsic :: max, sqrt, transpose + + ! Input Variables + integer, intent(in) :: & + d_variables ! number of diagnosed correlations + + real( kind = core_rknd ), dimension(d_variables, d_variables), intent(in) :: & + corr_array ! Prescribed correlations + + ! Output variables + real( kind = core_rknd ), intent(out) :: & + corr_w_chi, & ! Correlation between w and chi(s) (1st PDF component) [-] + corr_wrr, & ! Correlation between w and rr (1st PDF component) ip [-] + corr_wNr, & ! Correlation between w and Nr (1st PDF component) ip [-] + corr_wNcn, & ! Correlation between w and Ncn (1st PDF component) [-] + corr_chi_eta, & ! Correlation between chi(s) and eta(t) (1st PDF component) [-] + corr_chi_rr, & ! Correlation between chi(s) and rr (1st PDF component) ip [-] + corr_chi_Nr, & ! Correlation between chi(s) and Nr (1st PDF component) ip [-] + corr_chi_Ncn, & ! Correlation between chi(s) and Ncn (1st PDF component) [-] + corr_eta_rr, & ! Correlation between eta(t) and rr (1st PDF component) ip [-] + corr_eta_Nr, & ! Correlation between eta(t) and Nr (1st PDF component) ip [-] + corr_eta_Ncn, & ! Correlation between (t) and Ncn (1st PDF component) [-] + corr_rrNr ! Correlation between rr & Nr (1st PDF component) ip [-] + + ! ---- Begin Code ---- + +! corr_w_chi = corr_array(iiPDF_w, iiPDF_chi) +! corr_wrr = corr_array(iiPDF_w, iiPDF_rr) +! corr_wNr = corr_array(iiPDF_w, iiPDF_Nr) +! corr_wNcn = corr_array(iiPDF_w, iiPDF_Ncn) +! corr_chi_eta = corr_array(iiPDF_chi, iiPDF_eta) +! corr_chi_rr = corr_array(iiPDF_chi, iiPDF_rr) +! corr_chi_Nr = corr_array(iiPDF_chi, iiPDF_Nr) +! corr_chi_Ncn = corr_array(iiPDF_chi, iiPDF_Ncn) +! corr_eta_rr = corr_array(iiPDF_eta, iiPDF_rr) +! corr_eta_Nr = corr_array(iiPDF_eta, iiPDF_Nr) +! corr_eta_Ncn = corr_array(iiPDF_eta, iiPDF_Ncn) +! corr_rrNr = corr_array(iiPDF_rr, iiPDF_Nr) + + corr_w_chi = corr_array(iiPDF_chi, iiPDF_w) + corr_wrr = corr_array(iiPDF_rr, iiPDF_w) + corr_wNr = corr_array(iiPDF_Nr, iiPDF_w) + corr_wNcn = corr_array(iiPDF_Ncn, iiPDF_w) + corr_chi_eta = corr_array(iiPDF_eta, iiPDF_chi) + corr_chi_rr = corr_array(iiPDF_rr, iiPDF_chi) + corr_chi_Nr = corr_array(iiPDF_Nr, iiPDF_chi) + corr_chi_Ncn = corr_array(iiPDF_Ncn, iiPDF_chi) + corr_eta_rr = corr_array(iiPDF_rr, iiPDF_eta) + corr_eta_Nr = corr_array(iiPDF_Nr, iiPDF_eta) + corr_eta_Ncn = corr_array(iiPDF_Ncn, iiPDF_eta) + corr_rrNr = corr_array(iiPDF_rr, iiPDF_Nr) + + end subroutine unpack_correlations + +!=============================================================================== + +end module diagnose_correlations_module diff --git a/models/atm/cam/src/physics/clubb/diffusion.F90 b/models/atm/cam/src/physics/clubb/diffusion.F90 index 8ffe5157f476..e0caa3c412d6 100644 --- a/models/atm/cam/src/physics/clubb/diffusion.F90 +++ b/models/atm/cam/src/physics/clubb/diffusion.F90 @@ -1,4 +1,5 @@ -! $Id: diffusion.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +!----------------------------------------------------------------------- +! $Id: diffusion.F90 6849 2014-04-22 21:52:30Z charlass@uwm.edu $ !=============================================================================== module diffusion diff --git a/models/atm/cam/src/physics/clubb/endian.F90 b/models/atm/cam/src/physics/clubb/endian.F90 index 14388f09ccf5..299786cf378e 100644 --- a/models/atm/cam/src/physics/clubb/endian.F90 +++ b/models/atm/cam/src/physics/clubb/endian.F90 @@ -1,6 +1,5 @@ !---------------------------------------------------------------------- -! $Id: endian.F90 3784 2009-07-14 21:29:16Z dschanen@uwm.edu $ - +! $Id: endian.F90 6849 2014-04-22 21:52:30Z charlass@uwm.edu $ !---------------------------------------------------------------------- module endian diff --git a/models/atm/cam/src/physics/clubb/error_code.F90 b/models/atm/cam/src/physics/clubb/error_code.F90 index a31dc3c587d2..0e2989338708 100644 --- a/models/atm/cam/src/physics/clubb/error_code.F90 +++ b/models/atm/cam/src/physics/clubb/error_code.F90 @@ -1,5 +1,5 @@ !------------------------------------------------------------------------------- -! $Id: error_code.F90 5324 2011-07-27 21:05:45Z dschanen@uwm.edu $ +! $Id: error_code.F90 7184 2014-08-11 15:23:43Z betlej@uwm.edu $ !------------------------------------------------------------------------------- module error_code @@ -26,14 +26,7 @@ module error_code private ! Default Scope public :: & - clubb_no_error, & - clubb_var_less_than_zero, & - clubb_var_equals_NaN, & - clubb_singular_matrix, & - clubb_bad_lapack_arg, & - clubb_rtm_level_not_found, & - clubb_var_out_of_bounds, & - reportError, & + report_error, & fatal_error, & lapack_error, & clubb_at_least_debug_level, & @@ -48,19 +41,20 @@ module error_code !$omp threadprivate(clubb_debug_level) ! Error Code Values - integer, parameter :: & + integer, parameter, public :: & clubb_no_error = 0, & clubb_var_less_than_zero = 1, & clubb_var_equals_NaN = 2, & clubb_singular_matrix = 3, & clubb_bad_lapack_arg = 4, & clubb_rtm_level_not_found = 5, & - clubb_var_out_of_bounds = 6 + clubb_var_out_of_bounds = 6, & + clubb_var_out_of_range = 7 contains !------------------------------------------------------------------------------- - subroutine reportError( err_code ) + subroutine report_error( err_code ) ! ! Description: ! Reports meaning of error code to console. @@ -92,8 +86,7 @@ subroutine reportError( err_code ) write(fstderr,*) "Variable in CLUBB is NaN." case ( clubb_bad_lapack_arg ) - write(fstderr,*) & - "Argument used in LAPACK procedure is invalid." + write(fstderr,*) "Argument passed to a LAPACK procedure is invalid." case ( clubb_rtm_level_not_found ) write(fstderr,*) "rtm level not found" @@ -101,13 +94,16 @@ subroutine reportError( err_code ) case ( clubb_var_out_of_bounds ) write(fstderr,*) "Input variable is out of bounds." + case ( clubb_var_out_of_range ) + write(fstderr,*) "A CLUBB variable had a value outside the valid range." + case default write(fstderr,*) "Unknown error: ", err_code end select return - end subroutine reportError + end subroutine report_error !------------------------------------------------------------------------------- elemental function lapack_error( err_code ) ! diff --git a/models/atm/cam/src/physics/clubb/extrapolation.F90 b/models/atm/cam/src/physics/clubb/extrapolation.F90 deleted file mode 100644 index 36e144c70016..000000000000 --- a/models/atm/cam/src/physics/clubb/extrapolation.F90 +++ /dev/null @@ -1,90 +0,0 @@ -!$Id: extrapolation.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -module extrapolation - - implicit none - - public :: lin_ext_zm_bottom, lin_ext_zt_bottom - - private ! Default scope - - contains -!=============================================================================== - pure function lin_ext_zm_bottom( var_zmp2, var_zmp1, & - zmp2, zmp1, zm ) & - result( var_zm ) - - ! Description: - ! This function computes the value of a momentum-level variable at a bottom - ! grid level by using a linear extension of the values of the variable at - ! the two levels immediately above the level where the result value is - ! needed. - - ! References: - ! None - !----------------------------------------------------------------------- - - use clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - - ! Input Variables - real( kind = core_rknd ), intent(in) :: & - var_zmp2, & ! Momentum level variable at level (k+2) [units vary] - var_zmp1, & ! Momentum level variable at level (k+1) [units vary] - zmp2, & ! Altitude at momentum level (k+2) [m] - zmp1, & ! Altitude at momentum level (k+1) [m] - zm ! Altitude at momentum level (k) [m] - - ! Return Variable - real( kind = core_rknd ) :: var_zm ! Momentum level variable at level (k) [units vary] - - ! ---- Begin Code ----- - - var_zm = ( ( var_zmp2 - var_zmp1 ) / ( zmp2 - zmp1 ) ) & - * ( zm - zmp1 ) + var_zmp1 - - return - end function lin_ext_zm_bottom - -!=============================================================================== - pure function lin_ext_zt_bottom( var_ztp2, var_ztp1, & - ztp2, ztp1, zt ) & - result( var_zt ) - - ! Description: - ! This function computes the value of a thermodynamic-level variable at a - ! bottom grid level by using a linear extension of the values of the - ! variable at the two levels immediately above the level where the result - ! value is needed. - ! - ! References: - ! None - !----------------------------------------------------------------------- - - use clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! Input Variables - real( kind = core_rknd ), intent(in) :: & - var_ztp2, & ! Thermodynamic level variable at level (k+2) [units vary] - var_ztp1, & ! Thermodynamic level variable at level (k+1) [units vary] - ztp2, & ! Altitude at thermodynamic level (k+2) [m] - ztp1, & ! Altitude at thermodynamic level (k+1) [m] - zt ! Altitude at thermodynamic level (k) [m] - - ! Return Variable - real( kind = core_rknd ) :: var_zt ! Thermodynamic level variable at level (k) [units vary] - - ! ---- Begin Code ----- - - var_zt = ( ( var_ztp2 - var_ztp1 ) / ( ztp2 - ztp1 ) ) & - * ( zt - ztp1 ) + var_ztp1 - - return - end function lin_ext_zt_bottom - -end module extrapolation diff --git a/models/atm/cam/src/physics/clubb/fill_holes.F90 b/models/atm/cam/src/physics/clubb/fill_holes.F90 index 70753ba562cb..1e053e19e9ad 100644 --- a/models/atm/cam/src/physics/clubb/fill_holes.F90 +++ b/models/atm/cam/src/physics/clubb/fill_holes.F90 @@ -1,13 +1,18 @@ !----------------------------------------------------------------------- -! $Id: fill_holes.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +! $Id: fill_holes.F90 7315 2014-09-30 20:49:54Z schemena@uwm.edu $ !=============================================================================== module fill_holes implicit none public :: fill_holes_driver, & + fill_holes_vertical, & + hole_filling_hm_one_lev, & + fill_holes_hydromet, & + fill_holes_wv, & vertical_avg, & - vertical_integral + vertical_integral, & + setup_stats_indices private :: fill_holes_multiplicative @@ -16,9 +21,9 @@ module fill_holes contains !============================================================================= - subroutine fill_holes_driver( num_pts, threshold, field_grid, & - rho_ds, rho_ds_zm, & - field ) + subroutine fill_holes_vertical( num_draw_pts, threshold, field_grid, & + rho_ds, rho_ds_zm, & + field ) ! Description: ! This subroutine clips values of 'field' that are below 'threshold' as much @@ -46,7 +51,7 @@ subroutine fill_holes_driver( num_pts, threshold, field_grid, & ! Input variables integer, intent(in) :: & - num_pts ! The number of points on either side of the hole; + num_draw_pts ! The number of points on either side of the hole; ! Mass is drawn from these points to fill the hole. [] real( kind = core_rknd ), intent(in) :: & @@ -100,10 +105,10 @@ subroutine fill_holes_driver( num_pts, threshold, field_grid, & ! variables). For momentum level variables only, the hole-filling scheme ! should not alter the set value of 'field' at the upper boundary ! level (k=gr%nz). - do k = 2+num_pts, upper_hf_level-num_pts, 1 + do k = 2+num_draw_pts, upper_hf_level-num_draw_pts, 1 - begin_idx = k - num_pts - end_idx = k + num_pts + begin_idx = k - num_draw_pts + end_idx = k + num_draw_pts if ( any( field( begin_idx:end_idx ) < threshold ) ) then @@ -156,7 +161,7 @@ subroutine fill_holes_driver( num_pts, threshold, field_grid, & return - end subroutine fill_holes_driver + end subroutine fill_holes_vertical !============================================================================= subroutine fill_holes_multiplicative & @@ -484,4 +489,891 @@ end function vertical_integral !=============================================================================== + subroutine hole_filling_hm_one_lev( num_hm_fill, hm_one_lev, & ! Intent(in) + hm_one_lev_filled ) ! Intent(out) + + ! Description: + ! Fills holes between same-phase (i.e. either liquid or frozen) hydrometeors for + ! one height level. + ! + ! Warning: Do not input hydrometeors of different phases, e.g. liquid and frozen. + ! Otherwise heat will not be conserved. + ! + ! References: + ! + ! None + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Variable(s) + zero + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use error_code, only: & + clubb_at_least_debug_level ! Procedure(s) + + implicit none + + ! Input Variables + integer, intent(in) :: num_hm_fill ! number of hydrometeors involved + + real(kind = core_rknd), dimension(num_hm_fill), intent(in) :: hm_one_lev + + ! Output Variables + real(kind = core_rknd), dimension(num_hm_fill), intent(out) :: hm_one_lev_filled + + ! Local Variables + integer :: num_neg_hm ! number of holes + + real(kind = core_rknd) :: & + total_hole, & ! Size of the hole ( missing mass, less than 0 ) + total_mass ! Total mass to fill the hole + ! total mass of water substance = total_mass + total_hole + + integer :: i ! loop iterator + + !----------------------------------------------------------------------- + + !----- Begin Code ----- + + ! Initialization + hm_one_lev_filled = 0._core_rknd + total_hole = 0._core_rknd + total_mass = 0._core_rknd + num_neg_hm = 0 + + ! Determine the total size of the hole and the number of neg. hydrometeors + ! and the total mass of hole filling material + do i=1, num_hm_fill +! print *, "hm_one_lev(",i,") = ", hm_one_lev(i) + if ( hm_one_lev(i) < zero ) then + total_hole = total_hole + hm_one_lev(i) ! less than zero + num_neg_hm = num_neg_hm + 1 + else + total_mass = total_mass + hm_one_lev(i) + endif + + enddo + +! print *, "total_hole = ", total_hole +! print *, "total_mass = ", total_mass +! print *, "num_neg_hm = ", num_neg_hm + + ! There is no water substance at all to fill the hole + if ( total_mass == zero ) then + + if ( clubb_at_least_debug_level(2) ) then + print *, "Warning: One level hole filling was not successful! total_mass = 0" + endif + + hm_one_lev_filled = hm_one_lev + + return + endif + + ! Fill the holes and adjust the remaining quantities: + ! hm_filled(i) = 0, if hm(i) < 0 + ! or + ! hm_filled(i) = (1 + total_hole/total_mass)*hm(i), if hm(i) > 0 + do i=1, num_hm_fill + + ! if there is not enough material, fill the holes partially with all the material available + if ( abs(total_hole) > total_mass ) then + + if ( clubb_at_least_debug_level(2) ) then + print *, "Warning: One level hole was not able to fill holes completely!" // & + " The holes were filled partially. |total_hole| > total_mass" + endif + + hm_one_lev_filled(i) = min(hm_one_lev(i), zero) * ( one + total_mass / total_hole ) + + else ! fill holes completely + hm_one_lev_filled(i) = max(hm_one_lev(i), zero) * ( one + total_hole / total_mass ) + + endif + + enddo + + ! Assertion checks (water substance conservation, non-negativity) + if ( clubb_at_least_debug_level( 2 ) ) then + + if ( sum( hm_one_lev ) /= sum(hm_one_lev_filled) ) then + print *, "Warning: Hole filling was not conservative!" + endif + + if ( any( hm_one_lev_filled < zero ) ) then + print *, "Warning: Hole filling failed! A hole could not be filled." + endif + + endif + + return + + end subroutine hole_filling_hm_one_lev + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + subroutine fill_holes_hydromet( nz, hydromet_dim, hydromet, & ! Intent(in) + hydromet_filled ) ! Intent(out) + + ! Description: + ! Fills holes between same-phase hydrometeors(i.e. for frozen hydrometeors). + ! The hole filling conserves water substance between all same-phase (frozen or liquid) + ! hydrometeors at each height level. + ! + ! Attention: The hole filling for the liquid phase hydrometeors is not yet implemented + ! + ! Attention: l_frozen_hm and l_mix_rat_hm need to be set up before this subroutine is called! + ! + ! References: + ! + ! None + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd + + use array_index, only: & + l_frozen_hm, & ! Variable(s) + l_mix_rat_hm + + use constants_clubb, only: & + zero + + implicit none + + ! Input Variables + integer, intent(in) :: hydromet_dim, nz + + real( kind = core_rknd ), dimension(nz,hydromet_dim), intent(in) :: & + hydromet + + ! Output Variables + real( kind = core_rknd ), dimension(nz,hydromet_dim), intent(out) :: & + hydromet_filled + + ! Local Variables + integer :: i,j ! Loop iterators + + integer :: num_frozen_hm ! Number of frozen hydrometeor mixing ratios + + real( kind = core_rknd ), dimension(:,:), allocatable :: & + hydromet_frozen, & ! Frozen hydrometeor mixing ratios + hydromet_frozen_filled ! Frozen hydrometeor mixing ratios after hole filling + + !----------------------------------------------------------------------- + + !----- Begin Code ----- + + ! Determine the number of frozen hydrometeor mixing ratios + num_frozen_hm = 0 + do i=1,hydromet_dim + if ( l_frozen_hm(i) .and. l_mix_rat_hm(i) ) then + num_frozen_hm = num_frozen_hm + 1 + endif + enddo + + ! Allocation + allocate( hydromet_frozen(nz,num_frozen_hm) ) + allocate( hydromet_frozen_filled(nz,num_frozen_hm) ) + + ! Determine frozen hydrometeor mixing ratios + j = 1 + do i = 1,hydromet_dim + if ( l_frozen_hm(i) .and. l_mix_rat_hm(i) ) then + hydromet_frozen(:,j) = hydromet(:,i) + j = j+1 + endif + enddo + + ! Fill holes for the frozen hydrometeors + do i=1,nz + if ( any( hydromet_frozen(i,:) < zero ) ) then + call hole_filling_hm_one_lev( num_frozen_hm, hydromet_frozen(i,:), & ! Intent(in) + hydromet_frozen_filled(i,:) ) ! Intent(out) + else + hydromet_frozen_filled(i,:) = hydromet_frozen(i,:) + endif + enddo + + ! Setup the filled hydromet array + j = 1 + do i=1, hydromet_dim + if ( l_frozen_hm(i) .and. l_mix_rat_hm(i) ) then + hydromet_filled(:,i) = hydromet_frozen_filled(:,j) + j = j+1 + else + hydromet_filled(:,i) = hydromet(:,i) + endif + enddo + + !!! Here we could do the same hole filling for all the liquid phase hydrometeors + + return + end subroutine fill_holes_hydromet + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + subroutine fill_holes_wv( nz, dt, exner, hydromet_name, & ! Intent(in) + rvm_mc, thlm_mc, hydromet )! Intent(inout) + + ! Description: + ! Fills holes using the cloud water mixing ratio from the current height level. + ! + ! References: + ! + ! None + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd + + use constants_clubb, only: & + zero_threshold, & + Lv, & + Ls, & + Cp + + implicit none + + ! Input Variables + integer, intent(in) :: nz + + real( kind = core_rknd ), intent(in) :: & + dt ! Timestep [s] + + character(len=10), intent(in) :: hydromet_name + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + exner ! Exner function [-] + + ! Input/Output Variables + real( kind = core_rknd ), dimension(nz), intent(inout) :: & + hydromet, & ! Hydrometeor array [units vary] + rvm_mc, & + thlm_mc + + ! Local Variables + integer :: k ! Loop iterator + + real( kind = core_rknd ) :: rvm_clip_tndcy + !----------------------------------------------------------------------- + + !----- Begin Code ----- + + do k = 2, nz, 1 + + if ( hydromet(k) < zero_threshold ) then + + ! Set rvm_clip_tndcy to the time tendency applied to vapor and removed + ! from the hydrometeor. + rvm_clip_tndcy = hydromet(k) / dt + + ! Adjust the tendency rvm_mc accordingly + rvm_mc(k) = rvm_mc(k) + rvm_clip_tndcy + + ! Adjust the tendency of thlm_mc according to whether the + ! effect is an evaporation or sublimation tendency. + select case ( trim( hydromet_name ) ) + case( "rrm" ) + thlm_mc(k) = thlm_mc(k) - rvm_clip_tndcy * ( Lv / ( Cp*exner(k) ) ) + case( "rim", "rsm", "rgm" ) + thlm_mc(k) = thlm_mc(k) - rvm_clip_tndcy * ( Ls / ( Cp*exner(k) ) ) + case default + stop "Fatal error in microphys_driver" + end select + + ! Set the mixing ratio to 0 + hydromet(k) = zero_threshold + + endif ! hydromet(k,i) < 0 + + enddo ! k = 2..gr%nz + + return + end subroutine fill_holes_wv + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + subroutine fill_holes_driver( nz, dt, hydromet_dim, & ! Intent(in) + l_fill_holes_hm, & ! Intent(in) + rho_ds_zm, rho_ds_zt, exner, & ! Intent(in) + thlm_mc, rvm_mc, hydromet ) ! Intent(inout) + + ! Description: + ! Fills holes between same-phase hydrometeors(i.e. for frozen hydrometeors). + ! The hole filling conserves water substance between all same-phase (frozen or liquid) + ! hydrometeors at each height level. + ! + ! Attention: The hole filling for the liquid phase hydrometeors is not yet implemented + ! + ! Attention: l_frozen_hm and l_mix_rat_hm need to be set up before this subroutine is called! + ! + ! References: + ! + ! None + !----------------------------------------------------------------------- + + use grid_class, only: & + gr ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use constants_clubb, only: & + pi, & + four_thirds, & + one, & + zero, & + zero_threshold, & + Lv, & + Ls, & + Cp, & + rho_lw, & + rho_ice, & + fstderr + + use array_index, only: & + hydromet_list, & ! Names of the hydrometeor species + hydromet_tol + + use array_index, only: & + l_mix_rat_hm, & ! Variable(s) + l_frozen_hm + + use index_mapping, only: & + Nx2rx_hm_idx, & ! Procedure(s) + mvr_hm_max + + use error_code, only: & + clubb_at_least_debug_level ! Procedure(s) + + use stats_type_utilities, only: & + stat_begin_update, & ! Subroutines + stat_end_update + + use stats_variables, only: & + stats_zt, & ! Variables + l_stats_samp + + implicit none + + intrinsic :: trim + + ! Input Variables + integer, intent(in) :: hydromet_dim, nz + + logical, intent(in) :: l_fill_holes_hm + + real( kind = core_rknd ), intent(in) :: & + dt ! Timestep [s] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] + rho_ds_zt ! Dry, static density on thermo. levels [kg/m^3] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + exner ! Exner function [-] + + ! Input/Output Variables + real( kind = core_rknd ), dimension(nz, hydromet_dim), intent(inout) :: & + hydromet + + real( kind = core_rknd ), dimension(nz), intent(inout) :: & + rvm_mc, & ! Microphysics contributions to vapor water [kg/kg/s] + thlm_mc ! Microphysics contributions to liquid potential temp. [K/s] + + ! Local Variables + integer :: i, k ! Loop iterators + + real( kind = core_rknd ), dimension(nz, hydromet_dim) :: & + hydromet_filled ! Frozen hydrometeor mixing ratios after hole filling + + character( len = 10 ) :: hydromet_name + + real( kind = core_rknd ) :: & + Nxm_min_coef, & ! Coefficient for min. mean value of a concentration [1/kg] + max_velocity ! Maximum sedimentation velocity [m/s] + + integer :: ixrm_hf, ixrm_wvhf, ixrm_cl, & + ixrm_bt, ixrm_mc + + logical :: l_hole_fill = .true. + + !----------------------------------------------------------------------- + + !----- Begin Code ----- + + ! Start stats output for the _hf variables (changes in the hydromet array + ! due to fill_holes_hydromet and fill_holes_vertical) + if ( l_stats_samp ) then + + do i = 1, hydromet_dim + + ! Set up the stats indices for hydrometeor at index i + call setup_stats_indices( i, & ! Intent(in) + ixrm_bt, ixrm_hf, ixrm_wvhf, & ! Intent(inout) + ixrm_cl, ixrm_mc, & ! Intent(inout) + max_velocity ) ! Intent(inout) + + call stat_begin_update( ixrm_hf, hydromet(:,i) & + / dt, stats_zt ) + + enddo ! i = 1, hydromet_dim + + endif ! l_stats_samp + + ! If we're dealing with negative hydrometeors, we first try to fill the + ! holes proportionally from other same-phase hydrometeors at each height + ! level. + if ( any( hydromet < zero_threshold ) .and. l_fill_holes_hm ) then + + call fill_holes_hydromet( nz, hydromet_dim, hydromet, & ! Intent(in) + hydromet_filled ) ! Intent(out) + + hydromet = hydromet_filled + + endif ! any( hydromet < zero ) .and. l_fill_holes_hm + + hydromet_filled = zero + + do i = 1, hydromet_dim + + ! Set up the stats indices for hydrometeor at index i + call setup_stats_indices( i, & ! Intent(in) + ixrm_bt, ixrm_hf, ixrm_wvhf, & ! Intent(inout) + ixrm_cl, ixrm_mc, & ! Intent(inout) + max_velocity ) ! Intent(inout) + + ! Print warning message if any hydrometeor species has a value < 0. + if ( clubb_at_least_debug_level( 1 ) ) then + if ( any( hydromet(:,i) < zero_threshold ) ) then + + hydromet_name = hydromet_list(i) + + do k = 1, nz + if ( hydromet(k,i) < zero_threshold ) then + write(fstderr,*) trim( hydromet_name ) //" < ", & + zero_threshold, & + " in fill_holes_driver at k= ", k + endif ! hydromet(k,i) < 0 + enddo ! k = 1, nz + endif ! hydromet(:,i) < 0 + endif ! clubb_at_least_debug_level( 1 ) + + + ! Store the previous value of the hydrometeor for the effect of the + ! hole-filling scheme. +! if ( l_stats_samp ) then +! call stat_begin_update( ixrm_hf, hydromet(:,i) & +! / dt, stats_zt ) +! endif + + ! If we're dealing with a mixing ratio and hole filling is enabled, + ! then we apply the hole filling algorithm + if ( any( hydromet(:,i) < zero_threshold ) ) then + + if ( hydromet_name(1:1) == "r" .and. l_hole_fill ) then + + ! Apply the hole filling algorithm + call fill_holes_vertical( 2, zero_threshold, "zt", & + rho_ds_zt, rho_ds_zm, & + hydromet(:,i) ) + + endif ! Variable is a mixing ratio and l_hole_fill is true + + endif ! hydromet(:,i) < 0 + + ! Enter the new value of the hydrometeor for the effect of the + ! hole-filling scheme. + if ( l_stats_samp ) then + call stat_end_update( ixrm_hf, hydromet(:,i) & + / dt, stats_zt ) + endif + + ! Store the previous value of the hydrometeor for the effect of the water + ! vapor hole-filling scheme. + if ( l_stats_samp ) then + call stat_begin_update( ixrm_wvhf, hydromet(:,i) & + / dt, stats_zt ) + endif + + if ( any( hydromet(:,i) < zero_threshold ) ) then + + if ( hydromet_name(1:1) == "r" .and. l_hole_fill ) then + + ! If the hole filling algorithm failed, then we attempt to fill + ! the missing mass with water vapor mixing ratio. + ! We noticed this is needed for ASEX A209, particularly if Latin + ! hypercube sampling is enabled. -dschanen 11 Nov 2010 + call fill_holes_wv( nz, dt, exner, hydromet_name, & ! Intent(in) + rvm_mc, thlm_mc, hydromet(:,i) ) ! Intent(out) + + endif ! Variable is a mixing ratio and l_hole_fill is true + + endif ! hydromet(:,i) < 0 + + ! Enter the new value of the hydrometeor for the effect of the water vapor + ! hole-filling scheme. + if ( l_stats_samp ) then + call stat_end_update( ixrm_wvhf, hydromet(:,i) & + / dt, stats_zt ) + endif + + ! Clipping for hydrometeor mixing ratios. + if ( l_mix_rat_hm(i) ) then + + ! Store the previous value of the hydrometeor for the effect of + ! clipping. + if ( l_stats_samp ) then + call stat_begin_update( ixrm_cl, & + hydromet(:,i) & + / dt, & + stats_zt ) + endif + + if ( any( hydromet(:,i) < zero_threshold ) ) then + + ! Clip any remaining negative values of precipitating hydrometeor + ! mixing ratios to 0. + where ( hydromet(:,i) < zero_threshold ) + hydromet(:,i) = zero_threshold + end where + + endif ! hydromet(:,i) < 0 + + ! Eliminate very small values of mean precipitating hydrometeor mixing + ! ratios by setting them to 0. + do k = 2, gr%nz, 1 + + if ( hydromet(k,i) <= hydromet_tol(i) ) then + + rvm_mc(k) & + = rvm_mc(k) & + + ( hydromet(k,i) / dt ) + + if ( .not. l_frozen_hm(i) ) then + + ! Rain water mixing ratio + + thlm_mc(k) & + = thlm_mc(k) & + - ( Lv / ( Cp * exner(k) ) ) & + * ( hydromet(k,i) / dt ) + + else ! Frozen hydrometeor mixing ratio + + thlm_mc(k) & + = thlm_mc(k) & + - ( Ls / ( Cp * exner(k) ) ) & + * ( hydromet(k,i) / dt ) + + endif ! l_frozen_hm(i) + + hydromet(k,i) = zero + + endif ! hydromet(k,i) <= hydromet_tol(i) + + enddo ! k = 2, gr%nz, 1 + + + ! Enter the new value of the hydrometeor for the effect of clipping. + if ( l_stats_samp ) then + call stat_end_update( ixrm_cl, hydromet(:,i) & + / dt, stats_zt ) + endif + + endif ! l_mix_rat_hm(i) + + enddo ! i = 1, hydromet_dim, 1 + + ! Clipping for hydrometeor concentrations. + do i = 1, hydromet_dim + + if ( .not. l_mix_rat_hm(i) ) then + + ! Set up the stats indices for hydrometeor at index i + call setup_stats_indices( i, & ! Intent(in) + ixrm_bt, ixrm_hf, ixrm_wvhf, & ! Intent(inout) + ixrm_cl, ixrm_mc, & ! Intent(inout) + max_velocity ) ! Intent(inout) + + ! Store the previous value of the hydrometeor for the effect of + ! clipping. + if ( l_stats_samp ) then + call stat_begin_update( ixrm_cl, & + hydromet(:,i) & + / dt, & + stats_zt ) + endif + + if ( .not. l_frozen_hm(i) ) then + + ! Clipping for mean rain drop concentration, . + ! When mean rain water mixing ratio, , is found at a grid level, + ! mean rain drop concentration must be at least a minimum value so + ! that average rain drop mean volume radius stays within an upper + ! bound. Otherwise, mean rain drop concentration is 0. + + ! The minimum mean rain drop concentration is given by: + ! + ! = / ( (4/3) * pi * rho_lw * mvr_rain_max^3 ). + + Nxm_min_coef & + = one / ( four_thirds * pi * rho_lw * mvr_hm_max(i)**3 ) + + else ! l_frozen_hm(i) + + ! Clipping for mean frozen hydrometeor concentration, . + ! When mean frozen hydrometeor mixing ratio, , is found at a + ! grid level, mean frozen hydrometeor concentration must be at least + ! a minimum value so that average frozen hydrometeor mean volume + ! radius stays within an upper bound. Otherwise, mean frozen + ! hydrometeor concentration is 0. + + ! The minimum mean frozen hydrometeor concentration is given by: + ! + ! = / ( (4/3) * pi * rho_ice * mvr_x_max^3 ). + + Nxm_min_coef & + = one / ( four_thirds * pi * rho_ice * mvr_hm_max(i)**3 ) + + endif ! .not. l_frozen_hm(i) + + ! Loop over vertical levels and increase hydrometeor concentrations + ! when necessary. + do k = 2, gr%nz, 1 + + if ( hydromet(k,Nx2rx_hm_idx(i)) > zero ) then + + ! Hydrometeor mixing ratio, , is found at the grid level. + hydromet(k,i) & + = max( hydromet(k,i), & + Nxm_min_coef * hydromet(k,Nx2rx_hm_idx(i)) ) + + else ! = 0 + + hydromet(k,i) = zero + + endif ! hydromet(k,Nx2rx_hm_idx(i)) > 0 + + enddo ! k = 2, gr%nz, 1 + + ! Enter the new value of the hydrometeor for the effect of clipping. + if ( l_stats_samp ) then + call stat_end_update( ixrm_cl, hydromet(:,i) & + / dt, stats_zt ) + endif + + endif ! .not. l_mix_rat_hm(i) + + enddo ! i = 1, hydromet_dim, 1 + + + return + + end subroutine fill_holes_driver + + !----------------------------------------------------------------------- + subroutine setup_stats_indices( ihm, & ! Intent(in) + ixrm_bt, ixrm_hf, ixrm_wvhf, & ! Intent(inout) + ixrm_cl, ixrm_mc, & ! Intent(inout) + max_velocity ) ! Intent(inout) + + ! Description: + ! + ! Determines the stats output indices depending on the hydrometeor. + + ! Attention: hydromet_list needs to be set up before this routine is called. + ! + ! Bogus example + ! References: + ! + ! None + !----------------------------------------------------------------------- + + + use array_index, only: & + hydromet_list ! Names of the hydrometeor species + + use stats_variables, only: & + irrm_bt, & ! Variable(s) + irrm_mc, & + irrm_hf, & + irrm_wvhf, & + irrm_cl, & + irim_bt, & + irim_mc, & + irim_hf, & + irim_wvhf, & + irim_cl, & + irgm_bt, & + irgm_mc, & + irgm_hf, & + irgm_wvhf, & + irgm_cl, & + irsm_bt, & + irsm_mc, & + irsm_hf, & + irsm_wvhf, & + irsm_cl + + use stats_variables, only: & + iNrm_bt, & ! Variable(s) + iNrm_mc, & + iNrm_cl, & + iNim_bt, & + iNim_cl, & + iNim_mc, & + iNsm_bt, & + iNsm_cl, & + iNsm_mc, & + iNgm_bt, & + iNgm_cl, & + iNgm_mc, & + iNcm_bt, & + iNcm_cl, & + iNcm_mc + + use clubb_precision, only: & + core_rknd + + use constants_clubb, only: & + zero + + implicit none + + ! Input Variables + integer, intent(in) :: ihm + + ! Input/Output Variables + real( kind = core_rknd ), intent(inout) :: & + max_velocity ! Maximum sedimentation velocity [m/s] + + integer, intent(inout) :: ixrm_hf, ixrm_wvhf, ixrm_cl, & + ixrm_bt, ixrm_mc + + !----------------------------------------------------------------------- + + !----- Begin Code ----- + + ! Initializing max_velocity in order to avoid a compiler warning. + ! Regardless of the case, it will be reset in the 'select case' + ! statement immediately below. + max_velocity = zero + + select case ( trim( hydromet_list(ihm) ) ) + case ( "rrm" ) + ixrm_bt = irrm_bt + ixrm_hf = irrm_hf + ixrm_wvhf = irrm_wvhf + ixrm_cl = irrm_cl + ixrm_mc = irrm_mc + + max_velocity = -9.1_core_rknd ! m/s + + case ( "rim" ) + ixrm_bt = irim_bt + ixrm_hf = irim_hf + ixrm_wvhf = irim_wvhf + ixrm_cl = irim_cl + ixrm_mc = irim_mc + + max_velocity = -1.2_core_rknd ! m/s + + case ( "rsm" ) + ixrm_bt = irsm_bt + ixrm_hf = irsm_hf + ixrm_wvhf = irsm_wvhf + ixrm_cl = irsm_cl + ixrm_mc = irsm_mc + + ! Morrison limit +! max_velocity = -1.2_core_rknd ! m/s + ! Made up limit. The literature suggests that it is quite possible + ! that snow flake might achieve a terminal velocity of 2 m/s, and this + ! happens in the COAMPS microphysics -dschanen 29 Sept 2009 + max_velocity = -2.0_core_rknd ! m/s + + case ( "rgm" ) + ixrm_bt = irgm_bt + ixrm_hf = irgm_hf + ixrm_wvhf = irgm_wvhf + ixrm_cl = irgm_cl + ixrm_mc = irgm_mc + + max_velocity = -20._core_rknd ! m/s + + case ( "Nrm" ) + ixrm_bt = iNrm_bt + ixrm_hf = 0 + ixrm_wvhf = 0 + ixrm_cl = iNrm_cl + ixrm_mc = iNrm_mc + + max_velocity = -9.1_core_rknd ! m/s + + case ( "Nim" ) + ixrm_bt = iNim_bt + ixrm_hf = 0 + ixrm_wvhf = 0 + ixrm_cl = iNim_cl + ixrm_mc = iNim_mc + + max_velocity = -1.2_core_rknd ! m/s + + case ( "Nsm" ) + ixrm_bt = iNsm_bt + ixrm_hf = 0 + ixrm_wvhf = 0 + ixrm_cl = iNsm_cl + ixrm_mc = iNsm_mc + + ! Morrison limit +! max_velocity = -1.2_core_rknd ! m/s + ! Made up limit. The literature suggests that it is quite possible + ! that snow flake might achieve a terminal velocity of 2 m/s, and this + ! happens in the COAMPS microphysics -dschanen 29 Sept 2009 + max_velocity = -2.0_core_rknd ! m/s + + case ( "Ngm" ) + ixrm_bt = iNgm_bt + ixrm_hf = 0 + ixrm_wvhf = 0 + ixrm_cl = iNgm_cl + ixrm_mc = iNgm_mc + + max_velocity = -20._core_rknd ! m/s + + case ( "Ncm" ) + ixrm_bt = iNcm_bt + ixrm_hf = 0 + ixrm_wvhf = 0 + ixrm_cl = iNcm_cl + ixrm_mc = iNcm_mc + + ! Use the rain water limit, since Morrison has no explicit limit on + ! cloud water. Presumably these numbers are never large. + ! -dschanen 28 Sept 2009 + max_velocity = -9.1_core_rknd ! m/s + + case default + ixrm_bt = 0 + ixrm_hf = 0 + ixrm_wvhf = 0 + ixrm_cl = 0 + ixrm_mc = 0 + + max_velocity = -9.1_core_rknd ! m/s + + end select + + + return + + end subroutine setup_stats_indices + !----------------------------------------------------------------------- + end module fill_holes diff --git a/models/atm/cam/src/physics/clubb/gmres_cache.F90 b/models/atm/cam/src/physics/clubb/gmres_cache.F90 index 22c29638c657..4edd35d9c603 100644 --- a/models/atm/cam/src/physics/clubb/gmres_cache.F90 +++ b/models/atm/cam/src/physics/clubb/gmres_cache.F90 @@ -43,6 +43,7 @@ module gmres_cache gmres_temp_norm ! Temporary array that stores GMRES internal values ! for the non-interlaced matrices (gr%nz grid ! levels) + !$omp threadprivate(gmres_temp_intlc, gmres_temp_norm) integer, public :: & @@ -67,7 +68,6 @@ module gmres_cache ! initial solution has been passed in for that particular ! cache index. This defaults to false and is set to true ! when a solution is updated. - !$omp threadprivate(l_gmres_soln_ok) contains diff --git a/models/atm/cam/src/physics/clubb/gmres_wrap.F90 b/models/atm/cam/src/physics/clubb/gmres_wrap.F90 index c2bfbea788be..4ec015577ab1 100644 --- a/models/atm/cam/src/physics/clubb/gmres_wrap.F90 +++ b/models/atm/cam/src/physics/clubb/gmres_wrap.F90 @@ -1,5 +1,5 @@ !---------------------------------------------------------------------------- -! $Id: gmres_wrap.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +! $Id: gmres_wrap.F90 7012 2014-07-07 14:18:31Z schemena@uwm.edu $ !============================================================================== module gmres_wrap @@ -112,13 +112,12 @@ subroutine gmres_solve(elements, numeqns, & !Intent(in) csr_ia ! IA-array portion of the matrix description in CSR format. ! This describes the indices of the JA-array that start ! new rows. For more details, check the documentation in - ! the csr_matrix_class module. + ! the csr_matrix_module. integer, dimension(elements), intent(in) :: & csr_ja ! JA-array portion of the matrix description in CSR format. ! This describes which columns of a are nonzero. For more - ! details, check the documentation in the csr_matrix_class - ! module. + ! details, check the documentation in the csr_matrix_module. integer, intent(in) :: & tempsize ! Denotes the size of the temporary array used for GMRES @@ -201,8 +200,8 @@ subroutine gmres_solve(elements, numeqns, & !Intent(in) err_code = 0 ! Convert our A array and rhs vector to double precision... - csr_dbl_a = dble(csr_a) - dbl_rhs = dble(rhs) + csr_dbl_a = real(csr_a, kind=dp) + dbl_rhs = real(rhs, kind=dp) ! DEBUG: Set our a_array so it represents the identity matrix, and ! set the RHS so we can get a meaningful answer. diff --git a/models/atm/cam/src/physics/clubb/grid_class.F90 b/models/atm/cam/src/physics/clubb/grid_class.F90 index 5e36bfe04848..1a68eec5974a 100644 --- a/models/atm/cam/src/physics/clubb/grid_class.F90 +++ b/models/atm/cam/src/physics/clubb/grid_class.F90 @@ -1,5 +1,5 @@ !------------------------------------------------------------------------ -! $Id: grid_class.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +! $Id: grid_class.F90 7200 2014-08-13 15:15:12Z betlej@uwm.edu $ !=============================================================================== module grid_class @@ -9,16 +9,16 @@ module grid_class ! ! The grid specification is as follows: ! - ! + ================== zm(nzmax) =========GP======= + ! + ================== zm(nz) =========GP========= ! | ! | - ! 1/dzt(nzmax) + ------------------ zt(nzmax) ---------GP------- + ! 1/dzt(nz) + ------------------ zt(nz) ---------GP--------- ! | | ! | | - ! + 1/dzm(nzmax-1) ================== zm(nzmax-1) ================ + ! + 1/dzm(nz-1) ================== zm(nz-1) ================== ! | ! | - ! + ------------------ zt(nzmax-1) ---------------- + ! + ------------------ zt(nz-1) ------------------ ! ! . ! . @@ -131,6 +131,7 @@ module grid_class ! ! Chris Golaz, 7/17/99 ! modified 9/10/99 + ! schemena, modified 6/11/2014 - Restructered code to add cubic/linear flag ! References: @@ -141,14 +142,14 @@ module grid_class !----------------------------------------------------------------------- use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) implicit none public :: gr, grid, zt2zm, interp_weights_zt2zm_imp, zm2zt, & interp_weights_zm2zt_imp, ddzm, ddzt, & setup_grid, cleanup_grid, setup_grid_heights, & - read_grid_heights, flip, zt2zm_linear, zm2zt_linear + read_grid_heights, flip private :: linear_interpolated_azm, linear_interpolated_azmk, & interpolated_azmk_imp, linear_interpolated_azt, & @@ -161,11 +162,10 @@ module grid_class ! Constant parameters integer, parameter :: & - t_above = 1, & ! Upper thermodynamic level index (gr%weights_zt2zm). - t_below = 2, & ! Lower thermodynamic level index (gr%weights_zt2zm). - m_above = 1, & ! Upper momentum level index (gr%weights_zm2zt). - m_below = 2 ! Lower momentum level index (gr%weights_zm2zt). - + t_above = 1, & ! Upper thermodynamic level index (gr%weights_zt2zm). + t_below = 2, & ! Lower thermodynamic level index (gr%weights_zt2zm). + m_above = 1, & ! Upper momentum level index (gr%weights_zm2zt). + m_below = 2 ! Lower momentum level index (gr%weights_zm2zt). type grid @@ -181,9 +181,9 @@ module grid_class zt ! Thermo grid real( kind = core_rknd ), pointer, dimension(:) :: & invrs_dzm, & ! The inverse spacing between thermodynamic grid - ! levels; centered over momentum grid levels. + ! levels; centered over momentum grid levels. invrs_dzt ! The inverse spacing between momentum grid levels; - ! centered over thermodynamic grid levels. + ! centered over thermodynamic grid levels. real( kind = core_rknd ), pointer, dimension(:) :: & dzm, & ! Spacing between thermodynamic grid levels; centered over @@ -213,35 +213,32 @@ module grid_class ! Interfaces provided for function overloading - ! Interpolation/extension functions - interface zt2zm_linear + interface zt2zm + ! For l_cubic_interp = .true. + ! This version uses cublic spline interpolation of Stefen (1990). + ! + ! For l_cubic_interp = .false. ! This performs a linear extension at the highest grid level and therefore ! does not guarantee, for positive definite quantities (e.g. wp2), that the ! extended point is indeed positive definite. Positive definiteness can be ! ensured with a max statement. ! In the future, we could add a flag (lposdef) and, when needed, apply the ! max statement directly within interpolated_azm and interpolated_azmk. - module procedure linear_interpolated_azmk, linear_interpolated_azm + module procedure redirect_interpolated_azmk, redirect_interpolated_azm end interface - interface zm2zt_linear + interface zm2zt + ! For l_cubic_interp = .true. + ! This version uses cublic spline interpolation of Stefen (1990). + ! + ! For l_cubic_interp = .false. ! This performs a linear extension at the lowest grid level and therefore ! does not guarantee, for positive definite quantities (e.g. wp2), that the ! extended point is indeed positive definite. Positive definiteness can be ! ensured with a max statement. ! In the future, we could add a flag (lposdef) and, when needed, apply the ! max statement directly within interpolated_azt and interpolated_aztk. - module procedure linear_interpolated_azt, linear_interpolated_aztk - end interface - - interface zt2zm - ! This version uses cublic spline interpolation of Stefen (1990). - module procedure cubic_interpolated_azmk, cubic_interpolated_azm - end interface - - interface zm2zt - ! As above, but for interpolating zm to zt levels. - module procedure cubic_interpolated_aztk, cubic_interpolated_azt + module procedure redirect_interpolated_aztk, redirect_interpolated_azt end interface interface interp_weights_zt2zm_imp @@ -460,7 +457,7 @@ subroutine setup_grid( nzmax, sfc_elevation, l_implemented, & endif ! grid_type - endif ! l_implemented + endif ! .not. l_implemented !--------------------------------------------------- @@ -509,7 +506,7 @@ subroutine cleanup_grid ! None !------------------------------------------------------------------------------ use constants_clubb, only: & - fstderr ! Constant + fstderr ! Constant(s) implicit none @@ -529,7 +526,9 @@ subroutine cleanup_grid write(fstderr,*) "Grid deallocation failed." end if + return + end subroutine cleanup_grid !============================================================================= @@ -546,10 +545,11 @@ subroutine setup_grid_heights & ! None !------------------------------------------------------------------------------ - use constants_clubb, only: fstderr ! Constant + use constants_clubb, only: & + fstderr ! Constant(s) use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) implicit none @@ -787,8 +787,10 @@ subroutine read_grid_heights( nzmax, grid_type, & use constants_clubb, only: & fstderr ! Variable(s) + use file_functions, only: & file_read_1d ! Procedure(s) + use clubb_precision, only: & core_rknd ! Variable(s) @@ -1051,6 +1053,206 @@ subroutine read_grid_heights( nzmax, grid_type, & end subroutine read_grid_heights !============================================================================= + function redirect_interpolated_azmk( azt, k ) + + ! Description: + ! Calls the appropriate corresponding function based on l_cubic_temp + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use model_flags, only: & + l_cubic_interp, & ! Variable(s) + l_quintic_poly_interp + + use constants_clubb, only: & + fstdout ! Variable + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + azt ! Variable on thermodynamic grid levels [units vary] + + integer, intent(in) :: & + k ! Vertical level index + + ! Return Variable + real( kind = core_rknd ) :: & + redirect_interpolated_azmk ! Variable when interp. to momentum levels + + ! ---- Begin Code ---- + + ! Sanity Check + if (l_quintic_poly_interp) then + if (.not. l_cubic_interp) then + write (fstdout, *) "Error: Model flag l_quintic_poly_interp should not be true if "& + //"l_cubic_interp is false." + stop + end if + end if + + ! Redirect + if (l_cubic_interp) then + redirect_interpolated_azmk = cubic_interpolated_azmk( azt, k ) + else + redirect_interpolated_azmk = linear_interpolated_azmk( azt, k ) + end if + + return + end function redirect_interpolated_azmk + + !============================================================================= + function redirect_interpolated_azm( azt ) + + ! Description: + ! Calls the appropriate corresponding function based on l_cubic_temp + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use model_flags, only: & + l_cubic_interp, & ! Variable(s) + l_quintic_poly_interp + + use constants_clubb, only: & + fstdout ! Variable + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + azt ! Variable on thermodynamic grid levels [units vary] + + ! Return Variable + real( kind = core_rknd ), dimension(gr%nz) :: & + redirect_interpolated_azm ! Variable when interp. to momentum levels + + ! ---- Begin Code ---- + + ! Sanity Check + if (l_quintic_poly_interp) then + if (.not. l_cubic_interp) then + write (fstdout, *) "Error: Model flag l_quintic_poly_interp should not be true if "& + //"l_cubic_interp is false." + stop + end if + end if + + ! Redirect + if (l_cubic_interp) then + redirect_interpolated_azm = cubic_interpolated_azm( azt ) + else + redirect_interpolated_azm = linear_interpolated_azm( azt ) + end if + + return + end function redirect_interpolated_azm + + !============================================================================= + function redirect_interpolated_aztk( azt, k ) + + ! Description: + ! Calls the appropriate corresponding function based on l_cubic_temp + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use model_flags, only: & + l_cubic_interp, & ! Variable(s) + l_quintic_poly_interp + + use constants_clubb, only: & + fstdout ! Variable + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + azt ! Variable on thermodynamic grid levels [units vary] + + integer, intent(in) :: & + k ! Vertical level index + + ! Return Variable + real( kind = core_rknd ) :: & + redirect_interpolated_aztk ! Variable when interp. to momentum levels + + ! ---- Begin Code ---- + + ! Sanity Check + if (l_quintic_poly_interp) then + if (.not. l_cubic_interp) then + write (fstdout, *) "Error: Model flag l_quintic_poly_interp should not be true if "& + //"l_cubic_interp is false." + stop + end if + end if + + ! Redirect + if (l_cubic_interp) then + redirect_interpolated_aztk = cubic_interpolated_aztk( azt, k ) + else + redirect_interpolated_aztk = linear_interpolated_aztk( azt, k ) + end if + + return + end function redirect_interpolated_aztk + + !============================================================================= + function redirect_interpolated_azt( azt ) + + ! Description: + ! Calls the appropriate corresponding function based on l_cubic_temp + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use model_flags, only: & + l_cubic_interp, & ! Variable(s) + l_quintic_poly_interp + + use constants_clubb, only: & + fstdout ! Variable + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + azt ! Variable on thermodynamic grid levels [units vary] + + ! Return Variable + real( kind = core_rknd ), dimension(gr%nz) :: & + redirect_interpolated_azt ! Variable when interp. to momentum levels + + ! ---- Begin Code ---- + + ! Sanity Check + if (l_quintic_poly_interp) then + if (.not. l_cubic_interp) then + write (fstdout, *) "Error: Model flag l_quintic_poly_interp should not be true if "& + //"l_cubic_interp is false." + stop + end if + end if + + ! Redirect + if (l_cubic_interp) then + redirect_interpolated_azt = cubic_interpolated_azt( azt ) + else + redirect_interpolated_azt = linear_interpolated_azt( azt ) + end if + + return + end function redirect_interpolated_azt + + !============================================================================= + + pure function linear_interpolated_azm( azt ) ! Description: @@ -1061,40 +1263,47 @@ pure function linear_interpolated_azm( azt ) !----------------------------------------------------------------------- use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) - use interpolation, only: linear_interp_factor + use interpolation, only: & + linear_interp_factor ! Procedure(s) implicit none ! Input Variable - real( kind = core_rknd ), intent(in), dimension(gr%nz) :: azt + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + azt ! Variable on thermodynamic grid levels [units vary] ! Return Variable - real( kind = core_rknd ), dimension(gr%nz) :: linear_interpolated_azm + real( kind = core_rknd ), dimension(gr%nz) :: & + linear_interpolated_azm ! Variable when interp. to momentum levels ! Local Variable - integer :: k + integer :: k ! Grid level loop index - ! ---- Begin Code ---- - - ! Do the actual interpolation. - ! Use linear interpolation. - forall( k = 1 : gr%nz-1 : 1 ) - linear_interpolated_azm(k) = & - linear_interp_factor( gr%weights_zt2zm(1, k), azt(k+1), azt(k) ) - end forall + ! Set the value of the thermodynamic-level variable, azt, at the uppermost + ! level of the model, which is a momentum level. The name of the variable + ! when interpolated/extended to momentum levels is azm. + k = gr%nz ! ! Set the value of azm at level gr%nz (the uppermost level in the model) ! ! to the value of azt at level gr%nz. -! linear_interpolated_azm(gr%nz) = azt(gr%nz) +! linear_interpolated_azm(k) = azt(k) ! Use a linear extension based on the values of azt at levels gr%nz and ! gr%nz-1 to find the value of azm at level gr%nz (the uppermost level ! in the model). - linear_interpolated_azm(gr%nz) = & - ( ( azt(gr%nz)-azt(gr%nz-1) ) & - / ( gr%zt(gr%nz)-gr%zt(gr%nz-1) ) ) & - * ( gr%zm(gr%nz)-gr%zt(gr%nz) ) + azt(gr%nz) + linear_interpolated_azm(k) & + = ( ( azt(k) - azt(k-1) ) / ( gr%zt(k) - gr%zt(k-1) ) ) & + * ( gr%zm(k) - gr%zt(k) ) + azt(k) + + ! Interpolate the value of a thermodynamic-level variable to the central + ! momentum level, k, between two successive thermodynamic levels using + ! linear interpolation. + forall( k = 1 : gr%nz-1 : 1 ) + linear_interpolated_azm(k) & + = linear_interp_factor( gr%weights_zt2zm(1, k), azt(k+1), azt(k) ) + end forall ! k = 1 : gr%nz-1 : 1 + return @@ -1112,50 +1321,54 @@ pure function linear_interpolated_azmk( azt, k ) !----------------------------------------------------------------------- use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) - use interpolation, only: linear_interp_factor + use interpolation, only: & + linear_interp_factor ! Procedure(s) implicit none ! Input Variables - real( kind = core_rknd ), intent(in), dimension(gr%nz) :: azt + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + azt ! Variable on thermodynamic grid levels [units vary] - integer, intent(in) :: k + integer, intent(in) :: & + k ! Vertical level index ! Return Variable - real( kind = core_rknd ) :: linear_interpolated_azmk + real( kind = core_rknd ) :: & + linear_interpolated_azmk ! Variable when interp. to momentum levels - ! ---- Begin Code ---- - ! Do the actual interpolation. - ! Use a linear interpolation. + ! Interpolate the value of a thermodynamic-level variable to the central + ! momentum level, k, between two successive thermodynamic levels using + ! linear interpolation. if ( k /= gr%nz ) then - linear_interpolated_azmk = & - linear_interp_factor( gr%weights_zt2zm(1, k), azt(k+1), azt(k) ) + linear_interpolated_azmk & + = linear_interp_factor( gr%weights_zt2zm(1, k), azt(k+1), azt(k) ) else ! ! Set the value of azm at level gr%nz (the uppermost level in the ! ! model) to the value of azt at level gr%nz. ! linear_interpolated_azmk = azt(gr%nz) - ! Use a linear extension based on the values of azt at levels gr%nz and - ! gr%nz-1 to find the value of azm at level gr%nz (the uppermost - ! level in the model). - linear_interpolated_azmk = & - ( ( azt(gr%nz)-azt(gr%nz-1) ) & - / ( gr%zt(gr%nz)-gr%zt(gr%nz-1) ) ) & - * ( gr%zm(gr%nz)-gr%zt(gr%nz) ) + azt(gr%nz) + ! Use a linear extension based on the values of azt at levels gr%nz and + ! gr%nz-1 to find the value of azm at level gr%nz (the uppermost + ! level in the model). + linear_interpolated_azmk & + = ( ( azt(gr%nz) - azt(gr%nz-1) ) / ( gr%zt(gr%nz) - gr%zt(gr%nz-1) ) ) & + * ( gr%zm(gr%nz) - gr%zt(gr%nz) ) + azt(gr%nz) endif + return end function linear_interpolated_azmk !============================================================================= - pure function cubic_interpolated_azm( azt ) + function cubic_interpolated_azm( azt ) ! Description: ! Function to interpolate a variable located on the thermodynamic grid @@ -1165,7 +1378,7 @@ pure function cubic_interpolated_azm( azt ) !----------------------------------------------------------------------- use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) implicit none @@ -1185,9 +1398,9 @@ pure function cubic_interpolated_azm( azt ) ! ---- Begin Code ---- - forall( k = 1 : gr%nz ) + do k = 1, gr%nz tmp(k) = cubic_interpolated_azmk( azt, k ) - end forall + end do cubic_interpolated_azm = tmp @@ -1196,7 +1409,7 @@ pure function cubic_interpolated_azm( azt ) end function cubic_interpolated_azm !============================================================================= - pure function cubic_interpolated_azmk( azt, k ) + function cubic_interpolated_azmk( azt, k ) ! Description: ! Function to interpolate a variable located on the thermodynamic grid @@ -1205,10 +1418,11 @@ pure function cubic_interpolated_azmk( azt, k ) ! interpolation implemented by Tak Yamaguchi. !----------------------------------------------------------------------- - use interpolation, only: mono_cubic_interp + use interpolation, only: & + mono_cubic_interp ! Procedure(s) use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Constant(s) implicit none @@ -1420,8 +1634,11 @@ pure function interpolated_azmk_imp( m_lev ) & ! !----------------------------------------------------------------------- + use constants_clubb, only: & + one ! Constant(s) + use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) implicit none @@ -1430,39 +1647,40 @@ pure function interpolated_azmk_imp( m_lev ) & t_above = 1, & ! Upper thermodynamic level. t_below = 2 ! Lower thermodynamic level. - ! Input + ! Input Variable integer, intent(in) :: m_lev ! Momentum level index - ! Output - real( kind = core_rknd ), dimension(2) :: azt_weight ! Weights of the thermodynamic levels. + ! Output Variable + real( kind = core_rknd ), dimension(2) :: & + azt_weight ! Weights of the thermodynamic levels. ! Local Variables real( kind = core_rknd ) :: factor + integer :: k - ! ---- Begin Code ---- ! Compute the weighting factors at momentum level k. k = m_lev if ( k /= gr%nz ) then - ! At most levels, the momentum level is found in-between two - ! thermodynamic levels. Linear interpolation is used. - factor = ( gr%zm(k)-gr%zt(k) ) / ( gr%zt(k+1)-gr%zt(k) ) + ! At most levels, the momentum level is found in-between two + ! thermodynamic levels. Linear interpolation is used. + factor = ( gr%zm(k) - gr%zt(k) ) / ( gr%zt(k+1) - gr%zt(k) ) else - ! The top model level (gr%nz) is formulated differently because the top - ! momentum level is above the top thermodynamic level. A linear - ! extension is required, rather than linear interpolation. - ! Note: Variable "factor" will be greater than 1 in this situation. - factor = & - ( gr%zm(gr%nz)-gr%zt(gr%nz-1) ) & - / ( gr%zt(gr%nz)-gr%zt(gr%nz-1) ) + ! The top model level (gr%nz) is formulated differently because the top + ! momentum level is above the top thermodynamic level. A linear + ! extension is required, rather than linear interpolation. + ! Note: Variable "factor" will be greater than 1 in this situation. + factor & + = ( gr%zm(gr%nz) - gr%zt(gr%nz-1) ) / ( gr%zt(gr%nz) - gr%zt(gr%nz-1) ) endif ! Weight of upper thermodynamic level on momentum level. azt_weight(t_above) = factor ! Weight of lower thermodynamic level on momentum level. - azt_weight(t_below) = 1.0_core_rknd - factor + azt_weight(t_below) = one - factor + return @@ -1479,37 +1697,47 @@ pure function linear_interpolated_azt( azm ) !----------------------------------------------------------------------- use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) - use interpolation, only: linear_interp_factor + use interpolation, only: & + linear_interp_factor ! Procedure(s) implicit none ! Input Variable - real( kind = core_rknd ), intent(in), dimension(gr%nz) :: azm + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + azm ! Variable on momentum grid levels [units vary] ! Output Variable - real( kind = core_rknd ), dimension(gr%nz) :: linear_interpolated_azt + real( kind = core_rknd ), dimension(gr%nz) :: & + linear_interpolated_azt ! Variable when interp. to thermodynamic levels ! Local Variable - integer :: k ! Index + integer :: k ! Grid level loop index - ! ---- Begin Code ---- - ! Do actual interpolation. - ! Use a linear interpolation. - forall( k = gr%nz : 2 : -1 ) - linear_interpolated_azt(k) = & - linear_interp_factor( gr%weights_zm2zt(1, k), azm(k), azm(k-1) ) - end forall ! gr%nz .. 2 + ! Set the value of the momentum-level variable, azm, at the lowermost level + ! of the model (below the model lower boundary), which is a thermodynamic + ! level. The name of the variable when interpolated/extended to + ! thermodynamic levels is azt. + k = 1 ! ! Set the value of azt at level 1 (the lowermost level in the model) to the ! ! value of azm at level 1. -! interpolated_azt(1) = azm(1) +! linear_interpolated_azt(k) = azm(k) ! Use a linear extension based on the values of azm at levels 1 and 2 to ! find the value of azt at level 1 (the lowermost level in the model). - linear_interpolated_azt(1) = & - ( ( azm(2)-azm(1) ) / ( gr%zm(2)-gr%zm(1) ) ) & - * ( gr%zt(1)-gr%zm(1) ) + azm(1) + linear_interpolated_azt(k) & + = ( ( azm(k+1) - azm(k) ) / ( gr%zm(k+1) - gr%zm(k) ) ) & + * ( gr%zt(k) - gr%zm(k) ) + azm(k) + + ! Interpolate the value of a momentum-level variable to the central + ! thermodynamic level, k, between two successive momentum levels using + ! linear interpolation. + forall( k = gr%nz : 2 : -1 ) + linear_interpolated_azt(k) & + = linear_interp_factor( gr%weights_zm2zt(1, k), azm(k), azm(k-1) ) + end forall ! k = gr%nz : 2 : -1 + return @@ -1527,48 +1755,53 @@ pure function linear_interpolated_aztk( azm, k ) !----------------------------------------------------------------------- use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) - use interpolation, only: linear_interp_factor + use interpolation, only: & + linear_interp_factor ! Procedure(s) implicit none ! Input Variables - real( kind = core_rknd ), intent(in), dimension(gr%nz) :: azm + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + azm ! Variable on momentum grid levels [units vary] - integer, intent(in) :: k + integer, intent(in) :: & + k ! Vertical level index ! Return Variables - real( kind = core_rknd ) :: linear_interpolated_aztk + real( kind = core_rknd ) :: & + linear_interpolated_aztk ! Variable when interp. to thermodynamic levs. - ! ---- Begin Code ---- - ! Do actual interpolation. - ! Use a linear interpolation. + ! Interpolate the value of a momentum-level variable to the central + ! thermodynamic level, k, between two successive momentum levels using + ! linear interpolation. if ( k /= 1 ) then - linear_interpolated_aztk = & - linear_interp_factor( gr%weights_zm2zt(1, k), azm(k), azm(k-1) ) + linear_interpolated_aztk & + = linear_interp_factor( gr%weights_zm2zt(1, k), azm(k), azm(k-1) ) else ! ! Set the value of azt at level 1 (the lowermost level in the model) to ! ! the value of azm at level 1. ! linear_interpolated_aztk = azm(1) - ! Use a linear extension based on the values of azm at levels 1 and 2 to - ! find the value of azt at level 1 (the lowermost level in the model). - linear_interpolated_aztk = & - ( ( azm(2)-azm(1) ) / ( gr%zm(2)-gr%zm(1) ) ) & - * ( gr%zt(1)-gr%zm(1) ) + azm(1) + ! Use a linear extension based on the values of azm at levels 1 and 2 to + ! find the value of azt at level 1 (the lowermost level in the model). + linear_interpolated_aztk & + = ( ( azm(2) - azm(1) ) / ( gr%zm(2) - gr%zm(1) ) ) & + * ( gr%zt(1) - gr%zm(1) ) + azm(1) endif + return end function linear_interpolated_aztk !============================================================================= - pure function cubic_interpolated_azt( azm ) + function cubic_interpolated_azt( azm ) ! Description: ! Function to interpolate a variable located on the momentum grid @@ -1581,7 +1814,7 @@ pure function cubic_interpolated_azt( azm ) !----------------------------------------------------------------------- use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) implicit none @@ -1601,9 +1834,9 @@ pure function cubic_interpolated_azt( azm ) ! ---- Begin Code ---- - forall ( k = 1 : gr%nz ) + do k = 1, gr%nz tmp(k) = cubic_interpolated_aztk( azm, k ) - end forall + end do cubic_interpolated_azt = tmp @@ -1613,7 +1846,7 @@ end function cubic_interpolated_azt !============================================================================= - pure function cubic_interpolated_aztk( azm, k ) + function cubic_interpolated_aztk( azm, k ) ! Description: ! Function to interpolate a variable located on the momentum grid @@ -1625,10 +1858,11 @@ pure function cubic_interpolated_aztk( azm, k ) ! None !----------------------------------------------------------------------- - use interpolation, only: mono_cubic_interp + use interpolation, only: & + mono_cubic_interp ! Procedure(s) use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) implicit none @@ -1843,8 +2077,11 @@ pure function interpolated_aztk_imp( t_lev ) & ! !----------------------------------------------------------------------- + use constants_clubb, only: & + one ! Constant(s) + use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) implicit none @@ -1853,37 +2090,39 @@ pure function interpolated_aztk_imp( t_lev ) & m_above = 1, & ! Upper momentum level. m_below = 2 ! Lower momentum level. - ! Input + ! Input Variable integer, intent(in) :: t_lev ! Thermodynamic level index. - ! Output - real( kind = core_rknd ), dimension(2) :: azm_weight ! Weights of the momentum levels. + ! Output Variable + real( kind = core_rknd ), dimension(2) :: & + azm_weight ! Weights of the momentum levels. ! Local Variables real( kind = core_rknd ) :: factor + integer :: k - ! ---- Begin Code ---- ! Compute the weighting factors at thermodynamic level k. k = t_lev if ( k /= 1 ) then - ! At most levels, the thermodynamic level is found in-between two - ! momentum levels. Linear interpolation is used. - factor = ( gr%zt(k)-gr%zm(k-1) ) / ( gr%zm(k)-gr%zm(k-1) ) + ! At most levels, the thermodynamic level is found in-between two + ! momentum levels. Linear interpolation is used. + factor = ( gr%zt(k) - gr%zm(k-1) ) / ( gr%zm(k) - gr%zm(k-1) ) else - ! The bottom model level (1) is formulated differently because the bottom - ! thermodynamic level is below the bottom momentum level. A linear - ! extension is required, rather than linear interpolation. - ! Note: Variable "factor" will have a negative sign in this situation. - factor = ( gr%zt(1)-gr%zm(1) ) / ( gr%zm(2)-gr%zm(1) ) + ! The bottom model level (1) is formulated differently because the bottom + ! thermodynamic level is below the bottom momentum level. A linear + ! extension is required, rather than linear interpolation. + ! Note: Variable "factor" will have a negative sign in this situation. + factor = ( gr%zt(1) - gr%zm(1) ) / ( gr%zm(2) - gr%zm(1) ) endif ! Weight of upper momentum level on thermodynamic level. azm_weight(m_above) = factor ! Weight of lower momentum level on thermodynamic level. - azm_weight(m_below) = 1.0_core_rknd - factor + azm_weight(m_below) = one - factor + return @@ -1898,42 +2137,52 @@ pure function gradzm( azm ) ! thermodynamic grid. !----------------------------------------------------------------------- +! use constants_clubb, only: & +! zero ! Constant(s) + use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) implicit none ! Input Variable - real( kind = core_rknd ), intent(in), dimension(gr%nz) :: azm + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + azm ! Variable on momentum grid levels [units vary] ! Return Variable - real( kind = core_rknd ), dimension(gr%nz) :: gradzm + real( kind = core_rknd ), dimension(gr%nz) :: & + gradzm ! Vertical derivative of azm [units vary / m] ! Local Variable - integer :: k + integer :: k ! Grid level loop index - ! ---- Begin Code ---- - ! Compute vertical derivatives. - forall( k = gr%nz : 2 : -1 ) - ! Take derivative of momentum-level variable azm over the central - ! thermodynamic level (k). - gradzm(k) = ( azm(k) - azm(k-1) ) * gr%invrs_dzt(k) - end forall ! gr%nz .. 2 + ! Set the value of the vertical derivative of a momentum-level variable over + ! the thermodynamic grid level at the lowermost level of the model. + k = 1 ! ! Thermodynamic level 1 is located below momentum level 1, so there is not ! ! enough information to calculate the derivative over thermodynamic ! ! level 1. Thus, the value of the derivative at thermodynamic level 1 is ! ! set equal to 0. This formulation is consistent with setting the value of ! ! the variable azm below the model grid to the value of the variable azm at ! ! the lowest grid level. -! gradzm(1) = 0. +! gradzm(k) = zero ! Thermodynamic level 1 is located below momentum level 1, so there is not ! enough information to calculate the derivative over thermodynamic level 1. ! Thus, the value of the derivative at thermodynamic level 1 is set equal to ! the value of the derivative at thermodynamic level 2. This formulation is ! consistent with using a linear extension to find the values of the ! variable azm below the model grid. - gradzm(1) = gradzm(2) + gradzm(k) = ( azm(k+1) - azm(k) ) * gr%invrs_dzt(k+1) + + ! Calculate the vertical derivative of a momentum-level variable between two + ! successive momentum grid levels. + forall( k = gr%nz : 2 : -1 ) + ! Take derivative of momentum-level variable azm over the central + ! thermodynamic level (k). + gradzm(k) = ( azm(k) - azm(k-1) ) * gr%invrs_dzt(k) + end forall ! k = gr%nz : 2 : -1 + return @@ -1948,42 +2197,52 @@ pure function gradzt( azt ) ! the momentum grid. !----------------------------------------------------------------------- +! use constants_clubb, only: & +! zero ! Constant(s) + use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) implicit none ! Input Variable - real( kind = core_rknd ), intent(in), dimension(gr%nz) :: azt + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + azt ! Variable on thermodynamic grid levels [units vary] ! Output Variable - real( kind = core_rknd ), dimension(gr%nz) :: gradzt + real( kind = core_rknd ), dimension(gr%nz) :: & + gradzt ! Vertical derivative of azt [units vary / m] ! Local Variable - integer :: k + integer :: k ! Grid level loop index - ! ---- Begin Code ---- - ! Compute vertical derivative. - forall( k = 1 : gr%nz-1 : 1 ) - ! Take derivative of thermodynamic-level variable azt over the central - ! momentum level (k). - gradzt(k) = ( azt(k+1) - azt(k) ) * gr%invrs_dzm(k) - end forall ! 1 .. gr%nz-1 + ! Set the value of the vertical derivative of a thermodynamic-level variable + ! over the momentum grid level at the uppermost level of the model. + k = gr%nz ! ! Momentum level gr%nz is located above thermodynamic level gr%nz, so ! ! there is not enough information to calculate the derivative over momentum ! ! level gr%nz. Thus, the value of the derivative at momentum level ! ! gr%nz is set equal to 0. This formulation is consistent with setting ! ! the value of the variable azt above the model grid to the value of the ! ! variable azt at the highest grid level. -! gradzt(gr%nz) = 0. +! gradzt(k) = zero ! Momentum level gr%nz is located above thermodynamic level gr%nz, so ! there is not enough information to calculate the derivative over momentum ! level gr%nz. Thus, the value of the derivative at momentum level ! gr%nz is set equal to the value of the derivative at momentum level ! gr%nz-1. This formulation is consistent with using a linear extension ! to find the values of the variable azt above the model grid. - gradzt(gr%nz) = gradzt(gr%nz-1) + gradzt(k) = ( azt(k) - azt(k-1) ) * gr%invrs_dzm(k-1) + + ! Calculate the vertical derivative of a thermodynamic-level variable + ! between two successive thermodynamic grid levels. + forall( k = 1 : gr%nz-1 : 1 ) + ! Take derivative of thermodynamic-level variable azt over the central + ! momentum level (k). + gradzt(k) = ( azt(k+1) - azt(k) ) * gr%invrs_dzm(k) + end forall ! k = 1 : gr%nz-1 : 1 + return @@ -2003,7 +2262,7 @@ pure function flip( x, xdim ) !------------------------------------------------------------------------- use clubb_precision, only: & - dp ! double precision + dp ! double precision implicit none @@ -2020,15 +2279,20 @@ pure function flip( x, xdim ) integer :: indx - ! ---- Begin Code ---- + + ! Get rid of an annoying compiler warning. + indx = 1 + indx = indx forall ( indx = 1 : xdim ) - tmp(indx) = x((xdim+1) - (indx)) + tmp(indx) = x((xdim+1) - (indx)) end forall flip = tmp + return + end function flip !=============================================================================== diff --git a/models/atm/cam/src/physics/clubb/hydromet_pdf_parameter_module.F90 b/models/atm/cam/src/physics/clubb/hydromet_pdf_parameter_module.F90 new file mode 100644 index 000000000000..7fcbd5b0fdc2 --- /dev/null +++ b/models/atm/cam/src/physics/clubb/hydromet_pdf_parameter_module.F90 @@ -0,0 +1,105 @@ +!--------------------------------------------------------------------------- +! $Id: hydromet_pdf_parameter_module.F90 7284 2014-09-11 02:52:58Z bmg2@uwm.edu $ +!=============================================================================== +module hydromet_pdf_parameter_module + + ! Description: + ! This module defines the derived type hydromet_pdf_parameter. + + ! References: + ! None + !------------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + private ! Default scope + + public :: hydromet_pdf_parameter, & ! Variable type + init_hydromet_pdf_params ! Procedure + + integer, parameter, private :: & + max_hydromet_dim = 8 + + type hydromet_pdf_parameter + + real( kind = core_rknd ), dimension(max_hydromet_dim) :: & + hm1, & ! Mean of hydrometeor, hm (1st PDF component) [un vary] + hm2, & ! Mean of hydrometeor, hm (2nd PDF component) [un vary] + mu_hm_1, & ! Mean of hm (1st PDF component) in-precip (ip) [un vary] + mu_hm_2, & ! Mean of hm (2nd PDF component) ip [un vary] + sigma_hm_1, & ! Standard deviation of hm (1st PDF comp.) ip [un vary] + sigma_hm_2, & ! Standard deviation of hm (2nd PDF comp.) ip [un vary] + corr_w_hm_1, & ! Correlation of w and hm (1st PDF component) ip [-] + corr_w_hm_2, & ! Correlation of w and hm (2nd PDF component) ip [-] + corr_chi_hm_1, & ! Correlation of chi and hm (1st PDF component) ip [-] + corr_chi_hm_2, & ! Correlation of chi and hm (2nd PDF component) ip [-] + corr_eta_hm_1, & ! Correlation of eta and hm (1st PDF component) ip [-] + corr_eta_hm_2 ! Correlation of eta and hm (2nd PDF component) ip [-] + + real( kind = core_rknd ) :: & + mu_Ncn_1, & ! Mean of Ncn (1st PDF component) [num/kg] + mu_Ncn_2, & ! Mean of Ncn (2nd PDF component) [num/kg] + sigma_Ncn_1, & ! Standard deviation of Ncn (1st PDF component) [num/kg] + sigma_Ncn_2 ! Standard deviation of Ncn (2nd PDF component) [num/kg] + + real( kind = core_rknd ) :: & + precip_frac, & ! Precipitation fraction (overall) [-] + precip_frac_1, & ! Precipitation fraction (1st PDF component) [-] + precip_frac_2 ! Precipitation fraction (2nd PDF component) [-] + + end type hydromet_pdf_parameter + +contains + + !============================================================================= + subroutine init_hydromet_pdf_params( hydromet_pdf_params ) + + ! Description: + ! Initialize the elements of hydromet_pdf_params. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + zero ! Constant(s) + + implicit none + + ! Output Variable + type(hydromet_pdf_parameter), intent(out) :: & + hydromet_pdf_params ! Hydrometeor PDF parameters [units vary] + + ! Initialize hydromet_pdf_params. + hydromet_pdf_params%hm1 = zero + hydromet_pdf_params%hm2 = zero + hydromet_pdf_params%mu_hm_1 = zero + hydromet_pdf_params%mu_hm_2 = zero + hydromet_pdf_params%sigma_hm_1 = zero + hydromet_pdf_params%sigma_hm_2 = zero + hydromet_pdf_params%corr_w_hm_1 = zero + hydromet_pdf_params%corr_w_hm_2 = zero + hydromet_pdf_params%corr_chi_hm_1 = zero + hydromet_pdf_params%corr_chi_hm_2 = zero + hydromet_pdf_params%corr_eta_hm_1 = zero + hydromet_pdf_params%corr_eta_hm_2 = zero + + hydromet_pdf_params%mu_Ncn_1 = zero + hydromet_pdf_params%mu_Ncn_2 = zero + hydromet_pdf_params%sigma_Ncn_1 = zero + hydromet_pdf_params%sigma_Ncn_2 = zero + + hydromet_pdf_params%precip_frac = zero + hydromet_pdf_params%precip_frac_1 = zero + hydromet_pdf_params%precip_frac_2 = zero + + + return + + end subroutine init_hydromet_pdf_params + +!=============================================================================== + +end module hydromet_pdf_parameter_module diff --git a/models/atm/cam/src/physics/clubb/hydrostatic_module.F90 b/models/atm/cam/src/physics/clubb/hydrostatic_module.F90 deleted file mode 100644 index 870addba95c5..000000000000 --- a/models/atm/cam/src/physics/clubb/hydrostatic_module.F90 +++ /dev/null @@ -1,746 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: hydrostatic_module.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -!=============================================================================== -module hydrostatic_module - - implicit none - - private ! Default Scope - - public :: hydrostatic, & - inverse_hydrostatic - - private :: calc_exner_const_thvm, & - calc_exner_linear_thvm, & - calc_z_linear_thvm - - contains - -!=============================================================================== - subroutine hydrostatic( thvm, p_sfc, & - p_in_Pa, p_in_Pa_zm, & - exner, exner_zm, & - rho, rho_zm ) - - ! Description: - ! This subroutine integrates the hydrostatic equation. - ! - ! The hydrostatic equation is of the form: - ! - ! dp/dz = - rho * grav. - ! - ! This equation can be re-written in terms of d(exner)/dz, such that: - ! - ! [ { p0^(R_d/C_p) * p^(C_v/C_p) } / { R_d * rho } ] * d(exner)/dz - ! = - grav / C_p; - ! - ! which can also be expressed as: - ! - ! [ { p0^(R_d/C_p) * p^(C_v/C_p) } / { R_d * rho_d * ( 1 + r_v + r_c ) } ] - ! * d(exner)/dz - ! = - grav / C_p. - ! - ! Furthermore, the moist equation of state can be written as: - ! - ! theta = - ! [ { p0^(R_d/C_p) * p^(C_v/C_p) } - ! / { R_d * rho_d * ( 1 + (R_v/R_d)*r_v ) } ]. - ! - ! The relationship between theta and theta_v (including water vapor and - ! cloud water) is: - ! - ! theta_v = theta * [ ( 1 + (R_v/R_d)*r_v ) / ( 1 + r_v + r_c ) ]; - ! - ! which, when substituted into the above equation, changes the equation of - ! state to: - ! - ! theta_v = - ! [ { p0^(R_d/C_p) * p^(C_v/C_p) } - ! / { R_d * rho_d * ( 1 + r_v + r_c ) } ]. - ! - ! This equation is substituted into the d(exner)/dz form of the hydrostatic - ! equation, resulting in: - ! - ! theta_v * d(exner)/dz = - grav / C_p; - ! - ! which can be re-written as: - ! - ! d(exner)/dz = - grav / ( C_p * theta_v ). - ! - ! This subroutine integrates the above equation to solve for exner, such - ! that: - ! - ! INT(exner_1:exner_2) d(exner) = - ! - ( grav / C_p ) * INT(z_1:z_2) ( 1 / theta_v ) dz. - ! - ! - ! The resulting value of exner is used to calculate pressure. Then, the - ! values of pressure, exner, and theta_v can be used to calculate density. - - ! References: - ! - !------------------------------------------------------------------------ - - use constants_clubb, only: & - kappa, & ! Variable(s) - p0, & - Rd, & - zero_threshold - - use grid_class, only: & - gr, & ! Variable(s) - zm2zt, & ! Procedure(s) - zt2zm - - use clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! Input Variables - real( kind = core_rknd ), intent(in) :: & - p_sfc ! Pressure at the surface [Pa] - - real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & - thvm ! Virtual potential temperature [K] - - ! Output Variables - real( kind = core_rknd ), intent(out), dimension(gr%nz) :: & - p_in_Pa, & ! Pressure (thermodynamic levels) [Pa] - p_in_Pa_zm, & ! Pressure on momentum levels [Pa] - exner, & ! Exner function (thermodynamic levels) [-] - exner_zm, & ! Exner function on momentum levels [-] - rho, & ! Density (thermodynamic levels) [kg/m^3] - rho_zm ! Density on momentum levels [kg/m^3] - - ! Local Variables - real( kind = core_rknd ), dimension(gr%nz) :: & - thvm_zm ! Theta_v interpolated to momentum levels [K] - - real( kind = core_rknd ) :: & - dthvm_dz ! Constant d(thvm)/dz between successive levels [K/m] - - integer :: k - - ! Interpolate thvm from thermodynamic to momentum levels. Linear - ! interpolation is used, except for the uppermost momentum level, where a - ! linear extension is used. Since thvm is considered to either be constant - ! or vary linearly over the depth of a grid level, this interpolation is - ! consistent with the rest of this code. - thvm_zm = zt2zm( thvm ) - - ! Exner is defined on thermodynamic grid levels except for the value at - ! index 1. Since thermodynamic level 1 is below the surface, it is - ! disregarded, and the value of exner(1) corresponds to surface value, which - ! is actually at momentum level 1. - exner(1) = ( p_sfc/p0 )**kappa - exner_zm(1) = ( p_sfc/p0 )**kappa - - ! Consider the value of exner at thermodynamic level (2) to be based on - ! a constant thvm between thermodynamic level (2) and momentum level (1), - ! which is the surface or model lower boundary. Since thlm(1) is set equal - ! to thlm(2), the values of thvm are considered to be basically constant - ! near the ground. - exner(2) & - = calc_exner_const_thvm( thvm(2), gr%zt(2), gr%zm(1), exner(1) ) - - ! Given the value of exner at thermodynamic level k-1, and considering - ! thvm to vary linearly between its values at thermodynamic levels k - ! and k-1, the value of exner can be found at thermodynamic level k, - ! as well as at intermediate momentum level k-1. - do k = 3, gr%nz - - dthvm_dz = gr%invrs_dzm(k-1) * ( thvm(k) - thvm(k-1) ) - - if ( dthvm_dz /= 0.0_core_rknd ) then - - exner(k) & - = calc_exner_linear_thvm( thvm(k-1), dthvm_dz, & - gr%zt(k-1), gr%zt(k), exner(k-1) ) - - exner_zm(k-1) & - = calc_exner_linear_thvm( thvm(k-1), dthvm_dz, & - gr%zt(k-1), gr%zm(k-1), exner(k-1) ) - - else ! dthvm_dz = 0 - - exner(k) & - = calc_exner_const_thvm & - ( thvm(k), gr%zt(k), gr%zt(k-1), exner(k-1) ) - - exner_zm(k-1) & - = calc_exner_const_thvm & - ( thvm(k), gr%zm(k-1), gr%zt(k-1), exner(k-1) ) - - endif - - enddo ! k = 3, gr%nz - - ! Find the value of exner_zm at momentum level gr%nz by using a linear - ! extension of thvm from the two thermodynamic level immediately below - ! momentum level gr%nz. - dthvm_dz = ( thvm_zm(gr%nz) - thvm(gr%nz) ) & - / ( gr%zm(gr%nz) - gr%zt(gr%nz) ) - - if ( dthvm_dz /= 0.0_core_rknd ) then - - exner_zm(gr%nz) & - = calc_exner_linear_thvm & - ( thvm(gr%nz), dthvm_dz, & - gr%zt(gr%nz), gr%zm(gr%nz), exner(gr%nz) ) - - else ! dthvm_dz = 0 - - exner_zm(gr%nz) & - = calc_exner_const_thvm & - ( thvm(gr%nz), gr%zm(gr%nz), gr%zt(gr%nz), exner(gr%nz) ) - - endif - - ! Calculate pressure based on the values of exner. - - do k = 1, gr%nz - p_in_Pa(k) = p0 * exner(k)**( 1._core_rknd/kappa ) - p_in_Pa_zm(k) = p0 * exner_zm(k)**( 1._core_rknd/kappa ) - enddo - - ! Calculate density based on pressure, exner, and thvm. - - do k = 1, gr%nz - rho(k) = p_in_Pa(k) / ( Rd * thvm(k) * exner(k) ) - rho_zm(k) = p_in_Pa_zm(k) / ( Rd * thvm_zm(k) * exner_zm(k) ) - enddo - - - return - end subroutine hydrostatic - -!=============================================================================== - subroutine inverse_hydrostatic( p_sfc, zm_init, nlevels, thvm, exner, & - z ) - - ! Description: - ! Subprogram to integrate the inverse of hydrostatic equation - - ! References: - ! - !------------------------------------------------------------------------ - - use constants_clubb, only: & - p0, & ! Constant(s) - kappa, & - fstderr - - use interpolation, only: & - binary_search ! Procedure(s) - - use clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! Input Variables - real( kind = core_rknd ), intent(in) :: & - p_sfc, & ! Pressure at the surface [Pa] - zm_init ! Altitude at the surface [m] - - integer, intent(in) :: & - nlevels ! Number of levels in the sounding [-] - - real( kind = core_rknd ), intent(in), dimension(nlevels) :: & - thvm, & ! Virtual potential temperature [K] - exner ! Exner function [-] - - ! Output Variables - real( kind = core_rknd ), intent(out), dimension(nlevels) :: & - z ! Height [m] - - ! Local Variables - integer :: k - - real( kind = core_rknd ), dimension(nlevels) :: & - ref_z_snd ! Altitude minus altitude of the lowest sounding level [m] - - real( kind = core_rknd ), dimension(nlevels) :: & - exner_reverse_array ! Array of exner snd. values in reverse order [-] - - real( kind = core_rknd ) :: & - exner_sfc, & ! Value of exner at the surface [-] - ref_z_sfc, & ! Alt. diff between surface and lowest snd. level [m] - z_snd_bottom, & ! Altitude of the bottom of the input sounding [m] - dthvm_dexner ! Constant rate of change of thvm with respect to - ! exner between sounding levels k-1 and k [K] - - integer :: & - rev_low_idx, & - low_idx, & - high_idx - - - ! Variable ref_z_sfc is initialized to 0.0 to avoid a compiler warning. - ref_z_sfc = 0.0_core_rknd - - ! The variable ref_z_snd is the altitude of each sounding level compared to - ! the altitude of the lowest sounding level. Thus, the value of ref_z_snd - ! at sounding level 1 is 0. The lowest sounding level may or may not be - ! right at the surface, and therefore an adjustment may be required to find - ! the actual altitude above ground. - ref_z_snd(1) = 0.0_core_rknd - - do k = 2, nlevels - - ! The value of thvm is given at two successive sounding levels. For - ! purposes of achieving a quality estimate of altitude at each pressure - ! sounding level, the value of thvm is considered to vary linearly - ! with respect to exner between two successive sounding levels. Thus, - ! there is a constant d(thvm)/d(exner) between the two successive - ! sounding levels. If thvm is constant, then d(thvm)/d(exner) is 0. - dthvm_dexner = ( thvm(k) - thvm(k-1) ) / ( exner(k) - exner(k-1) ) - - ! Calculate the value of the reference height at sounding level k, based - ! the value of thvm at sounding level k-1, the constant value of - ! d(thvm)/d(exner), the value of exner at sounding levels k-1 and k, and - ! the reference altitude at sounding level k-1. - ref_z_snd(k) & - = calc_z_linear_thvm( thvm(k-1), dthvm_dexner, & - exner(k-1), exner(k), ref_z_snd(k-1) ) - - enddo - - ! Find the actual (above ground) altitude of the sounding levels from the - ! reference altitudes. - - ! The pressure at the surface (or model lower boundary), p_sfc, is found at - ! the altitude of the surface (or model lower boundary), zm_init. - - ! Find the value of exner at the surface from the pressure at the surface. - exner_sfc = ( p_sfc / p0 )**kappa - - ! Find the value of exner_sfc compared to the values of exner in the exner - ! sounding profile. - - if ( exner_sfc < exner(nlevels) ) then - - ! Since the values of exner decrease monotonically with height (and thus - ! with sounding level), the value of exner_sfc is less than all the - ! values of exner in the sounding (and thus the surface is located above - ! all the levels of the sounding), then there is insufficient information - ! to run the model. Stop the run. - - write(fstderr,*) "The entire sounding is below the model surface." - stop - - elseif ( exner_sfc > exner(1) ) then - - ! Since the values of exner decrease monotonically with height (and thus - ! with sounding level), the value of exner_sfc is greater than all the - ! values of exner in the sounding (and thus the surface is located below - ! all the levels of the sounding), use a linear extension of thvm to find - ! thvm at the surface. Thus, d(thvm)/d(exner) is the same as its value - ! between sounding levels 1 and 2. If the surface is so far below the - ! sounding that gr%zt(2) is below the first sounding level, the code in - ! subroutine read_sounding (found in sounding.F90) will stop the run. - - ! Calculate the appropriate d(thvm)/d(exner). - dthvm_dexner = ( thvm(2) - thvm(1) ) / ( exner(2) - exner(1) ) - - ! Calculate the difference between the altitude of the surface (or model - ! lower boundary) and the altitude of the lowest level of the sounding. - ref_z_sfc & - = calc_z_linear_thvm( thvm(1), dthvm_dexner, & - exner(1), exner_sfc, ref_z_snd(1) ) - - else ! exner(nlevels) < exner_sfc < exner(1) - - ! Since the values of exner decrease monotonically with height (and thus - ! with sounding level), the value of exner_sfc is between two values of - ! exner (at some levels k-1 and k) in the sounding, and the value of - ! d(thvm)/d(exner) is the same as between those two levels in the above - ! calculation. - - ! The value of exner_sfc is between two levels of the exner sounding. - ! Find the index of the lower level. - - ! In order to use the binary search, the array must be sorted from least - ! value to greatest value. Since exner decreases with altitude (and - ! vertical level), the array that is sent to function binary_search must - ! be the exact reverse of exner. - ! Thus, exner(1) becomes exner_reverse_array(nlevels), exner(nlevels) - ! becomes exner_reverse_array(1), etc. - do k = 1, nlevels, 1 - exner_reverse_array(k) = exner(nlevels-k+1) - enddo - ! The output from the binary search yields the first value in the - ! exner_reverse_array that is greater than or equal to exner_sfc. Thus, - ! in regards to the regular exner array, this is the reverse index of - ! the lower sounding level for exner_sfc. For example, if exner_sfc - ! is found between exner(1) and exner(2), the binary search for exner_sfc - ! in regards to exner_reverse_index will return a value of nlevels. - ! Once the actual lower level index is calculated, the result will be 1. - rev_low_idx = binary_search( nlevels, exner_reverse_array, exner_sfc ) - - ! Find the lower level index for the regular exner profile from the - ! lower level index for the reverse exner profile. - low_idx = nlevels - rev_low_idx + 1 - - ! Find the index of the upper level. - high_idx = low_idx + 1 - - ! Calculate the appropriate d(thvm)/d(exner). - dthvm_dexner = ( thvm(high_idx) - thvm(low_idx) ) & - / ( exner(high_idx) - exner(low_idx) ) - - ! Calculate the difference between the altitude of the surface (or model - ! lower boundary) and the altitude of the lowest level of the sounding. - ref_z_sfc & - = calc_z_linear_thvm( thvm(low_idx), dthvm_dexner, & - exner(low_idx), exner_sfc, ref_z_snd(low_idx) ) - - endif ! exner_sfc - - ! Find the altitude of the bottom of the sounding. - z_snd_bottom = zm_init - ref_z_sfc - - ! Calculate the sounding altitude profile based - ! on z_snd_bottom and ref_z_snd. - do k = 1, nlevels, 1 - z(k) = z_snd_bottom + ref_z_snd(k) - enddo - - - return - end subroutine inverse_hydrostatic - -!=============================================================================== - pure function calc_exner_const_thvm( thvm, z_2, z_1, exner_1 ) & - result( exner_2 ) - - ! Description: - ! This function solves for exner at a level, given exner at another level, - ! the altitudes of both levels, and a constant thvm over the depth of the - ! level. - ! - ! The derivative of exner is given by the following equation: - ! - ! d(exner)/dz = - grav / (Cp * thvm). - ! - ! This equation is integrated to solve for exner, such that: - ! - ! INT(exner_1:exner_2) d(exner) - ! = - ( grav / Cp ) INT(z_1:z_2) (1/thvm) dz. - ! - ! Since thvm is considered to be a constant over the depth of the layer - ! between z_1 and z_2, the equation can be written as: - ! - ! INT(exner_1:exner_2) d(exner) = - grav / ( Cp * thvm ) INT(z_1:z_2) dz. - ! - ! Solving the integral: - ! - ! exner_2 = exner_1 - [ grav / ( Cp * thvm ) ] * ( z_2 - z_1 ). - - ! References: - !------------------------------------------------------------------- - - use constants_clubb, only: & - grav, & ! Gravitational acceleration [m/s^2] - Cp ! Specific heat of dry air at const. pressure [J/(kg*K)] - - use clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! Input Variables - real( kind = core_rknd ), intent(in) :: & - thvm, & ! Constant value of thvm over the layer [K] - z_2, & ! Altitude at the top of the layer [m] - z_1, & ! Altitude at the bottom of the layer [m] - exner_1 ! Exner at the bottom of the layer [-] - - ! Return Variable - real( kind = core_rknd ) :: exner_2 ! Exner at the top of the layer [-] - - ! Calculate exner at top of the layer. - exner_2 = exner_1 - ( grav / ( Cp * thvm ) ) * ( z_2 - z_1 ) - - return - end function calc_exner_const_thvm - -!=============================================================================== - pure function calc_exner_linear_thvm( thvm_km1, dthvm_dz, & - z_km1, z_2, exner_km1 ) & - result( exner_2 ) - - ! Description: - ! This function solves for exner at a level, given exner at another level, - ! the altitudes of both levels, and a value of thvm that is considered to - ! vary linearly over the depth of the level. - ! - ! The derivative of exner is given by the following equation: - ! - ! d(exner)/dz = - grav / (Cp * thvm). - ! - ! This equation is integrated to solve for exner, such that: - ! - ! INT(exner_1:exner_2) d(exner) - ! = - ( grav / Cp ) INT(z_1:z_2) (1/thvm) dz. - ! - ! The value of thvm is considered to vary linearly (with respect to height) - ! over the depth of the level (resulting in a constant d(thvm)/dz over the - ! depth of the level). The entire level between z_1 and z_2 must be - ! encompassed between two levels with two known values of thvm. The value - ! of thvm at the upper level (z_up) is called thvm_up, and the value of thvm - ! at the lower level (z_low) is called thvm_low. Again, the values of thvm - ! at all interior altitudes, z_low <= z_1 < z <= z_2 <= z_up, behave - ! linearly between thvm_low and thvm_up, such that: - ! - ! thvm(z) - ! = [ ( thvm_up - thvm_low ) / ( z_up - z_low ) ] * ( z - z_low) - ! + thvm_low - ! = [ d(thvm)/dz ] * ( z - z_low ) + thvm_low - ! = C_a*z + C_b; - ! - ! where: - ! - ! C_a - ! = ( thvm_up - thvm_low ) / ( z_up - z_low ) - ! = d(thvm)/dz; - ! - ! and: - ! - ! C_b - ! = thvm_low - [ ( thvm_up - thvm_low ) / ( z_up - z_low ) ] * z_low - ! = thvm_low - [ d(thvm)/dz ] * z_low. - ! - ! The integral becomes: - ! - ! INT(exner_1:exner_2) d(exner) - ! = - ( grav / Cp ) INT(z_1:z_2) [ 1 / ( C_a*z + C_b ) ] dz. - ! - ! Performing a u-substitution ( u = C_a*z + C_b ), the equation becomes: - ! - ! INT(exner_1:exner_2) d(exner) - ! = - ( grav / Cp ) * ( 1 / C_a ) INT(z=z_1:z=z_2) (1/u) du. - ! - ! Solving the integral, and then re-substituting for u: - ! - ! exner_2 = exner_1 - ! - ( grav / Cp ) * ( 1 / C_a ) - ! * ln [ ( C_a*z_2 + C_b ) / ( C_a*z_1 + C_b ) ]. - ! - ! Re-substituting for C_a and C_b: - ! - ! exner_2 - ! = exner_1 - ! - ( grav / Cp ) * ( 1 / {d(thvm)/dz} ) - ! * ln [ ( {d(thvm)/dz}*z_2 + thvm_low - {d(thvm)/dz}*z_low ) - ! / ( {d(thvm)/dz}*z_1 + thvm_low - {d(thvm)/dz}*z_low ) ]. - ! - ! This equation is used to calculate exner_2 using exner_1, which is at the - ! same level as z_1. Furthermore, thvm_low and z_low are taken from the - ! same level as z_1 and exner_1. Thus, z_1 = z_low. Therefore: - ! - ! exner_2 - ! = exner_low - ! - ( grav / Cp ) * ( 1 / {d(thvm)/dz} ) - ! * ln [ ( thvm_low + {d(thvm)/dz}*(z_2-z_low) ) / thvm_low ]. - ! - ! Considering either a thermodynamic or sounding level k-1 as the low level - ! in the integration, and that thvm varies linearly between level k-1 and - ! level k: - ! - ! exner_2 - ! = exner(k-1) - ! - ( grav / Cp ) * ( 1 / {d(thvm)/dz} ) - ! * ln [ ( thvm(k-1) + {d(thvm)/dz}*(z_2-z(k-1)) ) / thvm(k-1) ]; - ! - ! where: - ! - ! d(thvm)/dz = ( thvm(k) - thvm(k-1) ) / ( z(k) - z(k-1) ); - ! - ! and where z(k-1) < z_2 <= z(k); and {d(thvm)/dz} /= 0. If the value of - ! {d(thvm)/dz} is 0, then thvm is considered to be a constant over the depth - ! of the level. The appropriate equation is found in pure function - ! calc_exner_const_thvm. - - ! References: - !------------------------------------------------------------------- - - use clubb_precision, only: & - core_rknd ! Variable(s) - - use constants_clubb, only: & - grav, & ! Gravitational acceleration [m/s^2] - Cp ! Specific heat of dry air at const. pressure [J/(kg*K)] - - implicit none - - ! Input Variables - real( kind = core_rknd ), intent(in) :: & - thvm_km1, & ! Value of thvm at level k-1 [K] - dthvm_dz, & ! Constant d(thvm)/dz between levels k-1 and k [K/m] - z_km1, & ! Altitude at level k-1 [m] - z_2, & ! Altitude at the top of the layer [m] - exner_km1 ! Exner at level k-1 [-] - - ! Return Variable - real( kind = core_rknd ) :: exner_2 ! Exner at the top of the layer [-] - - ! Calculate exner at the top of the layer. - exner_2 & - = exner_km1 & - - ( grav / Cp ) * ( 1.0_core_rknd / dthvm_dz ) & - * log( ( thvm_km1 + dthvm_dz * ( z_2 - z_km1 ) ) / thvm_km1 ) - - return - end function calc_exner_linear_thvm - -!=============================================================================== - pure function calc_z_linear_thvm( thvm_km1, dthvm_dexner, & - exner_km1, exner_2, z_km1 ) & - result( z_2 ) - - ! Description: - ! This function solves for z (altitude) at a level, given altitude at - ! another level, the values of exner at both levels, and a value of thvm - ! that is considered to vary linearly over the depth of the level. - ! - ! The derivative of exner is given by the following equation: - ! - ! d(exner)/dz = - grav / (Cp * thvm). - ! - ! This equation is integrated to solve for z, such that: - ! - ! INT(exner_1:exner_2) thvm d(exner) = - ( grav / Cp ) INT(z_1:z_2) dz. - ! - ! The value of thvm is considered to vary linearly (with respect to exner) - ! over the depth of the level (resulting in a constant d(thvm)/d(exner) over - ! the depth of the level). The entire level between exner_1 and exner_2 - ! must be encompassed between two levels with two known values of thvm. The - ! value of thvm at the upper level (exner_up) is called thvm_up, and the - ! value of thvm at the lower level (exner_low) is called thvm_low. Again, - ! the values of thvm at all interior exner levels, - ! exner_low >= exner_1 > exner >= exner_2 >= exner_up, behave linearly - ! between thvm_low and thvm_up, such that: - ! - ! thvm(exner) - ! = [ ( thvm_up - thvm_low ) / ( exner_up - exner_low ) ] - ! * ( exner - exner_low ) - ! + thvm_low - ! = [ d(thvm)/d(exner) ] * ( exner - exner_low ) + thvm_low - ! = C_a*z + C_b; - ! - ! where: - ! - ! C_a - ! = ( thvm_up - thvm_low ) / ( exner_up - exner_low ) - ! = d(thvm)/d(exner); - ! - ! and: - ! - ! C_b - ! = thvm_low - ! - [ ( thvm_up - thvm_low ) / ( exner_up - exner_low ) ] * exner_low - ! = thvm_low - [ d(thvm)/d(exner) ] * exner_low. - ! - ! The integral becomes: - ! - ! INT(exner_1:exner_2) ( C_a*exner + C_b ) d(exner) - ! = - ( grav / Cp ) INT(z_1:z_2) dz. - ! - ! Solving the integral: - ! - ! z_2 - ! = z_1 - ! - ( Cp / grav ) - ! * [ (1/2) * {d(thvm)/d(exner)} * ( {exner_2}^2 - {exner_1}^2 ) - ! + ( thvm_low - {d(thvm)/d(exner)} * exner_low ) - ! * ( exner_2 - exner_1 ) ]. - ! - ! This equation is used to calculate z_2 using z_1, which is at the same - ! level as exner_1. Furthermore, thvm_low and exner_low are taken from the - ! same level as exner_1 and z_1. Thus, exner_1 = exner_low. Therefore: - ! - ! z_2 - ! = z_low - ! - ( Cp / grav ) - ! * [ (1/2) * {d(thvm)/d(exner)} * ( {exner_2}^2 - {exner_low}^2 ) - ! + ( thvm_low - {d(thvm)/d(exner)} * exner_low ) - ! * ( exner_2 - exner_low ) ]. - ! - ! Considering a sounding level k-1 as the low level in the integration, and - ! that thvm varies linearly (with respect to exner) between level k-1 and - ! level k: - ! - ! z_2 - ! = z(k-1) - ! - ( Cp / grav ) - ! * [ (1/2) * {d(thvm)/d(exner)} * ( {exner_2}^2 - {exner(k-1)}^2 ) - ! + ( thvm(k-1) - {d(thvm)/d(exner)} * exner(k-1) ) - ! * ( exner_2 - exner(k-1) ) ]; - ! - ! where: - ! - ! d(thvm)/d(exner) - ! = ( thvm(k) - thvm(k-1) ) / ( exner(k) - exner(k-1) ); - ! - ! and where exner(k-1) > exner_2 >= exner(k). If the value of - ! d(thvm)/d(exner) is 0, then thvm is considered to be a constant over the - ! depth of the level, and the equation will reduce to: - ! - ! z_2 = z(k-1) - ( Cp / grav ) * thvm(k-1) * ( exner_2 - exner(k-1) ). - ! - ! - ! IMPORTANT NOTE: - ! - ! CLUBB is an altitude-based model. All linear interpolations (and - ! extensions) are based on considering a variable to change linearly with - ! respect to altitude, rather than with respect to exner. An exception is - ! made here to calculate the altitude of a sounding level based on a - ! sounding given in terms of a pressure coordinate rather than a height - ! coordinate. After the altitude of the sounding level has been calculated, - ! the values of the sounding variables are interpolated onto the model grid - ! linearly with respect to altitude. Therefore, considering a variable to - ! change linearly with respect to exner is not consistent with the rest of - ! the model code, but provides for a better estimation of the altitude of - ! the sounding levels (than simply considering thvm to be constant over the - ! depth of the sounding level). - - ! References: - !------------------------------------------------------------------- - - use clubb_precision, only: & - core_rknd ! Variable(s) - - use constants_clubb, only: & - grav, & ! Gravitational acceleration [m/s^2] - Cp ! Specific heat of dry air at const. pressure [J/(kg*K)] - - implicit none - - ! Input Variables - real( kind = core_rknd ), intent(in) :: & - thvm_km1, & ! Value of thvm at sounding level k-1 [K] - dthvm_dexner, & ! Constant d(thvm)/d(exner) between levels k-1 and k [K] - exner_km1, & ! Value of exner at sounding level k-1 [-] - exner_2, & ! Value of exner at the top of the layer [-] - z_km1 ! Altitude at sounding level k-1 [m] - - ! Return Variable - real( kind = core_rknd ) :: z_2 ! Altitude at the top of the layer [m] - - ! Calculate z_2 at the top of the layer. - z_2 & - = z_km1 & - - ( Cp / grav ) & - * ( 0.5_core_rknd * dthvm_dexner * ( exner_2**2 - exner_km1**2 ) & - + ( thvm_km1 - dthvm_dexner * exner_km1 ) & - * ( exner_2 - exner_km1 ) & - ) - - return - end function calc_z_linear_thvm - -!=============================================================================== - -end module hydrostatic_module diff --git a/models/atm/cam/src/physics/clubb/hyper_diffusion_4th_ord.F90 b/models/atm/cam/src/physics/clubb/hyper_diffusion_4th_ord.F90 deleted file mode 100644 index a43ac9d7d851..000000000000 --- a/models/atm/cam/src/physics/clubb/hyper_diffusion_4th_ord.F90 +++ /dev/null @@ -1,1685 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: hyper_diffusion_4th_ord.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -!=============================================================================== -module hyper_diffusion_4th_ord - - ! Description: - ! Module hyper_diffusion_4th_ord computes the 4th-order numerical diffusion - ! for any equation to which it is applied. Hyper-diffusion will only be - ! called if the model flag l_hyper_dfsn is set to true. Function - ! hyper_dfsn_4th_ord_zt_lhs handles 4th-order hyper-diffusion for variables - ! that reside on thermodynamic levels. Function hyper_dfsn_4th_ord_zm_lhs - ! handles 4th-order hyper-diffusion for variables that reside on momentum - ! levels. A special constant coefficient of 4th-order numerical diffusion, - ! nu_hd (which is sent in this module as nu), is used and has units of m^4/s. - - implicit none - - private ! Default Scope - - public :: hyper_dfsn_4th_ord_zt_lhs, & - hyper_dfsn_4th_ord_zm_lhs - - contains - - !============================================================================= - pure function hyper_dfsn_4th_ord_zt_lhs( boundary_cond, nu, invrs_dzt, & - invrs_dzm, invrs_dzmm1, & - invrs_dztp1, invrs_dztm1, & - invrs_dzmp1, invrs_dzmm2, level ) & - result( lhs ) - - ! Note: In the "Description" section of this function, the variable - ! "invrs_dzm" will be written as simply "dzm", and the variable - ! "invrs_dzt" will be written as simply "dzt". This is being done as - ! as device to save space and to make some parts of the description - ! more readable. This change does not pertain to the actual code. - - ! Description: - ! Vertical 4th-order numerical diffusion of var_zt: implicit portion of the - ! code. - ! - ! Fourth-order numerical diffusion, or fourth-order hyper-diffusion, is used - ! to help eliminate small-scale noise without altering larger-scale - ! features. - ! - ! The variable "var_zt" stands for a variable that is located at - ! thermodynamic grid levels. - ! - ! The d(var_zt)/dt equation contains a 4th-order numerical diffusion term: - ! - ! - nu * d^4(var_zt)/dz^4. - ! - ! This term is solved for completely implicitly, such that: - ! - ! - nu * d^4( var_zt(t+1) )/dz^4. - ! - ! Note: When the term is brought over to the left-hand side, the sign - ! is reversed and the leading "-" in front of the term is changed - ! to a "+". - ! - ! The timestep index (t+1) means that the value of var_zt being used is from - ! the next timestep, which is being advanced to in solving the d(var_zt)/dt - ! equation. - ! - ! The term is discretized as follows: - ! - ! The five values of var_zt are found on the thermodynamic levels. All four - ! derivatives (d/dz) of var_zt are taken over all the intermediate momentum - ! levels. Then, all three derivatives (d/dz) of d(var_zt)/dz are taken over - ! all the intermediate thermodynamic levels, which results in the second - ! derivatives. Then, both derivatives (d/dz) of d^2(var_zt)/dz^2 are taken - ! over the intermediate momentum levels, which results in the third - ! derivatives. Finally, the derivative (d/dz) of d^3(var_zt)/dz^3 is taken - ! over the intermediate (central) thermodynamic level, which results in the - ! fourth derivative. At the central thermodynamic level, d^4(var_zt)/dz^4 - ! is multiplied by constant coefficient nu. - ! - ! --var_ztp2----------------------------------------------- t(k+2) - ! - ! ======d(var_zt)/dz======================================= m(k+1) - ! - ! --var_ztp1----d^2(var_zt)/dz^2--------------------------- t(k+1) - ! - ! ======d(var_zt)/dz========d^3(var_zt)/dz^3=============== m(k) - ! - ! --var_zt------d^2(var_zt)/dz^2--------d^4(var_zt)/dz^4--- t(k) - ! - ! ======d(var_zt)/dz========d^3(var_zt)/dz^3=============== m(k-1) - ! - ! --var_ztm1----d^2(var_zt)/dz^2--------------------------- t(k-1) - ! - ! ======d(var_zt)/dz======================================= m(k-2) - ! - ! --var_ztm2----------------------------------------------- t(k-2) - ! - ! The vertical indices t(k+2), m(k+1), t(k+1), m(k), t(k), m(k-1), t(k-1), - ! m(k-2), and t(k-2) correspond with altitudes zt(k+2), zm(k+1), zt(k+1), - ! zm(k), zt(k), zm(k-1), zt(k-1), zm(k-2), and zt(k-2) respectively. The - ! letter "t" is used for thermodynamic levels and the letter "m" is used for - ! momentum levels. - ! - ! dzt(k) = 1 / ( zm(k) - zm(k-1) ) - ! dzm(k) = 1 / ( zt(k+1) - zt(k) ) - ! dzm(k-1) = 1 / ( zt(k) - zt(k-1) ) - ! dzt(k+1) = 1 / ( zm(k+1) - zm(k) ) - ! dzt(k-1) = 1 / ( zm(k-1) - zm(k-2) ) - ! dzm(k+1) = 1 / ( zt(k+2) - zt(k+1) ) - ! dzm(k-2) = 1 / ( zt(k-1) - zt(k-2) ) - ! - ! The discretization of -nu*d^4(var_zt)/dz^4 at thermodynamic level (k) - ! is written out as follows: - ! - ! -nu - ! *dzt(k)*[ dzm(k)*{ dzt(k+1)*( dzm(k+1)*(var_zt(k+2)-var_zt(k+1)) - ! -dzm(k)*(var_zt(k+1)-var_zt(k)) ) - ! -dzt(k)*( dzm(k)*(var_zt(k+1)-var_zt(k)) - ! -dzm(k-1)*(var_zt(k)-var_zt(k-1)) ) } - ! -dzm(k-1)*{ dzt(k)*( dzm(k)*(var_zt(k+1)-var_zt(k)) - ! -dzm(k-1)*(var_zt(k)-var_zt(k-1)) ) - ! -dzt(k-1)*( dzm(k-1)*(var_zt(k)-var_zt(k-1)) - ! -dzm(k-2)*(var_zt(k-1)-var_zt(k-2)) ) } ]. - ! - ! Again, the term is treated completely implicitly, so the leading "-" sign - ! changes to a "+" sign when the term is brought over to the left-hand side, - ! and var_zt is considered to be at timestep (t+1). - ! - ! - ! Boundary Conditions: - ! - ! 1) Zero-flux boundary conditions. - ! This function is set up to use zero-flux boundary conditions at both - ! the lower boundary level and the upper boundary level. The flux, F, - ! is the amount of var_zt flowing normal through the boundary per unit - ! time per unit surface area. The derivative of the flux effects the - ! time-tendency of var_zt, such that: - ! - ! d(var_zt)/dt = -dF/dz. - ! - ! For the 4th-order numerical diffusion term, -nu*d^4(var_zt)/dz^4 (which - ! is actually -d[nu*d^3(var_zt)/dz^3]/dz with a constant coefficient, - ! nu), the flux is: - ! - ! F = +nu*d^3(var_zt)/dz^3. - ! - ! In order to have zero-flux boundary conditions, the third derivative of - ! var_zt, d^3(var_zt)/dz^3, needs to equal 0 at both the lower boundary - ! and the upper boundary. - ! - ! Fourth-order numerical diffusion is used in conjunction with - ! second-order eddy diffusion, +d[(K_zm+nu)*d(var_zt)/dz]/dz, where the - ! coefficient of eddy diffusivity, (K_zm+nu), varies in the vertical. - ! Both 4th-order numerical diffusion and 2nd-order eddy diffusion use the - ! same boundary condition type at all times, which in this case is - ! zero-flux boundary conditions. For 2nd-order eddy diffusion, the flux - ! is: F = -(K_zm+nu)*d(var_zt)/dz. In order to have zero-flux boundary - ! conditions, the derivative of var_zt, d(var_zt)/dz, needs to equal 0 at - ! both the lower boundary and the upper boundary. - ! - ! Thus, the boundary conditions used for 4th-order numerical diffusion - ! are: d^3(var_zt)/dz^3 = 0 and d(var_zt)/dz = 0 at both the upper - ! boundary and the lower boundary, resulting in four boundary conditions, - ! which is the number of boundary conditions needed for a 4th-order term. - ! - ! In order to discretize the lower boundary condition, consider a new - ! level outside the model (thermodynamic level 0) just below the lower - ! boundary level (thermodynamic level 1). The value of var_zt at the - ! level just outside the model is defined to be the same as the value of - ! var_zt at the lower boundary level. Therefore, the value of - ! d(var_zt)/dz between the level just outside the model and the lower - ! boundary level is 0, satisfying one of the boundary conditions. The - ! boundary condition d^3(var_zt)/dz^3 = 0 is also set at this level. The - ! rest of the levels involved are discretized normally, as listed above. - ! - ! Since the normal discretization includes two levels on either side of - ! the central level, the lower boundary begins to effect the - ! discretization at thermodynamic level 2. - ! - ! -var_zt(4)----------------------------------------------- t(4) - ! - ! ======d(var_zt)/dz======================================= m(3) - ! - ! -var_zt(3)----d^2(var_zt)/dz^2--------------------------- t(3) - ! - ! ======d(var_zt)/dz========d^3(var_zt)/dz^3=============== m(2) - ! - ! -var_zt(2)----d^2(var_zt)/dz^2--------d^4(var_zt)/dz^4--- t(2) - ! - ! ======d(var_zt)/dz========d^3(var_zt)/dz^3=============== m(1) - ! - ! -var_zt(1)----d^2(var_zt)/dz^2--------------------------- t(1) Boundary - ! - ! ======[d(var_zt)/dz = 0]================================= m(0) - ! - ! -[var_zt(0) = var_zt(1)]-----(level outside model)------- t(0) - ! - ! The discretization of -nu*d^4(var_zt)/dz^4 at thermodynamic level (k=2) - ! is written out as follows: - ! - ! -nu - ! *dzt(k)*[ dzm(k)*{ dzt(k+1)*( dzm(k+1)*(var_zt(k+2)-var_zt(k+1)) - ! -dzm(k)*(var_zt(k+1)-var_zt(k)) ) - ! -dzt(k)*( dzm(k)*(var_zt(k+1)-var_zt(k)) - ! -dzm(k-1)*(var_zt(k)-var_zt(k-1)) ) } - ! -dzm(k-1)*{ dzt(k)*( dzm(k)*(var_zt(k+1)-var_zt(k)) - ! -dzm(k-1)*(var_zt(k)-var_zt(k-1)) ) - ! -dzt(k-1)*dzm(k-1)*(var_zt(k)-var_zt(k-1)) } ]. - ! - ! Again, the term is treated completely implicitly, so the leading "-" - ! sign changes to a "+" sign when the term is brought over to the - ! left-hand side, and var_zt is considered to be at timestep (t+1). - ! - ! The result is dependent only on values of var_zt found at thermodynamic - ! levels 1, 2, 3, and 4. Thus, it only affects 4 diagonals on the - ! left-hand side matrix. - ! - ! The lower boundary also effects the discretization at thermodynamic - ! level 1. - ! - ! -var_zt(3)----------------------------------------------- t(3) - ! - ! ======d(var_zt)/dz======================================= m(2) - ! - ! -var_zt(2)----d^2(var_zt)/dz^2--------------------------- t(2) - ! - ! ======d(var_zt)/dz========d^3(var_zt)/dz^3=============== m(1) - ! - ! -var_zt(1)----d^2(var_zt)/dz^2--------d^4(var_zt)/dz^4--- t(1) Boundary - ! - ! ======[d(var_zt)/dz = 0]==[d^3(var_zt)/dz^3 = 0]========= m(0) - ! - ! -[var_zt(0) = var_zt(1)]-----(level outside model)------- t(0) - ! - ! The discretization of -nu*d^4(var_zt)/dz^4 at thermodynamic level (k=1) - ! is written out as follows: - ! - ! -nu - ! *dzt(k)*[ dzm(k)*{ dzt(k+1)*( dzm(k+1)*(var_zt(k+2)-var_zt(k+1)) - ! -dzm(k)*(var_zt(k+1)-var_zt(k)) ) - ! -dzt(k)*dzm(k)*(var_zt(k+1)-var_zt(k)) } ]. - ! - ! Again, the term is treated completely implicitly, so the leading "-" - ! sign changes to a "+" sign when the term is brought over to the - ! left-hand side, and var_zt is considered to be at timestep (t+1). - ! - ! The result is dependent only on values of var_zt found at thermodynamic - ! levels 1, 2, and 3. Thus, it only affects 3 diagonals on the left-hand - ! side matrix. - ! - ! The same method can be used to discretize the upper boundary by - ! considering a new level outside the model just above the upper boundary - ! level. - ! - ! 2) Fixed-point boundary conditions. - ! Many equations in the model use fixed-point boundary conditions rather - ! than zero-flux boundary conditions. This means that the value of - ! var_zt stays the same over the course of the timestep at the lower - ! boundary, as well as at the upper boundary. - ! - ! For a 4th-order term, four boundary conditions are needed. Two - ! boundary conditions are applied at each boundary. For the case of - ! fixed-point boundary conditions, one of those two conditions is setting - ! var_zt = A, where A is a constant value. One more condition is needed. - ! Setting the values of d(var_zt)/dz and d^3(var_zt)/dz^3 are inherently - ! used for zero-flux (or perhaps fixed-flux) boundary conditions. - ! Fixed-point and zero-flux boundary conditions inherently should not be - ! invoked at the same time. The only remaining choice for a second - ! boundary condition for the fixed-point case is setting - ! d^2(var_zt)/dz^2. As it turns out, setting d^2(var_zt)/dz^2 = 0 is the - ! appropriate condition to use because it prevents values of var_zt at - ! levels outside the model from being involved in the discretization of - ! -nu*d^4(var_zt)/dz^4 at thermodynamic level 2. Setting - ! d^3(var_zt)/dz^3 = 0 does not accomplish the same thing for the - ! discretization of -nu*d^4(var_zt)/dz^4 at thermodynamic level 2. Also, - ! as stated above, fourth-order numerical diffusion is used in - ! conjunction with second-order eddy diffusion, - ! +d[(K_zm+nu)*d(var_zt)/dz]/dz, where the coefficient of eddy - ! diffusivity, (K_zm+nu), varies in the vertical. Both 4th-order - ! numerical diffusion and 2nd-order eddy diffusion use the same boundary - ! condition type at all times, which in this case is fixed-point boundary - ! conditions. For 2nd-order eddy diffusion, fixed-point boundary - ! conditions set var_zt = A, and do not set d(var_zt)/dz. Thus, - ! d(var_zt)/dz cannot be set for fixed-point boundary conditions. As - ! previously stated, the only other boundary condition that can be - ! invoked for a fixed-point boundary case is d^2(var_zt)/dz^2 = 0. - ! - ! Since the normal discretization includes two levels on either side of - ! the central level, the lower boundary begins to effect the - ! discretization at thermodynamic level 2. - ! - ! -var_zt(4)----------------------------------------------- t(4) - ! - ! ======d(var_zt)/dz======================================= m(3) - ! - ! -var_zt(3)----d^2(var_zt)/dz^2--------------------------- t(3) - ! - ! ======d(var_zt)/dz========d^3(var_zt)/dz^3=============== m(2) - ! - ! -var_zt(2)----d^2(var_zt)/dz^2--------d^4(var_zt)/dz^4--- t(2) - ! - ! ======d(var_zt)/dz========d^3(var_zt)/dz^3=============== m(1) - ! - ! -var_zt(1)----[d^2(var_zt)/dz^2 = 0]--------------------- t(1) Boundary - ! - ! ======d(var_zt)/dz======================================= m(0) - ! - ! -var_zt(0)-------------------(level outside model)------- t(0) - ! - ! The discretization of -nu*d^4(var_zt)/dz^4 at thermodynamic level (k=2) - ! is written out as follows: - ! - ! -nu - ! *dzt(k)*[ dzm(k)*{ dzt(k+1)*( dzm(k+1)*(var_zt(k+2)-var_zt(k+1)) - ! -dzm(k)*(var_zt(k+1)-var_zt(k)) ) - ! -dzt(k)*( dzm(k)*(var_zt(k+1)-var_zt(k)) - ! -dzm(k-1)*(var_zt(k)-var_zt(k-1)) ) } - ! -dzm(k-1)*{ dzt(k)*( dzm(k)*(var_zt(k+1)-var_zt(k)) - ! -dzm(k-1)*(var_zt(k)-var_zt(k-1)) ) } ]. - ! - ! Again, the term is treated completely implicitly, so the leading "-" - ! sign changes to a "+" sign when the term is brought over to the - ! left-hand side, and var_zt is considered to be at timestep (t+1). - ! - ! The result is dependent only on values of var_zt found at thermodynamic - ! levels 1, 2, 3, and 4. Thus, it only affects 4 diagonals on the - ! left-hand side matrix. - ! - ! The same method can be used to discretize -nu*d^4(var_zt)/dz^4 at the - ! second-highest thermodynamic level (k=top-1) by setting - ! d^2(var_zt)/dz^2 = 0 at the highest thermodynamic level. - ! - ! The discretization at thermodynamic level (k=1) is written to simply - ! set the value var_zt(1) = A. Likewise, the discretization at - ! thermodynamic level (k=top) is written to simply set the value - ! var_zt(top) = B. In order to discretize the boundary conditions at the - ! lowest and highest vertical levels for equations requiring fixed-point - ! boundary conditions, either: - ! a) in the parent subroutine or function (that calls this function), - ! loop over all vertical levels from the second-lowest to the - ! second-highest, ignoring the lowest and highest levels. Then set - ! the values at the lowest and highest levels in the parent - ! subroutine; or - ! b) in the parent subroutine or function, loop over all vertical levels - ! and then overwrite the results at the lowest and highest levels. - ! - ! Either way, at the lowest and highest levels, an array with a value - ! of 1 at the main diagonal on the left-hand side and with values of 0 at - ! all other diagonals on the left-hand side will preserve the right-hand - ! side value at that level, thus satisfying the fixed-point boundary - ! conditions. - ! - ! - ! Conservation Properties: - ! - ! When zero-flux boundary conditions are used, this technique of - ! discretizing the 4th-order numerical diffusion term leads to conservative - ! differencing. When conservative differencing is in place, the column - ! totals for each column in the left-hand side matrix (for the 4th-order - ! numerical diffusion term) should be equal to 0. This ensures that the - ! total amount of the quantity var_zt over the entire vertical domain is - ! being conserved, meaning that nothing is lost due to diffusional effects. - ! - ! To see that this conservation law is satisfied, compute the 4th-order - ! numerical diffusion of var_zt and integrate vertically. In discretized - ! matrix notation (where "i" stands for the matrix column and "j" stands for - ! the matrix row): - ! - ! 0 = Sum_j Sum_i ( 1/dzt )_i ( nu*dzt*dzm*dzt*dzm )_ij (var_zt)_j. - ! - ! The left-hand side matrix, ( nu*dzt*dzm*dzt*dzm )_ij, is partially written - ! below. The sum over i in the above equation removes the first dzt(k) - ! everywhere from the matrix below. The sum over j leaves the column totals - ! that are desired. - ! - ! Left-hand side matrix contributions from 4th-order numerical diffusion - ! (or hyper-diffusion) term; first five vertical levels: - ! - ! column 1 || column 2 || column 3 || column 4 || column 5 - ! ------------------------------------------------------------------------------------------> - ! | +nu -nu +nu - ! | *dzt(k) *dzt(k) *dzt(k) - ! | *[ dzm(k) *[ dzm(k) *dzm(k) - !k=1| *{ dzt(k+1) *{ dzt(k+1) *dzt(k+1) 0 0 - ! | *dzm(k) *( dzm(k+1) *dzm(k+1) - ! | +dzt(k) +dzm(k) ) - ! | *dzm(k) } ] +dzt(k) - ! | *dzm(k) } ] - ! | - ! | -nu +nu -nu +nu - ! | *dzt(k) *dzt(k) *dzt(k) *dzt(k) - ! | *[ dzm(k) *[ dzm(k) *[ dzm(k) *dzm(k) - ! | *dzt(k) *{ dzt(k+1) *{ dzt(k+1) *dzt(k+1) - ! | *dzm(k-1) *dzm(k) *( dzm(k+1) *dzm(k+1) - ! | +dzm(k-1) +dzt(k) +dzm(k) ) - ! | *{ dzt(k) *( dzm(k) +dzt(k) - !k=2| *dzm(k-1) +dzm(k-1) ) *dzm(k) } 0 - ! | +dzt(k-1) } +dzm(k-1) - ! | *dzm(k-1) +dzm(k-1) *dzt(k) - ! | } ] *{ dzt(k) *dzm(k) ] - ! | *( dzm(k) - ! | +dzm(k-1) ) - ! | +dzt(k-1) - ! | *dzm(k-1) } ] - ! | - ! | +nu -nu +nu -nu +nu - ! | *dzt(k) *dzt(k) *dzt(k) *dzt(k) *dzt(k) - ! | *dzm(k-1) *[ dzm(k) *[ dzm(k) *[ dzm(k) *dzm(k) - ! | *dzt(k-1) *dzt(k) *{ dzt(k+1) *{ dzt(k+1) *dzt(k+1) - ! | *dzm(k-2) *dzm(k-1) *dzm(k) *( dzm(k+1) *dzm(k+1) - ! | +dzm(k-1) +dzt(k) +dzm(k) ) - ! | *{ dzt(k) *( dzm(k) +dzt(k) - !k=3| *dzm(k-1) +dzm(k-1) ) *dzm(k) } - ! | +dzt(k-1) } +dzm(k-1) - ! | *( dzm(k-1) +dzm(k-1) *dzt(k) - ! | +dzm(k-2) ) *{ dzt(k) *dzm(k) ] - ! | } ] *( dzm(k) - ! | +dzm(k-1) ) - ! | +dzt(k-1) - ! | *dzm(k-1) } ] - ! | - ! | +nu -nu +nu -nu - ! | *dzt(k) *dzt(k) *dzt(k) *dzt(k) - ! | *dzm(k-1) *[ dzm(k) *[ dzm(k) *[ dzm(k) - ! | *dzt(k-1) *dzt(k) *{ dzt(k+1) *{ dzt(k+1) - ! | *dzm(k-2) *dzm(k-1) *dzm(k) *( dzm(k+1) - ! | +dzm(k-1) +dzt(k) +dzm(k) ) - ! | *{ dzt(k) *( dzm(k) +dzt(k) - !k=4| 0 *dzm(k-1) +dzm(k-1) ) *dzm(k) } - ! | +dzt(k-1) } +dzm(k-1) - ! | *( dzm(k-1) +dzm(k-1) *dzt(k) - ! | +dzm(k-2) ) *{ dzt(k) *dzm(k) ] - ! | } ] *( dzm(k) - ! | +dzm(k-1) ) - ! | +dzt(k-1) - ! | *dzm(k-1) } ] - ! | - ! | +nu -nu +nu - ! | *dzt(k) *dzt(k) *dzt(k) - ! | *dzm(k-1) *[ dzm(k) *[ dzm(k) - ! | *dzt(k-1) *dzt(k) *{ dzt(k+1) - ! | *dzm(k-2) *dzm(k-1) *dzm(k) - ! | +dzm(k-1) +dzt(k) - ! | *{ dzt(k) *( dzm(k) - !k=5| 0 0 *dzm(k-1) +dzm(k-1) ) - ! | +dzt(k-1) } - ! | *( dzm(k-1) +dzm(k-1) - ! | +dzm(k-2) ) *{ dzt(k) - ! | } ] *( dzm(k) - ! | +dzm(k-1) ) - ! | +dzt(k-1) - ! | *dzm(k-1) } ] - ! \ / - ! - ! Note: The super-super diagonal term from level 4 and both the super - ! diagonal and super-super diagonal terms from level 5 are not shown - ! on this diagram. - ! - ! Note: The matrix shown is a five-diagonal matrix. For a nine-diagonal - ! matrix, there would be an extra row between each of the rows shown - ! and an extra column between each of the columns shown. However, - ! for the purposes of the var_zt 4th-order hyper-diffusion term, - ! those extra row and column values are all 0, and the conservation - ! properties of the matrix aren't effected. - ! - ! For the case of fixed-point boundary conditions, the contributions of the - ! 4th-order hyper-diffusion term are as follows (only the top 2 levels - ! differ from the matrix diagram above): - ! - ! column 1 || column 2 || column 3 || column 4 || column 5 - ! ------------------------------------------------------------------------------------------> - !k=1| 0 0 0 0 0 - ! | - ! | -nu +nu -nu +nu - ! | *dzt(k) *dzt(k) *dzt(k) *dzt(k) - ! | *[ dzm(k) *[ dzm(k) *[ dzm(k) *dzm(k) - ! | *dzt(k) *{ dzt(k+1) *{ dzt(k+1) *dzt(k+1) - ! | *dzm(k-1) *dzm(k) *( dzm(k+1) *dzm(k+1) - ! | +dzm(k-1) +dzt(k) +dzm(k) ) - !k=2| *dzt(k) *( dzm(k) +dzt(k) 0 - ! | *dzm(k-1) ] +dzm(k-1) ) *dzm(k) } - ! | } +dzm(k-1) - ! | +dzm(k-1) *dzt(k) - ! | *{ dzt(k) *dzm(k) ] - ! | *( dzm(k) - ! | +dzm(k-1) ) - ! | } ] - ! \ / - ! - ! For the left-hand side matrix as a whole, the matrix entries at level 1 - ! (k=1) read: 1 0 0 0 0. For the case of fixed-point boundary - ! conditions, conservative differencing is not in play. The total amount of - ! var_zt over the entire vertical domain is not being conserved, as amounts - ! of var_zt may be fluxed out through the upper boundary or lower boundary - ! through the effects of diffusion. - ! - ! Brian Griffin. October 7, 2008. - - ! References: - ! None - !----------------------------------------------------------------------- - - use clubb_precision, only: & - core_rknd ! Variable(s) - - use grid_class, only: & - gr ! Variable(s) gr%nz - - implicit none - - ! Constant parameters - integer, parameter :: & - kp2_tdiag = 1, & ! Thermodynamic super-super diagonal index. - kp1_tdiag = 2, & ! Thermodynamic super diagonal index. - k_tdiag = 3, & ! Thermodynamic main diagonal index. - km1_tdiag = 4, & ! Thermodynamic sub diagonal index. - km2_tdiag = 5 ! Thermodynamic sub-sub diagonal index. - - ! Input Variables - character (len=*), intent(in) :: & - boundary_cond ! Type of boundary conditions being used - ! ('zero-flux' or 'fixed-point'). - - real( kind = core_rknd ), intent(in) :: & - nu, & ! Constant coef. of 4th-order numerical diffusion [m^4/s] - invrs_dzt, & ! Inverse of grid spacing over thermo. level (k) [1/m] - invrs_dzm, & ! Inverse of grid spacing over momentum level (k) [1/m] - invrs_dzmm1, & ! Inverse of grid spacing over momentum level (k-1) [1/m] - invrs_dztp1, & ! Inverse of grid spacing over thermo. level (k+1) [1/m] - invrs_dztm1, & ! Inverse of grid spacing over thermo. level (k-1) [1/m] - invrs_dzmp1, & ! Inverse of grid spacing over momentum level (k+1) [1/m] - invrs_dzmm2 ! Inverse of grid spacing over momentum level (k-2) [1/m] - - integer, intent(in) :: & - level ! Thermodynamic level where calculation occurs. [-] - - ! Return Variable - real( kind = core_rknd ), dimension(5) :: lhs - - - if ( level == 1 ) then - - ! Lowest level - ! k = 1; lower boundery level at surface. - ! Only relevant if zero-flux boundary conditions are used. - - if ( trim( boundary_cond ) == 'zero-flux' ) then - - ! Zero-flux boundary conditions - - ! Thermodynamic sub-sub diagonal: [ x var_zt(k-2,) ] - lhs(km2_tdiag) & - = 0.0_core_rknd - - ! Thermodynamic sub diagonal: [ x var_zt(k-1,) ] - lhs(km1_tdiag) & - = 0.0_core_rknd - - ! Thermodynamic main diagonal: [ x var_zt(k,) ] - lhs(k_tdiag) & - = +nu*invrs_dzt & - *invrs_dzm*(invrs_dztp1*invrs_dzm + invrs_dzt*invrs_dzm) - - ! Thermodynamic super diagonal: [ x var_zt(k+1,) ] - lhs(kp1_tdiag) & - = -nu*invrs_dzt & - *invrs_dzm*( invrs_dztp1*(invrs_dzmp1 + invrs_dzm) & - +invrs_dzt*invrs_dzm ) - - ! Thermodynamic super-super diagonal: [ x var_zt(k+2,) ] - lhs(kp2_tdiag) & - = +nu*invrs_dzt & - *invrs_dzm*invrs_dztp1*invrs_dzmp1 - - elseif ( trim( boundary_cond ) == 'fixed-point' ) then - - ! Fixed-point boundary conditions - ! The left-hand side matrix contributions from level 1 are - ! over-written or set in the parent subroutine. - - ! Thermodynamic sub-sub diagonal: [ x var_zt(k-2,) ] - lhs(km2_tdiag) & - = 0.0_core_rknd - - ! Thermodynamic sub diagonal: [ x var_zt(k-1,) ] - lhs(km1_tdiag) & - = 0.0_core_rknd - - ! Thermodynamic main diagonal: [ x var_zt(k,) ] - lhs(k_tdiag) & - = 0.0_core_rknd - - ! Thermodynamic super diagonal: [ x var_zt(k+1,) ] - lhs(kp1_tdiag) & - = 0.0_core_rknd - - ! Thermodynamic super-super diagonal: [ x var_zt(k+2,) ] - lhs(kp2_tdiag) & - = 0.0_core_rknd - - endif - - - elseif ( level == 2 ) then - - ! Second-lowest level - - if ( trim( boundary_cond ) == 'zero-flux' ) then - - ! Zero-flux boundary conditions - - ! Thermodynamic sub-sub diagonal: [ x var_zt(k-2,) ] - lhs(km2_tdiag) & - = 0.0_core_rknd - - ! Thermodynamic sub diagonal: [ x var_zt(k-1,) ] - lhs(km1_tdiag) & - = -nu*invrs_dzt & - *( invrs_dzm*invrs_dzt*invrs_dzmm1 & - +invrs_dzmm1*( invrs_dzt*invrs_dzmm1 & - +invrs_dztm1*invrs_dzmm1 ) ) - - ! Thermodynamic main diagonal: [ x var_zt(k,) ] - lhs(k_tdiag) & - = +nu*invrs_dzt & - *( invrs_dzm*( invrs_dztp1*invrs_dzm & - +invrs_dzt*(invrs_dzm + invrs_dzmm1) ) & - +invrs_dzmm1*( invrs_dzt*(invrs_dzm + invrs_dzmm1) & - +invrs_dztm1*invrs_dzmm1 ) ) - - ! Thermodynamic super diagonal: [ x var_zt(k+1,) ] - lhs(kp1_tdiag) & - = -nu*invrs_dzt & - *( invrs_dzm*( invrs_dztp1*(invrs_dzmp1 + invrs_dzm) & - +invrs_dzt*invrs_dzm ) & - +invrs_dzmm1*invrs_dzt*invrs_dzm ) - - ! Thermodynamic super-super diagonal: [ x var_zt(k+2,) ] - lhs(kp2_tdiag) & - = +nu*invrs_dzt & - *invrs_dzm*invrs_dztp1*invrs_dzmp1 - - elseif ( trim( boundary_cond ) == 'fixed-point' ) then - - ! Fixed-point boundary conditions - - ! Thermodynamic sub-sub diagonal: [ x var_zt(k-2,) ] - lhs(km2_tdiag) & - = 0.0_core_rknd - - ! Thermodynamic sub diagonal: [ x var_zt(k-1,) ] - lhs(km1_tdiag) & - = -nu*invrs_dzt & - *( invrs_dzm*invrs_dzt*invrs_dzmm1 & - +invrs_dzmm1*invrs_dzt*invrs_dzmm1 ) - - ! Thermodynamic main diagonal: [ x var_zt(k,) ] - lhs(k_tdiag) & - = +nu*invrs_dzt & - *( invrs_dzm*( invrs_dztp1*invrs_dzm & - +invrs_dzt*(invrs_dzm + invrs_dzmm1) ) & - +invrs_dzmm1*( invrs_dzt*(invrs_dzm + invrs_dzmm1) ) ) - - ! Thermodynamic super diagonal: [ x var_zt(k+1,) ] - lhs(kp1_tdiag) & - = -nu*invrs_dzt & - *( invrs_dzm*( invrs_dztp1*(invrs_dzmp1 + invrs_dzm) & - +invrs_dzt*invrs_dzm ) & - +invrs_dzmm1*invrs_dzt*invrs_dzm ) - - ! Thermodynamic super-super diagonal: [ x var_zt(k+2,) ] - lhs(kp2_tdiag) & - = +nu*invrs_dzt & - *invrs_dzm*invrs_dztp1*invrs_dzmp1 - - endif - - - elseif ( level > 2 .and. level < gr%nz-1 ) then - - ! k > 2 and k < num_levels-1 - ! These interior level are not effected by boundary conditions. - - ! Thermodynamic sub-sub diagonal: [ x var_zt(k-2,) ] - lhs(km2_tdiag) & - = +nu*invrs_dzt & - *invrs_dzmm1*invrs_dztm1*invrs_dzmm2 - - ! Thermodynamic sub diagonal: [ x var_zt(k-1,) ] - lhs(km1_tdiag) & - = -nu*invrs_dzt & - *( invrs_dzm*invrs_dzt*invrs_dzmm1 & - +invrs_dzmm1*( invrs_dzt*invrs_dzmm1 & - +invrs_dztm1*(invrs_dzmm1 + invrs_dzmm2) ) ) - - ! Thermodynamic main diagonal: [ x var_zt(k,) ] - lhs(k_tdiag) & - = +nu*invrs_dzt & - *( invrs_dzm*( invrs_dztp1*invrs_dzm & - +invrs_dzt*(invrs_dzm + invrs_dzmm1) ) & - +invrs_dzmm1*( invrs_dzt*(invrs_dzm + invrs_dzmm1) & - +invrs_dztm1*invrs_dzmm1 ) ) - - ! Thermodynamic super diagonal: [ x var_zt(k+1,) ] - lhs(kp1_tdiag) & - = -nu*invrs_dzt & - *( invrs_dzm*( invrs_dztp1*(invrs_dzmp1 + invrs_dzm) & - +invrs_dzt*invrs_dzm ) & - +invrs_dzmm1*invrs_dzt*invrs_dzm ) - - ! Thermodynamic super-super diagonal: [ x var_zt(k+2,) ] - lhs(kp2_tdiag) & - = +nu*invrs_dzt & - *invrs_dzm*invrs_dztp1*invrs_dzmp1 - - - elseif ( level == gr%nz-1 ) then - - ! Second-highest level - - if ( trim( boundary_cond ) == 'zero-flux' ) then - - ! Zero-flux boundary conditions - - ! Thermodynamic sub-sub diagonal: [ x var_zt(k-2,) ] - lhs(km2_tdiag) & - = +nu*invrs_dzt & - *invrs_dzmm1*invrs_dztm1*invrs_dzmm2 - - ! Thermodynamic sub diagonal: [ x var_zt(k-1,) ] - lhs(km1_tdiag) & - = -nu*invrs_dzt & - *( invrs_dzm*invrs_dzt*invrs_dzmm1 & - +invrs_dzmm1*( invrs_dzt*invrs_dzmm1 & - +invrs_dztm1*(invrs_dzmm1 + invrs_dzmm2) ) ) - - ! Thermodynamic main diagonal: [ x var_zt(k,) ] - lhs(k_tdiag) & - = +nu*invrs_dzt & - *( invrs_dzm*( invrs_dztp1*invrs_dzm & - +invrs_dzt*(invrs_dzm + invrs_dzmm1) ) & - +invrs_dzmm1*( invrs_dzt*(invrs_dzm + invrs_dzmm1) & - +invrs_dztm1*invrs_dzmm1 ) ) - - ! Thermodynamic super diagonal: [ x var_zt(k+1,) ] - lhs(kp1_tdiag) & - = -nu*invrs_dzt & - *( invrs_dzm*( invrs_dztp1*invrs_dzm & - +invrs_dzt*invrs_dzm ) & - +invrs_dzmm1*invrs_dzt*invrs_dzm ) - - ! Thermodynamic super-super diagonal: [ x var_zt(k+2,) ] - lhs(kp2_tdiag) & - = 0.0_core_rknd - - elseif ( trim( boundary_cond ) == 'fixed-point' ) then - - ! Fixed-point boundary conditions - - ! Thermodynamic sub-sub diagonal: [ x var_zt(k-2,) ] - lhs(km2_tdiag) & - = +nu*invrs_dzt & - *invrs_dzmm1*invrs_dztm1*invrs_dzmm2 - - ! Thermodynamic sub diagonal: [ x var_zt(k-1,) ] - lhs(km1_tdiag) & - = -nu*invrs_dzt & - *( invrs_dzm*invrs_dzt*invrs_dzmm1 & - +invrs_dzmm1*( invrs_dzt*invrs_dzmm1 & - +invrs_dztm1*(invrs_dzmm1 + invrs_dzmm2) ) ) - - ! Thermodynamic main diagonal: [ x var_zt(k,) ] - lhs(k_tdiag) & - = +nu*invrs_dzt & - *( invrs_dzm*( invrs_dzt*(invrs_dzm + invrs_dzmm1) ) & - +invrs_dzmm1*( invrs_dzt*(invrs_dzm + invrs_dzmm1) & - +invrs_dztm1*invrs_dzmm1 ) ) - - ! Thermodynamic super diagonal: [ x var_zt(k+1,) ] - lhs(kp1_tdiag) & - = -nu*invrs_dzt & - *( invrs_dzm*invrs_dzt*invrs_dzm & - +invrs_dzmm1*invrs_dzt*invrs_dzm ) - - ! Thermodynamic super-super diagonal: [ x var_zt(k+2,) ] - lhs(kp2_tdiag) & - = 0.0_core_rknd - - endif - - - elseif ( level == gr%nz ) then - - ! Highest level - ! k = gr%nz; upper boundery level at model top. - ! Only relevant if zero-flux boundary conditions are used. - - if ( trim( boundary_cond ) == 'zero-flux' ) then - - ! Zero-flux boundary conditions - - ! Thermodynamic sub-sub diagonal: [ x var_zt(k-2,) ] - lhs(km2_tdiag) & - = +nu*invrs_dzt & - *invrs_dzmm1*invrs_dztm1*invrs_dzmm2 - - ! Thermodynamic sub diagonal: [ x var_zt(k-1,) ] - lhs(km1_tdiag) & - = -nu*invrs_dzt & - *invrs_dzmm1*( invrs_dzt*invrs_dzmm1 & - +invrs_dztm1*(invrs_dzmm1 + invrs_dzmm2) ) - - ! Thermodynamic main diagonal: [ x var_zt(k,) ] - lhs(k_tdiag) & - = +nu*invrs_dzt & - *invrs_dzmm1*(invrs_dzt*invrs_dzmm1 + invrs_dztm1*invrs_dzmm1) - - ! Thermodynamic super diagonal: [ x var_zt(k+1,) ] - lhs(kp1_tdiag) & - = 0.0_core_rknd - - ! Thermodynamic super-super diagonal: [ x var_zt(k+2,) ] - lhs(kp2_tdiag) & - = 0.0_core_rknd - - elseif ( trim( boundary_cond ) == 'fixed-point' ) then - - ! Fixed-point boundary conditions - ! The left-hand side matrix contributions from level gr%nz are - ! over-written or set in the parent subroutine. - - ! Thermodynamic sub-sub diagonal: [ x var_zt(k-2,) ] - lhs(km2_tdiag) & - = 0.0_core_rknd - - ! Thermodynamic sub diagonal: [ x var_zt(k-1,) ] - lhs(km1_tdiag) & - = 0.0_core_rknd - - ! Thermodynamic main diagonal: [ x var_zt(k,) ] - lhs(k_tdiag) & - = 0.0_core_rknd - - ! Thermodynamic super diagonal: [ x var_zt(k+1,) ] - lhs(kp1_tdiag) & - = 0.0_core_rknd - - ! Thermodynamic super-super diagonal: [ x var_zt(k+2,) ] - lhs(kp2_tdiag) & - = 0.0_core_rknd - - endif - - endif - - return - - end function hyper_dfsn_4th_ord_zt_lhs - - !============================================================================= - pure function hyper_dfsn_4th_ord_zm_lhs( boundary_cond, nu, invrs_dzm, & - invrs_dztp1, invrs_dzt, & - invrs_dzmp1, invrs_dzmm1, & - invrs_dztp2, invrs_dztm1, level ) & - result( lhs ) - - ! Note: In the "Description" section of this function, the variable - ! "invrs_dzm" will be written as simply "dzm", and the variable - ! "invrs_dzt" will be written as simply "dzt". This is being done as - ! as device to save space and to make some parts of the description - ! more readable. This change does not pertain to the actual code. - - ! Description: - ! Vertical 4th-order numerical diffusion of var_zm: implicit portion of the - ! code. - ! - ! Fourth-order numerical diffusion, or fourth-order hyper-diffusion, is used - ! to help eliminate small-scale noise without altering larger-scale - ! features. - ! - ! The variable "var_zm" stands for a variable that is located at momentum - ! grid levels. - ! - ! The d(var_zm)/dt equation contains a 4th-order numerical diffusion term: - ! - ! - nu * d^4(var_zm)/dz^4. - ! - ! This term is solved for completely implicitly, such that: - ! - ! - nu * d^4( var_zm(t+1) )/dz^4. - ! - ! Note: When the term is brought over to the left-hand side, the sign - ! is reversed and the leading "-" in front of the term is changed - ! to a "+". - ! - ! The timestep index (t+1) means that the value of var_zm being used is from - ! the next timestep, which is being advanced to in solving the d(var_zm)/dt - ! equation. - ! - ! The term is discretized as follows: - ! - ! The five values of var_zm are found on the momentum levels. All four - ! derivatives (d/dz) of var_zm are taken over all the intermediate - ! thermodynamic levels. Then, all three derivatives (d/dz) of d(var_zm)/dz - ! are taken over all the intermediate momentum levels, which results in the - ! second derivatives. Then, both derivatives (d/dz) of d^2(var_zm)/dz^2 are - ! taken over the intermediate thermodynamic levels, which results in the - ! third derivatives. Finally, the derivative (d/dz) of d^3(var_zm)/dz^3 is - ! taken over the intermediate (central) momentum level, which results in the - ! fourth derivative. At the central momentum level, d^4(var_zm)/dz^4 is - ! multiplied by constant coefficient nu. - ! - ! ==var_zmp2=============================================== m(k+2) - ! - ! ------d(var_zm)/dz--------------------------------------- t(k+2) - ! - ! ==var_zmp1====d^2(var_zm)/dz^2=========================== m(k+1) - ! - ! ------d(var_zm)/dz--------d^3(var_zm)/dz^3--------------- t(k+1) - ! - ! ==var_zm======d^2(var_zm)/dz^2========d^4(var_zm)/dz^4=== m(k) - ! - ! ------d(var_zm)/dz--------d^3(var_zm)/dz^3--------------- t(k) - ! - ! ==var_zmm1====d^2(var_zm)/dz^2=========================== m(k-1) - ! - ! ------d(var_zm)/dz--------------------------------------- t(k-1) - ! - ! ==var_zmm2=============================================== m(k-2) - ! - ! The vertical indices m(k+2), t(k+2), m(k+1), t(k+1), m(k), t(k), m(k-1), - ! t(k-1), and m(k-2) correspond with altitudes zm(k+2), zt(k+2), zm(k+1), - ! zt(k+1), zm(k), zt(k), zm(k-1), zt(k-1), and zm(k-2) respectively. The - ! letter "t" is used for thermodynamic levels and the letter "m" is used for - ! momentum levels. - ! - ! dzm(k) = 1 / ( zt(k+1) - zt(k) ) - ! dzt(k+1) = 1 / ( zm(k+1) - zm(k) ) - ! dzt(k) = 1 / ( zm(k) - zm(k-1) ) - ! dzm(k+1) = 1 / ( zt(k+2) - zt(k+1) ) - ! dzm(k-1) = 1 / ( zt(k) - zt(k-1) ) - ! dzt(k+2) = 1 / ( zm(k+2) - zm(k+1) ) - ! dzt(k-1) = 1 / ( zm(k-1) - zm(k-2) ) - ! - ! The discretization of -nu*d^4(var_zm)/dz^4 at momentum level (k) is - ! written out as follows: - ! - ! -nu*dzm(k)*[ dzt(k+1)*{ dzm(k+1)*( dzt(k+2)*(var_zm(k+2)-var_zm(k+1)) - ! -dzt(k+1)*(var_zm(k+1)-var_zm(k)) ) - ! -dzm(k)*( dzt(k+1)*(var_zm(k+1)-var_zm(k)) - ! -dzt(k)*(var_zm(k)-var_zm(k-1)) ) } - ! -dzt(k)*{ dzm(k)*( dzt(k+1)*(var_zm(k+1)-var_zm(k)) - ! -dzt(k)*(var_zm(k)-var_zm(k-1)) ) - ! -dzm(k-1)*( dzt(k)*(var_zm(k)-var_zm(k-1)) - ! -dzt(k-1)*(var_zm(k-1)-var_zm(k-2)) ) } ]. - ! - ! Again, the term is treated completely implicitly, so the leading "-" sign - ! changes to a "+" sign when the term is brought over to the left-hand side, - ! and var_zm is considered to be at timestep (t+1). - ! - ! - ! Boundary Conditions: - ! - ! 1) Zero-flux boundary conditions. - ! This function is set up to use zero-flux boundary conditions at both - ! the lower boundary level and the upper boundary level. The flux, F, - ! is the amount of var_zm flowing normal through the boundary per unit - ! time per unit surface area. The derivative of the flux effects the - ! time-tendency of var_zm, such that: - ! - ! d(var_zm)/dt = -dF/dz. - ! - ! For the 4th-order numerical diffusion term, -nu*d^4(var_zm)/dz^4 (which - ! is actually -d[nu*d^3(var_zm)/dz^3]/dz with a constant coefficient, - ! nu), the flux is: - ! - ! F = +nu*d^3(var_zm)/dz^3. - ! - ! In order to have zero-flux boundary conditions, the third derivative of - ! var_zm, d^3(var_zm)/dz^3, needs to equal 0 at both the lower boundary - ! and the upper boundary. - ! - ! Fourth-order numerical diffusion is used in conjunction with - ! second-order eddy diffusion, +d[(K_zt+nu)*d(var_zm)/dz]/dz, where the - ! coefficient of eddy diffusivity, (K_zt+nu), varies in the vertical. - ! Both 4th-order numerical diffusion and 2nd-order eddy diffusion use the - ! same boundary condition type at all times, which in this case is - ! zero-flux boundary conditions. For 2nd-order eddy diffusion, the flux - ! is: F = -(K_zt+nu)*d(var_zm)/dz. In order to have zero-flux boundary - ! conditions, the derivative of var_zm, d(var_zm)/dz, needs to equal 0 at - ! both the lower boundary and the upper boundary. - ! - ! Thus, the boundary conditions used for 4th-order numerical diffusion - ! are: d^3(var_zm)/dz^3 = 0 and d(var_zm)/dz = 0 at both the upper - ! boundary and the lower boundary, resulting in four boundary conditions, - ! which is the number of boundary conditions needed for a 4th-order term. - ! - ! In order to discretize the lower boundary condition, consider a new - ! level outside the model (momentum level 0) just below the lower - ! boundary level (momentum level 1). The value of var_zm at the level - ! just outside the model is defined to be the same as the value of var_zm - ! at the lower boundary level. Therefore, the value of d(var_zm)/dz - ! between the level just outside the model and the lower boundary level - ! is 0, satisfying one of the boundary conditions. The boundary - ! condition d^3(var_zm)/dz^3 = 0 is also set at this level. The rest of - ! the levels involved are discretized normally, as listed above. - ! - ! Since the normal discretization includes two levels on either side of - ! the central level, the lower boundary begins to effect the - ! discretization at momentum level 2. - ! - ! =var_zm(4)=============================================== m(4) - ! - ! ------d(var_zm)/dz--------------------------------------- t(4) - ! - ! =var_zm(3)====d^2(var_zm)/dz^2=========================== m(3) - ! - ! ------d(var_zm)/dz--------d^3(var_zm)/dz^3--------------- t(3) - ! - ! =var_zm(2)====d^2(var_zm)/dz^2========d^4(var_zm)/dz^4=== m(2) - ! - ! ------d(var_zm)/dz--------d^3(var_zm)/dz^3--------------- t(2) - ! - ! =var_zm(1)====d^2(var_zm)/dz^2=========================== m(1) Boundary - ! - ! ------[d(var_zm)/dz = 0]--------------------------------- t(1) - ! - ! =[var_zm(0) = var_zm(1)]=====(level outside model)======= m(0) - ! - ! The discretization of -nu*d^4(var_zm)/dz^4 at momentum level (k=2) is - ! written out as follows: - ! - ! -nu*dzm(k)*[ dzt(k+1)*{ dzm(k+1)*( dzt(k+2)*(var_zm(k+2)-var_zm(k+1)) - ! -dzt(k+1)*(var_zm(k+1)-var_zm(k)) ) - ! -dzm(k)*( dzt(k+1)*(var_zm(k+1)-var_zm(k)) - ! -dzt(k)*(var_zm(k)-var_zm(k-1)) ) } - ! -dzt(k)*{ dzm(k)*( dzt(k+1)*(var_zm(k+1)-var_zm(k)) - ! -dzt(k)*(var_zm(k)-var_zm(k-1)) ) - ! -dzm(k-1)*dzt(k)*(var_zm(k)-var_zm(k-1)) } ]. - ! - ! Again, the term is treated completely implicitly, so the leading "-" - ! sign changes to a "+" sign when the term is brought over to the - ! left-hand side, and var_zm is considered to be at timestep (t+1). - ! - ! The result is dependent only on values of var_zm found at momentum - ! levels 1, 2, 3, and 4. Thus, it only affects 4 diagonals on the - ! left-hand side matrix. - ! - ! The lower boundary also effects the discretization at momentum - ! level 1. - ! - ! =var_zm(3)=============================================== m(3) - ! - ! ------d(var_zm)/dz--------------------------------------- t(3) - ! - ! =var_zm(2)====d^2(var_zm)/dz^2=========================== m(2) - ! - ! ------d(var_zm)/dz--------d^3(var_zm)/dz^3--------------- t(2) - ! - ! =var_zm(1)====d^2(var_zm)/dz^2========d^4(var_zm)/dz^4=== m(1) Boundary - ! - ! ------[d(var_zm)/dz = 0]--[d^3(var_zm)/dz^3 = 0]--------- t(1) - ! - ! =[var_zm(0) = var_zm(1)]=====(level outside model)======= m(0) - ! - ! The discretization of -nu*d^4(var_zm)/dz^4 at momentum level (k=1) is - ! written out as follows: - ! - ! -nu*dzm(k)*[dzt(k+1)*{ dzm(k+1)*( dzt(k+2)*(var_zm(k+2)-var_zm(k+1)) - ! -dzt(k+1)*(var_zm(k+1)-var_zm(k)) ) - ! -dzm(k)*dzt(k+1)*(var_zm(k+1)-var_zm(k)) } ]. - ! - ! Again, the term is treated completely implicitly, so the leading "-" - ! sign changes to a "+" sign when the term is brought over to the - ! left-hand side, and var_zm is considered to be at timestep (t+1). - ! - ! The result is dependent only on values of var_zm found at momentum - ! levels 1, 2, and 3. Thus, it only affects 3 diagonals on the left-hand - ! side matrix. - ! - ! The same method can be used to discretize the upper boundary by - ! considering a new level outside the model just above the upper boundary - ! level. - ! - ! 2) Fixed-point boundary conditions. - ! Many equations in the model use fixed-point boundary conditions rather - ! than zero-flux boundary conditions. This means that the value of - ! var_zm stays the same over the course of the timestep at the lower - ! boundary, as well as at the upper boundary. - ! - ! For a 4th-order term, four boundary conditions are needed. Two - ! boundary conditions are applied at each boundary. For the case of - ! fixed-point boundary conditions, one of those two conditions is setting - ! var_zm = A, where A is a constant value. One more condition is needed. - ! Setting the values of d(var_zm)/dz and d^3(var_zm)/dz^3 are inherently - ! used for zero-flux (or perhaps fixed-flux) boundary conditions. - ! Fixed-point and zero-flux boundary conditions inherently should not be - ! invoked at the same time. The only remaining choice for a second - ! boundary condition for the fixed-point case is setting - ! d^2(var_zm)/dz^2. As it turns out, setting d^2(var_zm)/dz^2 = 0 is the - ! appropriate condition to use because it prevents values of var_zm at - ! levels outside the model from being involved in the discretization of - ! -nu*d^4(var_zm)/dz^4 at momentum level 2. Setting d^3(var_zm)/dz^3 = 0 - ! does not accomplish the same thing for the discretization of - ! -nu*d^4(var_zm)/dz^4 at momentum level 2. Also, as stated above, - ! fourth-order numerical diffusion is used in conjunction with - ! second-order eddy diffusion, +d[(K_zt+nu)*d(var_zm)/dz]/dz, where the - ! coefficient of eddy diffusivity, (K_zt+nu), varies in the vertical. - ! Both 4th-order numerical diffusion and 2nd-order eddy diffusion use the - ! same boundary condition type at all times, which in this case is - ! fixed-point boundary conditions. For 2nd-order eddy diffusion, - ! fixed-point boundary conditions set var_zm = A, and do not set - ! d(var_zm)/dz. Thus, d(var_zm)/dz cannot be set for fixed-point - ! boundary conditions. As previously stated, the only other boundary - ! condition that can be invoked for a fixed-point boundary case is - ! d^2(var_zm)/dz^2 = 0. - ! - ! Since the normal discretization includes two levels on either side of - ! the central level, the lower boundary begins to effect the - ! discretization at momentum level 2. - ! - ! =var_zm(4)=============================================== m(4) - ! - ! ------d(var_zm)/dz--------------------------------------- t(4) - ! - ! =var_zm(3)====d^2(var_zm)/dz^2=========================== m(3) - ! - ! ------d(var_zm)/dz--------d^3(var_zm)/dz^3--------------- t(3) - ! - ! =var_zm(2)====d^2(var_zm)/dz^2========d^4(var_zm)/dz^4=== m(2) - ! - ! ------d(var_zm)/dz--------d^3(var_zm)/dz^3--------------- t(2) - ! - ! =var_zm(1)====[d^2(var_zm)/dz^2 = 0]===================== m(1) Boundary - ! - ! ------d(var_zm)/dz--------------------------------------- t(1) - ! - ! =var_zm(0)===================(level outside model)======= m(0) - ! - ! The discretization of -nu*d^4(var_zm)/dz^4 at momentum level (k=2) is - ! written out as follows: - ! - ! -nu*dzm(k)*[ dzt(k+1)*{ dzm(k+1)*( dzt(k+2)*(var_zm(k+2)-var_zm(k+1)) - ! -dzt(k+1)*(var_zm(k+1)-var_zm(k)) ) - ! -dzm(k)*( dzt(k+1)*(var_zm(k+1)-var_zm(k)) - ! -dzt(k)*(var_zm(k)-var_zm(k-1)) ) } - ! -dzt(k)*{ dzm(k)*( dzt(k+1)*(var_zm(k+1)-var_zm(k)) - ! -dzt(k)*(var_zm(k)-var_zm(k-1)) ) } ]. - ! - ! Again, the term is treated completely implicitly, so the leading "-" - ! sign changes to a "+" sign when the term is brought over to the - ! left-hand side, and var_zm is considered to be at timestep (t+1). - ! - ! The result is dependent only on values of var_zm found at momentum - ! levels 1, 2, 3, and 4. Thus, it only affects 4 diagonals on the - ! left-hand side matrix. - ! - ! The same method can be used to discretize -nu*d^4(var_zm)/dz^4 at the - ! second-highest momentum level (k=top-1) by setting d^2(var_zm)/dz^2 = 0 - ! at the highest momentum level. - ! - ! The discretization at momentum level (k=1) is written to simply set the - ! value var_zm(1) = A. Likewise, the discretization at momentum level - ! (k=top) is written to simply set the value var_zm(top) = B. In order - ! to discretize the boundary conditions at the lowest and highest - ! vertical levels for equations requiring fixed-point boundary - ! conditions, either: - ! a) in the parent subroutine or function (that calls this function), - ! loop over all vertical levels from the second-lowest to the - ! second-highest, ignoring the lowest and highest levels. Then set - ! the values at the lowest and highest levels in the parent - ! subroutine; or - ! b) in the parent subroutine or function, loop over all vertical levels - ! and then overwrite the results at the lowest and highest levels. - ! - ! Either way, at the lowest and highest levels, an array with a value - ! of 1 at the main diagonal on the left-hand side and with values of 0 at - ! all other diagonals on the left-hand side will preserve the right-hand - ! side value at that level, thus satisfying the fixed-point boundary - ! conditions. - ! - ! - ! Conservation Properties: - ! - ! When zero-flux boundary conditions are used, this technique of - ! discretizing the 4th-order numerical diffusion term leads to conservative - ! differencing. When conservative differencing is in place, the column - ! totals for each column in the left-hand side matrix (for the 4th-order - ! numerical diffusion term) should be equal to 0. This ensures that the - ! total amount of the quantity var_zm over the entire vertical domain is - ! being conserved, meaning that nothing is lost due to diffusional effects. - ! - ! To see that this conservation law is satisfied, compute the 4th-order - ! numerical diffusion of var_zm and integrate vertically. In discretized - ! matrix notation (where "i" stands for the matrix column and "j" stands for - ! the matrix row): - ! - ! 0 = Sum_j Sum_i ( 1/dzm )_i ( nu*dzm*dzt*dzm*dzt )_ij (var_zm)_j. - ! - ! The left-hand side matrix, ( nu*dzm*dzt*dzm*dzt )_ij, is partially written - ! below. The sum over i in the above equation removes the first dzm(k) - ! everywhere from the matrix below. The sum over j leaves the column totals - ! that are desired. - ! - ! Left-hand side matrix contributions from 4th-order numerical diffusion - ! (or hyper-diffusion) term; first five vertical levels: - ! - ! column 1 || column 2 || column 3 || column 4 || column 5 - ! ------------------------------------------------------------------------------------------> - ! | +nu -nu +nu - ! | *dzm(k) *dzm(k) *dzm(k) - ! | *[ dzt(k+1) *[ dzt(k+1) *dzt(k+1) - ! | *{ dzm(k+1) *{ dzm(k+1) *dzm(k+1) - !k=1| *dzt(k+1) *( dzt(k+2) *dzt(k+2) 0 0 - ! | +dzm(k) +dzt(k+1) ) - ! | *dzt(k+1) } +dzm(k) - ! | ] *dzt(k+1) } ] - ! | - ! | -nu +nu -nu +nu - ! | *dzm(k) *dzm(k) *dzm(k) *dzm(k) - ! | *[ dzt(k+1) *[ dzt(k+1) *[ dzt(k+1) *dzt(k+1) - ! | *dzm(k) *{ dzm(k+1) *{ dzm(k+1) *dzm(k+1) - ! | *dzt(k) *dzt(k+1) *( dzt(k+2) *dzt(k+2) - ! | +dzt(k) +dzm(k) +dzt(k+1) ) - !k=2| *{ dzm(k) *( dzt(k+1) +dzm(k) 0 - ! | *dzt(k) +dzt(k) ) } *dzt(k+1) } - ! | +dzm(k-1) +dzt(k) +dzt(k) - ! | *dzt(k) } ] *{ dzm(k) *dzm(k) - ! | *( dzt(k+1) *dzt(k+1) ] - ! | +dzt(k) ) - ! | +dzm(k-1) - ! | *dzt(k) } ] - ! | - ! | +nu -nu +nu -nu +nu - ! | *dzm(k) *dzm(k) *dzm(k) *dzm(k) *dzm(k) - ! | *dzt(k) *[ dzt(k+1) *[ dzt(k+1) *[ dzt(k+1) *dzt(k+1) - ! | *dzm(k-1) *dzm(k) *{ dzm(k+1) *{ dzm(k+1) *dzm(k+1) - ! | *dzt(k-1) *dzt(k) *dzt(k+1) *( dzt(k+2) *dzt(k+2) - ! | +dzt(k) +dzm(k) +dzt(k+1) ) - !k=3| *{ dzm(k) *( dzt(k+1) +dzm(k) - ! | *dzt(k) +dzt(k) ) } *dzt(k+1) } - ! | +dzm(k-1) +dzt(k) +dzt(k) - ! | *( dzt(k) *{ dzm(k) *dzm(k) - ! | +dzt(k-1) ) *( dzt(k+1) *dzt(k+1) ] - ! | } ] +dzt(k) ) - ! | +dzm(k-1) - ! | *dzt(k) } ] - ! | - ! | +nu -nu +nu -nu - ! | *dzm(k) *dzm(k) *dzm(k) *dzm(k) - ! | *dzt(k) *[ dzt(k+1) *[ dzt(k+1) *[ dzt(k+1) - ! | *dzm(k-1) *dzm(k) *{ dzm(k+1) *{ dzm(k+1) - ! | *dzt(k-1) *dzt(k) *dzt(k+1) *( dzt(k+2) - ! | +dzt(k) +dzm(k) +dzt(k+1) ) - !k=4| 0 *{ dzm(k) *( dzt(k+1) +dzm(k) - ! | *dzt(k) +dzt(k) ) } *dzt(k+1) } - ! | +dzm(k-1) +dzt(k) +dzt(k) - ! | *( dzt(k) *{ dzm(k) *dzm(k) - ! | +dzt(k-1) ) *( dzt(k+1) *dzt(k+1) ] - ! | } ] +dzt(k) ) - ! | +dzm(k-1) - ! | *dzt(k) } ] - ! | - ! | +nu -nu +nu - ! | *dzm(k) *dzm(k) *dzm(k) - ! | *dzt(k) *[ dzt(k+1) *[ dzt(k+1) - ! | *dzm(k-1) *dzm(k) *{ dzm(k+1) - ! | *dzt(k-1) *dzt(k) *dzt(k+1) - ! | +dzt(k) +dzm(k) - !k=5| 0 0 *{ dzm(k) *( dzt(k+1) - ! | *dzt(k) +dzt(k) ) } - ! | +dzm(k-1) +dzt(k) - ! | *( dzt(k) *{ dzm(k) - ! | +dzt(k-1) ) *( dzt(k+1) - ! | } ] +dzt(k) ) - ! | +dzm(k-1) - ! | *dzt(k) } ] - ! \ / - ! - ! Note: The super-super diagonal term from level 4 and both the super - ! diagonal and super-super diagonal terms from level 5 are not shown - ! on this diagram. - ! - ! Note: The matrix shown is a five-diagonal matrix. For a nine-diagonal - ! matrix, there would be an extra row between each of the rows shown - ! and an extra column between each of the columns shown. However, - ! for the purposes of the var_zm 4th-order hyper-diffusion term, - ! those extra row and column values are all 0, and the conservation - ! properties of the matrix aren't effected. - ! - ! For the case of fixed-point boundary conditions, the contributions of the - ! 4th-order hyper-diffusion term are as follows (only the top 2 levels - ! differ from the matrix diagram above): - ! - ! column 1 || column 2 || column 3 || column 4 || column 5 - ! ------------------------------------------------------------------------------------------> - !k=1| 0 0 0 0 0 - ! | - ! | -nu +nu -nu +nu - ! | *dzm(k) *dzm(k) *dzm(k) *dzm(k) - ! | *[ dzt(k+1) *[ dzt(k+1) *[ dzt(k+1) *dzt(k+1) - ! | *dzm(k) *{ dzm(k+1) *{ dzm(k+1) *dzm(k+1) - ! | *dzt(k) *dzt(k+1) *( dzt(k+2) *dzt(k+2) - !k=2| +dzt(k) +dzm(k) +dzt(k+1) ) 0 - ! | *dzm(k) *( dzt(k+1) +dzm(k) - ! | *dzt(k) ] +dzt(k) ) } *dzt(k+1) } - ! | +dzt(k) +dzt(k) - ! | *dzm(k) *dzm(k) - ! | *( dzt(k+1) *dzt(k+1) ] - ! | +dzt(k) ) ] - ! \ / - ! - ! For the left-hand side matrix as a whole, the matrix entries at level 1 - ! (k=1) read: 1 0 0 0 0. For the case of fixed-point boundary - ! conditions, conservative differencing is not in play. The total amount of - ! var_zm over the entire vertical domain is not being conserved, as amounts - ! of var_zm may be fluxed out through the upper boundary or lower boundary - ! through the effects of diffusion. - ! - ! Brian Griffin. September 28, 2008. - - ! References: - ! None - !----------------------------------------------------------------------- - - use clubb_precision, only: & - core_rknd ! Variable(s) - - use grid_class, only: & - gr ! Variable(s) gr%nz - - implicit none - - ! Constant parameters - integer, parameter :: & - kp2_mdiag = 1, & ! Momentum super-super diagonal index. - kp1_mdiag = 2, & ! Momentum super diagonal index. - k_mdiag = 3, & ! Momentum main diagonal index. - km1_mdiag = 4, & ! Momentum sub diagonal index. - km2_mdiag = 5 ! Momentum sub-sub diagonal index. - - ! Input Variables - character (len=*), intent(in) :: & - boundary_cond ! Type of boundary conditions being used - ! ('zero-flux' or 'fixed-point'). - - real( kind = core_rknd ), intent(in) :: & - nu, & ! Constant coef. of 4th-order numerical diffusion [m^4/s] - invrs_dzm, & ! Inverse of grid spacing over momentum level (k) [1/m] - invrs_dztp1, & ! Inverse of grid spacing over thermo. level (k+1) [1/m] - invrs_dzt, & ! Inverse of grid spacing over thermo. level (k) [1/m] - invrs_dzmp1, & ! Inverse of grid spacing over momentum level (k+1) [1/m] - invrs_dzmm1, & ! Inverse of grid spacing over momentum level (k-1) [1/m] - invrs_dztp2, & ! Inverse of grid spacing over thermo. level (k+2) [1/m] - invrs_dztm1 ! Inverse of grid spacing over thermo. level (k-1) [1/m] - - integer, intent(in) :: & - level ! Momentum level where calculation occurs. [-] - - ! Return Variable - real( kind = core_rknd ), dimension(5) :: lhs - - - if ( level == 1 ) then - - ! Lowest level - ! k = 1; lower boundery level at surface. - ! Only relevant if zero-flux boundary conditions are used. - - if ( trim( boundary_cond ) == 'zero-flux' ) then - - ! Zero-flux boundary conditions - - ! Momentum sub-sub diagonal: [ x var_zm(k-2,) ] - lhs(km2_mdiag) & - = 0.0_core_rknd - - ! Momentum sub diagonal: [ x var_zm(k-1,) ] - lhs(km1_mdiag) & - = 0.0_core_rknd - - ! Momentum main diagonal: [ x var_zm(k,) ] - lhs(k_mdiag) & - = +nu*invrs_dzm & - *invrs_dztp1*(invrs_dzmp1*invrs_dztp1 + invrs_dzm*invrs_dztp1) - - ! Momentum super diagonal: [ x var_zm(k+1,) ] - lhs(kp1_mdiag) & - = -nu*invrs_dzm & - *invrs_dztp1*( invrs_dzmp1*(invrs_dztp2 + invrs_dztp1) & - +invrs_dzm*invrs_dztp1 ) - - ! Momentum super-super diagonal: [ x var_zm(k+2,) ] - lhs(kp2_mdiag) & - = +nu*invrs_dzm & - *invrs_dztp1*invrs_dzmp1*invrs_dztp2 - - elseif ( trim( boundary_cond ) == 'fixed-point' ) then - - ! Fixed-point boundary conditions - ! The left-hand side matrix contributions from level 1 are - ! over-written or set in the parent subroutine. - - ! Momentum sub-sub diagonal: [ x var_zm(k-2,) ] - lhs(km2_mdiag) & - = 0.0_core_rknd - - ! Momentum sub diagonal: [ x var_zm(k-1,) ] - lhs(km1_mdiag) & - = 0.0_core_rknd - - ! Momentum main diagonal: [ x var_zm(k,) ] - lhs(k_mdiag) & - = 0.0_core_rknd - - ! Momentum super diagonal: [ x var_zm(k+1,) ] - lhs(kp1_mdiag) & - = 0.0_core_rknd - - ! Momentum super-super diagonal: [ x var_zm(k+2,) ] - lhs(kp2_mdiag) & - = 0.0_core_rknd - - endif - - - elseif ( level == 2 ) then - - ! Second-lowest level - - if ( trim( boundary_cond ) == 'zero-flux' ) then - - ! Zero-flux boundary conditions - - ! Momentum sub-sub diagonal: [ x var_zm(k-2,) ] - lhs(km2_mdiag) & - = 0.0_core_rknd - - ! Momentum sub diagonal: [ x var_zm(k-1,) ] - lhs(km1_mdiag) & - = -nu*invrs_dzm & - *( invrs_dztp1*invrs_dzm*invrs_dzt & - +invrs_dzt*( invrs_dzm*invrs_dzt & - +invrs_dzmm1*invrs_dzt ) ) - - ! Momentum main diagonal: [ x var_zm(k,) ] - lhs(k_mdiag) & - = +nu*invrs_dzm & - *( invrs_dztp1*( invrs_dzmp1*invrs_dztp1 & - +invrs_dzm*(invrs_dztp1 + invrs_dzt) ) & - +invrs_dzt*( invrs_dzm*(invrs_dztp1 + invrs_dzt) & - +invrs_dzmm1*invrs_dzt ) ) - - ! Momentum super diagonal: [ x var_zm(k+1,) ] - lhs(kp1_mdiag) & - = -nu*invrs_dzm & - *( invrs_dztp1*( invrs_dzmp1*(invrs_dztp2 + invrs_dztp1) & - +invrs_dzm*invrs_dztp1 ) & - +invrs_dzt*invrs_dzm*invrs_dztp1 ) - - ! Momentum super-super diagonal: [ x var_zm(k+2,) ] - lhs(kp2_mdiag) & - = +nu*invrs_dzm & - *invrs_dztp1*invrs_dzmp1*invrs_dztp2 - - elseif ( trim( boundary_cond ) == 'fixed-point' ) then - - ! Fixed-point boundary conditions - - ! Momentum sub-sub diagonal: [ x var_zm(k-2,) ] - lhs(km2_mdiag) & - = 0.0_core_rknd - - ! Momentum sub diagonal: [ x var_zm(k-1,) ] - lhs(km1_mdiag) & - = -nu*invrs_dzm & - *( invrs_dztp1*invrs_dzm*invrs_dzt & - +invrs_dzt*invrs_dzm*invrs_dzt ) - - ! Momentum main diagonal: [ x var_zm(k,) ] - lhs(k_mdiag) & - = +nu*invrs_dzm & - *( invrs_dztp1*( invrs_dzmp1*invrs_dztp1 & - +invrs_dzm*(invrs_dztp1 + invrs_dzt) ) & - +invrs_dzt*invrs_dzm*(invrs_dztp1 + invrs_dzt) ) - - ! Momentum super diagonal: [ x var_zm(k+1,) ] - lhs(kp1_mdiag) & - = -nu*invrs_dzm & - *( invrs_dztp1*( invrs_dzmp1*(invrs_dztp2 + invrs_dztp1) & - +invrs_dzm*invrs_dztp1 ) & - +invrs_dzt*invrs_dzm*invrs_dztp1 ) - - ! Momentum super-super diagonal: [ x var_zm(k+2,) ] - lhs(kp2_mdiag) & - = +nu*invrs_dzm & - *invrs_dztp1*invrs_dzmp1*invrs_dztp2 - - endif - - - elseif ( level > 2 .and. level < gr%nz-1 ) then - - ! k > 2 and k < num_levels-1 - ! These interior level are not effected by boundary conditions. - - ! Momentum sub-sub diagonal: [ x var_zm(k-2,) ] - lhs(km2_mdiag) & - = +nu*invrs_dzm & - *invrs_dzt*invrs_dzmm1*invrs_dztm1 - - ! Momentum sub diagonal: [ x var_zm(k-1,) ] - lhs(km1_mdiag) & - = -nu*invrs_dzm & - *( invrs_dztp1*invrs_dzm*invrs_dzt & - +invrs_dzt*( invrs_dzm*invrs_dzt & - +invrs_dzmm1*(invrs_dzt + invrs_dztm1) ) ) - - ! Momentum main diagonal: [ x var_zm(k,) ] - lhs(k_mdiag) & - = +nu*invrs_dzm & - *( invrs_dztp1*( invrs_dzmp1*invrs_dztp1 & - +invrs_dzm*(invrs_dztp1 + invrs_dzt) ) & - +invrs_dzt*( invrs_dzm*(invrs_dztp1 + invrs_dzt) & - +invrs_dzmm1*invrs_dzt ) ) - - ! Momentum super diagonal: [ x var_zm(k+1,) ] - lhs(kp1_mdiag) & - = -nu*invrs_dzm & - *( invrs_dztp1*( invrs_dzmp1*(invrs_dztp2 + invrs_dztp1) & - +invrs_dzm*invrs_dztp1 ) & - +invrs_dzt*invrs_dzm*invrs_dztp1 ) - - ! Momentum super-super diagonal: [ x var_zm(k+2,) ] - lhs(kp2_mdiag) & - = +nu*invrs_dzm & - *invrs_dztp1*invrs_dzmp1*invrs_dztp2 - - - elseif ( level == gr%nz-1 ) then - - ! Second-highest level - - if ( trim( boundary_cond ) == 'zero-flux' ) then - - ! Zero-flux boundary conditions - - ! Momentum sub-sub diagonal: [ x var_zm(k-2,) ] - lhs(km2_mdiag) & - = +nu*invrs_dzm & - *invrs_dzt*invrs_dzmm1*invrs_dztm1 - - ! Momentum sub diagonal: [ x var_zm(k-1,) ] - lhs(km1_mdiag) & - = -nu*invrs_dzm & - *( invrs_dztp1*invrs_dzm*invrs_dzt & - +invrs_dzt*( invrs_dzm*invrs_dzt & - +invrs_dzmm1*(invrs_dzt + invrs_dztm1) ) ) - - ! Momentum main diagonal: [ x var_zm(k,) ] - lhs(k_mdiag) & - = +nu*invrs_dzm & - *( invrs_dztp1*( invrs_dzmp1*invrs_dztp1 & - +invrs_dzm*(invrs_dztp1 + invrs_dzt) ) & - +invrs_dzt*( invrs_dzm*(invrs_dztp1 + invrs_dzt) & - +invrs_dzmm1*invrs_dzt ) ) - - ! Momentum super diagonal: [ x var_zm(k+1,) ] - lhs(kp1_mdiag) & - = -nu*invrs_dzm & - *( invrs_dztp1*( invrs_dzmp1*invrs_dztp1 & - +invrs_dzm*invrs_dztp1 ) & - +invrs_dzt*invrs_dzm*invrs_dztp1 ) - - ! Momentum super-super diagonal: [ x var_zm(k+2,) ] - lhs(kp2_mdiag) & - = 0.0_core_rknd - - elseif ( trim( boundary_cond ) == 'fixed-point' ) then - - ! Fixed-point boundary conditions - - ! Momentum sub-sub diagonal: [ x var_zm(k-2,) ] - lhs(km2_mdiag) & - = +nu*invrs_dzm & - *invrs_dzt*invrs_dzmm1*invrs_dztm1 - - ! Momentum sub diagonal: [ x var_zm(k-1,) ] - lhs(km1_mdiag) & - = -nu*invrs_dzm & - *( invrs_dztp1*invrs_dzm*invrs_dzt & - +invrs_dzt*( invrs_dzm*invrs_dzt & - +invrs_dzmm1*(invrs_dzt + invrs_dztm1) ) ) - - ! Momentum main diagonal: [ x var_zm(k,) ] - lhs(k_mdiag) & - = +nu*invrs_dzm & - *( invrs_dztp1*( invrs_dzm*(invrs_dztp1 + invrs_dzt) ) & - +invrs_dzt*( invrs_dzm*(invrs_dztp1 + invrs_dzt) & - +invrs_dzmm1*invrs_dzt ) ) - - ! Momentum super diagonal: [ x var_zm(k+1,) ] - lhs(kp1_mdiag) & - = -nu*invrs_dzm & - *( invrs_dztp1*invrs_dzm*invrs_dztp1 & - +invrs_dzt*invrs_dzm*invrs_dztp1 ) - - ! Momentum super-super diagonal: [ x var_zm(k+2,) ] - lhs(kp2_mdiag) & - = 0.0_core_rknd - - endif - - - elseif ( level == gr%nz ) then - - ! Highest level - ! k = gr%nz; upper boundery level at model top. - ! Only relevant if zero-flux boundary conditions are used. - - if ( trim( boundary_cond ) == 'zero-flux' ) then - - ! Zero-flux boundary conditions - - ! Momentum sub-sub diagonal: [ x var_zm(k-2,) ] - lhs(km2_mdiag) & - = +nu*invrs_dzm & - *invrs_dzt*invrs_dzmm1*invrs_dztm1 - - ! Momentum sub diagonal: [ x var_zm(k-1,) ] - lhs(km1_mdiag) & - = -nu*invrs_dzm & - *invrs_dzt*( invrs_dzm*invrs_dzt & - +invrs_dzmm1*(invrs_dzt + invrs_dztm1) ) - - ! Momentum main diagonal: [ x var_zm(k,) ] - lhs(k_mdiag) & - = +nu*invrs_dzm & - *invrs_dzt*(invrs_dzm*invrs_dzt + invrs_dzmm1*invrs_dzt) - - ! Momentum super diagonal: [ x var_zm(k+1,) ] - lhs(kp1_mdiag) & - = 0.0_core_rknd - - ! Momentum super-super diagonal: [ x var_zm(k+2,) ] - lhs(kp2_mdiag) & - = 0.0_core_rknd - - elseif ( trim( boundary_cond ) == 'fixed-point' ) then - - ! Fixed-point boundary conditions - ! The left-hand side matrix contributions from level gr%nz are - ! over-written or set in the parent subroutine. - - ! Momentum sub-sub diagonal: [ x var_zm(k-2,) ] - lhs(km2_mdiag) & - = 0.0_core_rknd - - ! Momentum sub diagonal: [ x var_zm(k-1,) ] - lhs(km1_mdiag) & - = 0.0_core_rknd - - ! Momentum main diagonal: [ x var_zm(k,) ] - lhs(k_mdiag) & - = 0.0_core_rknd - - ! Momentum super diagonal: [ x var_zm(k+1,) ] - lhs(kp1_mdiag) & - = 0.0_core_rknd - - ! Momentum super-super diagonal: [ x var_zm(k+2,) ] - lhs(kp2_mdiag) & - = 0.0_core_rknd - - endif - - - endif - - - return - - end function hyper_dfsn_4th_ord_zm_lhs - -!=============================================================================== - -end module hyper_diffusion_4th_ord diff --git a/models/atm/cam/src/physics/clubb/index_mapping.F90 b/models/atm/cam/src/physics/clubb/index_mapping.F90 new file mode 100644 index 000000000000..7127f62226fe --- /dev/null +++ b/models/atm/cam/src/physics/clubb/index_mapping.F90 @@ -0,0 +1,363 @@ +!--------------------------------------------------------------------------- +! $Id: index_mapping.F90 7118 2014-07-25 00:12:15Z raut@uwm.edu $ +!=============================================================================== +module index_mapping + + ! Description: + ! Functions to map back and forth between the PDF arrays and the hydrometeor + ! arrays. + + ! References: + ! None + !------------------------------------------------------------------------- + + ! Hydrometeor array indices + use array_index, only: & + iirrm, & ! Hydrometeor array index for rain water mixing ratio, rr + iirsm, & ! Hydrometeor array index for snow mixing ratio, rs + iirim, & ! Hydrometeor array index for ice mixing ratio, ri + iirgm, & ! Hydrometeor array index for graupel mixing ratio, rg + iiNrm, & ! Hydrometeor array index for rain drop concentration, Nr + iiNsm, & ! Hydrometeor array index for snow concentration, Ns + iiNim, & ! Hydrometeor array index for ice concentration, Ni + iiNgm ! Hydrometeor array index for graupel concentration, Ng + + ! PDF array indices + use corr_varnce_module, only: & + iiPDF_rr, & ! PDF array index for rain water mixing ratio, rr + iiPDF_rs, & ! PDF array index for snow mixing ratio, rs + iiPDF_ri, & ! PDF array index for ice mixing ratio, ri + iiPDF_rg, & ! PDF array index for graupel mixing ratio, rg + iiPDF_Nr, & ! PDF array index for rain drop concentration, Nr + iiPDF_Ns, & ! PDF array index for snow concentration, Ns + iiPDF_Ni, & ! PDF array index for ice concentration, Ni + iiPDF_Ng ! PDF array index for graupel concentration, Ng + + implicit none + + private ! Default Scope + + public :: pdf2hydromet_idx, & + hydromet2pdf_idx, & + rx2Nx_hm_idx, & + Nx2rx_hm_idx, & + mvr_hm_max + +contains + + !============================================================================= + function pdf2hydromet_idx( pdf_idx ) result( hydromet_idx ) + + ! Description: + ! Returns the position of a specific precipitating hydrometeor corresponding + ! to the PDF index (pdf_idx) in the precipitating hydrometeor array + ! (hydromet_idx). + + ! References: + !----------------------------------------------------------------------- + + implicit none + + ! Input Variables + integer, intent(in) :: & + pdf_idx ! Index of a hydrometeor in the PDF array. + + ! Return Variable + integer :: & + hydromet_idx ! Index of a hydrometeor in the hydromet array. + + + ! Initialize hydromet_idx + hydromet_idx = 0 + + if ( pdf_idx == iiPDF_rr ) then + + ! Index for rain water mixing ratio, rr. + hydromet_idx = iirrm + + elseif ( pdf_idx == iiPDF_Nr ) then + + ! Index for rain drop concentration, Nr. + hydromet_idx = iiNrm + + elseif ( pdf_idx == iiPDF_rs ) then + + ! Index for snow mixing ratio, rs. + hydromet_idx = iirsm + + elseif ( pdf_idx == iiPDF_Ns ) then + + ! Index for snow flake concentration, Ns. + hydromet_idx = iiNsm + + elseif ( pdf_idx == iiPDF_rg ) then + + ! Index for graupel mixing ratio, rg. + hydromet_idx = iirgm + + elseif ( pdf_idx == iiPDF_Ng ) then + + ! Index for graupel concentration, Ng. + hydromet_idx = iiNgm + + elseif ( pdf_idx == iiPDF_ri ) then + + ! Index for ice mixing ratio, ri. + hydromet_idx = iirim + + elseif ( pdf_idx == iiPDF_Ni ) then + + ! Index for ice concentration, Ni. + hydromet_idx = iiNim + + endif + + + return + + end function pdf2hydromet_idx + + !============================================================================= + function hydromet2pdf_idx( hydromet_idx ) result( pdf_idx ) + + ! Description: + ! Returns the position of a specific precipitating hydrometeor corresponding + ! to the precipitating hydrometeor index (hydromet_idx) in the PDF array + ! (pdf_idx). + + ! References: + !----------------------------------------------------------------------- + + implicit none + + ! Input Variable + integer, intent(in) :: & + hydromet_idx ! Index of a hydrometeor in the hydromet array. + + ! Return Variable + integer :: & + pdf_idx ! Index of a hydrometeor in the PDF array. + + + ! Initialize pdf_idx. + pdf_idx = 0 + + if ( hydromet_idx == iirrm ) then + + ! Index for rain water mixing ratio, rr. + pdf_idx = iiPDF_rr + + elseif ( hydromet_idx == iiNrm ) then + + ! Index for rain drop concentration, Nr. + pdf_idx = iiPDF_Nr + + elseif ( hydromet_idx == iirim ) then + + ! Index for ice mixing ratio, ri. + pdf_idx = iiPDF_ri + + elseif ( hydromet_idx == iiNim ) then + + ! Index for ice concentration, Ni. + pdf_idx = iiPDF_Ni + + elseif ( hydromet_idx == iirsm ) then + + ! Index for snow mixing ratio, rs. + pdf_idx = iiPDF_rs + + elseif ( hydromet_idx == iiNsm ) then + + ! Index for snow flake concentration, Ns. + pdf_idx = iiPDF_Ns + + elseif ( hydromet_idx == iirgm ) then + + ! Index for graupel mixing ratio, rg. + pdf_idx = iiPDF_rg + + elseif ( hydromet_idx == iiNgm ) then + + ! Index for graupel concentration, Ng. + pdf_idx = iiPDF_Ng + + endif + + + return + + end function hydromet2pdf_idx + + !============================================================================= + function rx2Nx_hm_idx( rx_idx ) result( Nx_idx ) + + ! Description: + ! Returns the position in the hydrometeor array of the specific + ! precipitating hydrometeor concentration (Nx_idx) corresponding to the + ! precipitating hydrometeor mixing ratio (rx_idx) of the same species of + ! precipitating hydrometeor (rain, ice, snow, or graupel). + + ! References: + !----------------------------------------------------------------------- + + implicit none + + ! Input Variable + integer, intent(in) :: & + rx_idx ! Index of the mixing ratio in the hydrometeor array. + + ! Return Variable + integer :: & + Nx_idx ! Index of the concentration in the hydrometeor array. + + + ! Initialize Nx_idx. + Nx_idx = 0 + + if ( rx_idx == iirrm ) then + + ! Index for rain drop concentration, Nr. + Nx_idx = iiNrm + + elseif ( rx_idx == iirim ) then + + ! Index for ice crystal concentration, Ni. + Nx_idx = iiNim + + elseif ( rx_idx == iirsm ) then + + ! Index for snow flake concentration, Ns. + Nx_idx = iiNsm + + elseif ( rx_idx == iirgm ) then + + ! Index for graupel concentration, Ng. + Nx_idx = iiNgm + + endif + + + return + + end function rx2Nx_hm_idx + + !============================================================================= + function Nx2rx_hm_idx( Nx_idx ) result( rx_idx ) + + ! Description: + ! Returns the position in the hydrometeor array of the specific + ! precipitating hydrometeor mixing ratio (rx_idx) corresponding to the + ! precipitating hydrometeor concentration (Nx_idx) of the same species of + ! precipitating hydrometeor (rain, ice, snow, or graupel). + + ! References: + !----------------------------------------------------------------------- + + implicit none + + ! Input Variable + integer, intent(in) :: & + Nx_idx ! Index of the concentration in the hydrometeor array. + + ! Return Variable + integer :: & + rx_idx ! Index of the mixing ratio in the hydrometeor array. + + + ! Initialize rx_idx. + rx_idx = 0 + + if ( Nx_idx == iiNrm ) then + + ! Index for rain water mixing ratio, rr. + rx_idx = iirrm + + elseif ( Nx_idx == iiNim ) then + + ! Index for ice mixing ratio, ri. + rx_idx = iirim + + elseif ( Nx_idx == iiNsm ) then + + ! Index for snow mixing ratio, rs. + rx_idx = iirsm + + elseif ( Nx_idx == iiNgm ) then + + ! Index for graupel mixing ratio, rg. + rx_idx = iirgm + + endif + + + return + + end function Nx2rx_hm_idx + + !============================================================================= + function mvr_hm_max( hydromet_idx ) result( mvr_hydromet_max ) + + ! Description: + ! Returns the maximum allowable mean volume radius of a specific + ! precipitating hydrometeor type (rain, ice, snow, or graupel) corresponding + ! to the precipitating hydrometeor index, whether that index is for the + ! mixing ratio or concentration associated with that hydrometeor type. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + mvr_rain_max, & ! Constant(s) + mvr_ice_max, & + mvr_snow_max, & + mvr_graupel_max, & + zero + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variable + integer, intent(in) :: & + hydromet_idx ! Index of a hydrometeor in the hydromet array. + + ! Return Variable + real( kind = core_rknd ) :: & + mvr_hydromet_max ! Maximum allowable mean volume radius [m] + + + ! Initialize mvr_hydromet_max. + mvr_hydromet_max = zero + + if ( hydromet_idx == iirrm .or. hydromet_idx == iiNrm ) then + + ! Maximum allowable mean volume radius for rain drops. + mvr_hydromet_max = mvr_rain_max + + elseif ( hydromet_idx == iirim .or. hydromet_idx == iiNim ) then + + ! Maximum allowable mean volume radius for ice crystals. + mvr_hydromet_max = mvr_ice_max + + elseif ( hydromet_idx == iirsm .or. hydromet_idx == iiNsm ) then + + ! Maximum allowable mean volume radius for snow flakes. + mvr_hydromet_max = mvr_snow_max + + elseif ( hydromet_idx == iirgm .or. hydromet_idx == iiNgm ) then + + ! Maximum allowable mean volume radius for graupel. + mvr_hydromet_max = mvr_graupel_max + + endif + + + return + + end function mvr_hm_max + +!=============================================================================== + +end module index_mapping diff --git a/models/atm/cam/src/physics/clubb/input_names.F90 b/models/atm/cam/src/physics/clubb/input_names.F90 index 290da17f4734..ad4df85df4e4 100644 --- a/models/atm/cam/src/physics/clubb/input_names.F90 +++ b/models/atm/cam/src/physics/clubb/input_names.F90 @@ -1,4 +1,6 @@ -!$Id: input_names.F90 5378 2011-08-22 20:19:16Z connork@uwm.edu $ +!----------------------------------------------------------------------- +!$Id: input_names.F90 6849 2014-04-22 21:52:30Z charlass@uwm.edu $ +!=============================================================================== module input_names ! ! Description: This module contains all of the strings used to define the diff --git a/models/atm/cam/src/physics/clubb/input_reader.F90 b/models/atm/cam/src/physics/clubb/input_reader.F90 index 627fd5daa1a6..5860603e2034 100644 --- a/models/atm/cam/src/physics/clubb/input_reader.F90 +++ b/models/atm/cam/src/physics/clubb/input_reader.F90 @@ -1,10 +1,15 @@ -!$Id: input_reader.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +!----------------------------------------------------------------------- +!$Id: input_reader.F90 6849 2014-04-22 21:52:30Z charlass@uwm.edu $ +!=============================================================================== module input_reader -! + +! Description: ! This module is respondsible for the procedures and structures necessary to ! read in "SAM-Like" case specific files. Currently only the ! _sounding.in file is formatted to be used by this module. ! +! References: +! None !--------------------------------------------------------------------------------------------------- use clubb_precision, only: & @@ -377,9 +382,6 @@ subroutine fill_blanks_two_dim_vars( num_vars, other_dim, two_dim_vars ) ! None !---------------------------------------------------------------------------------------------- - use clubb_precision, only: & - core_rknd ! Variable(s) - implicit none ! External @@ -431,6 +433,7 @@ end subroutine fill_blanks_two_dim_vars !------------------------------------------------------------------------------------------------ function linear_fill_blanks( dim_grid, grid, var, default_value ) & + result( var_out ) ! ! Description: ! This function fills blanks in array var using the grid @@ -440,7 +443,6 @@ function linear_fill_blanks( dim_grid, grid, var, default_value ) & ! References: ! None !----------------------------------------------------------------------------------------------- - result( var_out ) use interpolation, only: zlinterp_fnc @@ -617,6 +619,9 @@ function read_x_table( nvar, xdim, ydim, target_name, retVars ) result( x ) implicit none + ! External Functions + intrinsic :: trim + ! Input Variable(s) integer, intent(in) :: nvar ! Number of variables in retVars @@ -691,7 +696,7 @@ function read_x_profile( nvar, dim_size, target_name, retVars, & implicit none ! External Functions - intrinsic :: present, size + intrinsic :: present, size, trim ! Input Variable(s) integer, intent(in) :: & @@ -794,6 +799,9 @@ function count_columns( iunit, filename ) result( nCols ) implicit none + ! External + intrinsic :: index, trim, size + ! Input Variables integer, intent(in) :: iunit ! I/O unit character(len=*), intent(in) :: filename ! Name of the file being read from @@ -813,12 +821,12 @@ function count_columns( iunit, filename ) result( nCols ) isComment = .true. - open(unit=iunit, file=trim(filename), status = 'old' ) + open(unit=iunit, file=trim( filename ), status = 'old' ) ! Skip all the comments at the top of the file do while(isComment) read(iunit,fmt='(A)') tmp - k = index(tmp, "!") + k = index( tmp, "!" ) isComment = .false. if(k > 0) then isComment = .true. @@ -843,7 +851,7 @@ function count_columns( iunit, filename ) result( nCols ) end if - do i=1,size(colArray) + do i=1,size( colArray ) if( colArray(i) /= "" ) then ! Increment number of columns until array is blank nCols = nCols+1 end if diff --git a/models/atm/cam/src/physics/clubb/interpolation.F90 b/models/atm/cam/src/physics/clubb/interpolation.F90 index 9b8383785620..3a9fdb6d258e 100644 --- a/models/atm/cam/src/physics/clubb/interpolation.F90 +++ b/models/atm/cam/src/physics/clubb/interpolation.F90 @@ -1,5 +1,6 @@ !------------------------------------------------------------------------------- -!$Id: interpolation.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +!$Id: interpolation.F90 7200 2014-08-13 15:15:12Z betlej@uwm.edu $ +!=============================================================================== module interpolation use clubb_precision, only: & @@ -9,13 +10,14 @@ module interpolation private ! Default Scope - public :: lin_int, binary_search, zlinterp_fnc, & - linear_interpolation, linear_interp_factor, mono_cubic_interp, plinterp_fnc + public :: lin_interpolate_two_points, binary_search, zlinterp_fnc, & + lin_interpolate_on_grid, linear_interp_factor, mono_cubic_interp, plinterp_fnc, & + pvertinterp contains !------------------------------------------------------------------------------- - pure function lin_int( height_int, height_high, height_low, & + function lin_interpolate_two_points( height_int, height_high, height_low, & var_high, var_low ) ! Description: @@ -55,6 +57,8 @@ pure function lin_int( height_int, height_high, height_low, & use clubb_precision, only: & core_rknd ! Variable(s) + use constants_clubb, only: fstderr ! Constant + implicit none ! Input Variables @@ -67,15 +71,21 @@ pure function lin_int( height_int, height_high, height_low, & var_low ! Variable below the interpolation [units vary] ! Output Variables - real( kind = core_rknd ) :: lin_int + real( kind = core_rknd ) :: lin_interpolate_two_points + + ! Check for valid input + if ( abs(height_low - height_high) < 1.0e-12_core_rknd ) then + write(fstderr,*) "lin_interpolate_two_points: height_high and height_low cannot be equal." + stop + end if ! Compute linear interpolation - lin_int = ( ( height_int - height_low )/( height_high - height_low ) ) & + lin_interpolate_two_points = ( ( height_int - height_low )/( height_high - height_low ) ) & * ( var_high - var_low ) + var_low return - end function lin_int + end function lin_interpolate_two_points !------------------------------------------------------------------------------------------------- elemental real( kind = core_rknd ) function linear_interp_factor( factor, var_high, var_low ) @@ -101,7 +111,7 @@ elemental real( kind = core_rknd ) function linear_interp_factor( factor, var_hi return end function linear_interp_factor !------------------------------------------------------------------------------------------------- - pure function mono_cubic_interp & + function mono_cubic_interp & ( z_in, km1, k00, kp1, kp2, zm1, z00, zp1, zp2, fm1, f00, fp1, fp2 ) result ( f_out ) ! Description: @@ -125,7 +135,7 @@ pure function mono_cubic_interp & eps use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Constant use model_flags, only: & l_quintic_poly_interp ! Variable(s) @@ -234,7 +244,7 @@ pure function mono_cubic_interp & ! Prevent an underflow by using a linear interpolation if ( abs( beta ) < eps ) then - f_out = lin_int( z00, zp1, zm1, & + f_out = lin_interpolate_two_points( z00, zp1, zm1, & fp1, fm1 ) else @@ -482,7 +492,7 @@ function zlinterp_fnc( dim_out, dim_src, grid_out, & !kp1 = min( k+1, dim_src ) ! Interpolate - var_out(kint) = lin_int( grid_out(kint), grid_src(k), & + var_out(kint) = lin_interpolate_two_points( grid_out(kint), grid_src(k), & grid_src(km1), var_src(k), var_src(km1) ) ! ( var_src(k) - var_src(km1) ) / & @@ -501,7 +511,67 @@ function zlinterp_fnc( dim_out, dim_src, grid_out, & end function zlinterp_fnc !------------------------------------------------------------------------------- - subroutine linear_interpolation & + subroutine pvertinterp & + ( nlev, pmid, pout, arrin, arrout ) + + implicit none + + !------------------------------Arguments-------------------------------- + integer , intent(in) :: nlev ! vertical dimension + real( kind = core_rknd ), intent(in) :: pmid(nlev) ! input level pressure levels + real( kind = core_rknd ), intent(in) :: pout ! output pressure level + real( kind = core_rknd ), intent(in) :: arrin(nlev) ! input array + real( kind = core_rknd ), intent(out) :: arrout ! output array (interpolated) + + !---------------------------Local variables----------------------------- + integer i,k ! indices + integer kupper ! Level indices for interpolation + real( kind = core_rknd ) dpu ! upper level pressure difference + real( kind = core_rknd ) dpl ! lower level pressure difference + logical found ! true if input levels found + logical error ! true if error + !----------------------------------------------------------------- + ! + ! Initialize index array and logical flags + ! + + found = .false. + kupper = 1 + + error = .false. + ! + ! Store level indices for interpolation. + ! If all indices for this level have been found, + ! do the interpolation + ! + do k=1,nlev-1 + if ((.not. found) .and. pmid(k)>pout .and. pout>=pmid(k+1)) then + found = .true. + kupper = k + end if + end do + ! + ! If we've fallen through the k=1,nlev-1 loop, we cannot interpolate and + ! must extrapolate from the bottom or top data level for at least some + ! of the longitude points. + ! + if (pout >= pmid(1)) then + arrout = arrin(1) + else if (pout <= pmid(nlev)) then + arrout = arrin(nlev) + else if (found) then + dpu = pmid(kupper) - pout + dpl = pout - pmid(kupper+1) + arrout = (arrin(kupper)*dpl + arrin(kupper+1)*dpu)/(dpl + dpu) + else + error = .true. + end if + + return + end subroutine pvertinterp + +!------------------------------------------------------------------------------- + subroutine lin_interpolate_on_grid & ( nparam, xlist, tlist, xvalue, tvalue ) ! Description: @@ -515,7 +585,9 @@ subroutine linear_interpolation & ! Author: Michael Falk for COAMPS. !------------------------------------------------------------------------------- - use error_code, only: clubb_debug ! Procedure + use error_code, only: & + clubb_debug, & ! Procedure(s) + clubb_at_least_debug_level use constants_clubb, only: fstderr ! Constant @@ -540,42 +612,27 @@ subroutine linear_interpolation & ! Local variables integer :: & - i, & ! Loop control variable for bubble sort- number of the - ! lowest yet-unsorted data point. - j ! Loop control variable for bubble sort- index of value - ! currently being tested + i ! Loop control variable + integer :: & bottombound, & ! Index of the smaller value in the linear interpolation - topbound, & ! Index of the larger value in the linear interpolation - smallest ! Index of the present smallest value, for bubble sort - - real( kind = core_rknd ) :: temp ! A temporary variable used for the bubble sort swap + topbound ! Index of the larger value in the linear interpolation !------------------------------------------------------------------------------- ! -! Bubble Sort algorithm, assuring that the elements are in order so -! that the interpolation is between the two closest points to the -! point in question. +! Assure that the elements are in order so that the interpolation is between +! the two closest points to the point in question. ! !------------------------------------------------------------------------------- - do i=1,nparam - smallest = i - do j=i,nparam - if ( xlist(j) < xlist(smallest) ) then - smallest = j - end if - end do - - temp = xlist(i) - xlist(i) = xlist(smallest) - xlist(smallest) = temp - - temp = tlist(i) - tlist(i) = tlist(smallest) - tlist(smallest) = temp - end do - + if ( clubb_at_least_debug_level( 2 ) ) then + do i=2,nparam + if ( xlist(i) <= xlist(i-1) ) then + write(fstderr,*) "xlist must be sorted for lin_interpolate_on_grid." + stop + end if + end do + end if !------------------------------------------------------------------------------- ! ! If the point in question is larger than the largest x-value or @@ -584,7 +641,7 @@ subroutine linear_interpolation & !------------------------------------------------------------------------------- if ( (xvalue < xlist(1)) .or. (xvalue > xlist(nparam)) ) then - write(fstderr,*) "linear_interpolation: Value out of range" + write(fstderr,*) "lin_interpolate_on_grid: Value out of range" stop end if @@ -607,14 +664,14 @@ subroutine linear_interpolation & if ( topbound == -1 .or. bottombound == -1 ) then call clubb_debug( 1, "Sanity check failed! xlist is not properly sorted" ) - call clubb_debug( 1, "in linear_interpolation.") + call clubb_debug( 1, "in lin_interpolate_on_grid.") end if tvalue = & - lin_int( xvalue, xlist(topbound), xlist(bottombound), & + lin_interpolate_two_points( xvalue, xlist(topbound), xlist(bottombound), & tlist(topbound), tlist(bottombound) ) return - end subroutine linear_interpolation + end subroutine lin_interpolate_on_grid end module interpolation diff --git a/models/atm/cam/src/physics/clubb/lapack_wrap.F90 b/models/atm/cam/src/physics/clubb/lapack_wrap.F90 index 472dca4a49d6..5cc726de8270 100644 --- a/models/atm/cam/src/physics/clubb/lapack_wrap.F90 +++ b/models/atm/cam/src/physics/clubb/lapack_wrap.F90 @@ -1,5 +1,6 @@ !----------------------------------------------------------------------- -! $Id: lapack_wrap.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +! $Id: lapack_wrap.F90 6849 2014-04-22 21:52:30Z charlass@uwm.edu $ +!=============================================================================== module lapack_wrap ! Description: @@ -20,7 +21,8 @@ module lapack_wrap clubb_no_error use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd, & ! Variable(s) + dp implicit none @@ -36,8 +38,7 @@ module lapack_wrap ! precision float is in LAPACK. Hopefully this will work more portably on ! architectures like Itanium than the old code -dschanen 11 Aug 2011 integer, parameter, private :: & - sp = selected_real_kind( precision( 0.0_core_rknd ) ), & - dp = selected_real_kind( precision( 0.d0 ) ) + sp = kind ( 0.0 ) private ! Set Default Scope @@ -251,6 +252,12 @@ subroutine tridag_solve & ! Local Variables + real( kind = dp ), dimension(ndim) :: & + subd_dp, supd_dp, diag_dp + + real( kind = dp ), dimension(ndim,nrhs) :: & + rhs_dp + integer :: info ! Diagnostic output !----------------------------------------------------------------------- @@ -267,8 +274,18 @@ subroutine tridag_solve & rhs, ndim, info ) else - stop "tridag_solve: Cannot resolve the precision of real datatype" - + !stop "tridag_solve: Cannot resolve the precision of real datatype" + ! Eric Raut Aug 2013: Force double precision + subd_dp = real( subd, kind=dp ) + diag_dp = real( diag, kind=dp ) + supd_dp = real( supd, kind=dp ) + rhs_dp = real( rhs, kind=dp ) + call dgtsv( ndim, nrhs, subd_dp(2:ndim), diag_dp, supd_dp(1:ndim-1), & + rhs_dp, ndim, info ) + subd = real( subd_dp, kind=core_rknd ) + diag = real( diag_dp, kind=core_rknd ) + supd = real( supd_dp, kind=core_rknd ) + rhs = real( rhs_dp, kind=core_rknd ) end if select case( info ) @@ -567,6 +584,12 @@ subroutine band_solve( solve_type, nsup, nsub, ndim, nrhs, & real( kind = core_rknd ), dimension(2*nsub+nsup+1,ndim) :: & lulhs ! LU Decomposition of the LHS + real( kind = dp ), dimension(2*nsub+nsup+1,ndim) :: & + lulhs_dp + + real( kind = dp ), dimension(ndim,nrhs) :: & + rhs_dp + integer, dimension(ndim) :: & ipivot @@ -576,7 +599,7 @@ subroutine band_solve( solve_type, nsup, nsub, ndim, nrhs, & imain ! Main diagonal of the matrix ! Copy LHS into Decomposition scratch space - + lulhs = 0.0_core_rknd lulhs(nsub+1:2*nsub+nsup+1, 1:ndim) = lhs(1:nsub+nsup+1, 1:ndim) !----------------------------------------------------------------------- @@ -634,10 +657,15 @@ subroutine band_solve( solve_type, nsup, nsub, ndim, nrhs, & ipivot, rhs, ndim, info ) else - stop "band_solve: Cannot resolve the precision of real datatype" + !stop "band_solve: Cannot resolve the precision of real datatype" ! One implication of this is that CLUBB cannot be used with quad ! precision variables without a quad precision band diagonal solver - + ! Eric Raut Aug 2013: force double precision + lulhs_dp = real( lulhs, kind=dp ) + rhs_dp = real( rhs, kind=dp ) + call dgbsv( ndim, nsub, nsup, nrhs, lulhs_dp, nsub*2+nsup+1, & + ipivot, rhs_dp, ndim, info ) + rhs = real( rhs_dp, kind=core_rknd ) end if select case( info ) diff --git a/models/atm/cam/src/physics/clubb/matrix_operations.F90 b/models/atm/cam/src/physics/clubb/matrix_operations.F90 new file mode 100644 index 000000000000..c28e4855349b --- /dev/null +++ b/models/atm/cam/src/physics/clubb/matrix_operations.F90 @@ -0,0 +1,597 @@ +!----------------------------------------------------------------------- +! $Id: matrix_operations.F90 7016 2014-07-07 16:48:40Z betlej@uwm.edu $ +!=============================================================================== +module matrix_operations + + implicit none + + + public :: symm_covar_matrix_2_corr_matrix, Cholesky_factor, & + row_mult_lower_tri_matrix, print_lower_triangular_matrix, & + get_lower_triangular_matrix, set_lower_triangular_matrix_dp, & + set_lower_triangular_matrix, mirror_lower_triangular_matrix + + private :: Symm_matrix_eigenvalues + + private ! Default scope + + contains + +!----------------------------------------------------------------------- + subroutine symm_covar_matrix_2_corr_matrix( ndim, covar, corr ) + +! Description: +! Convert a matrix of covariances in to a matrix of correlations. +! This only does the computation the lower triangular portion of the +! matrix. +! References: +! None +!----------------------------------------------------------------------- + + use clubb_precision, only: & + dp ! double precision + + implicit none + + ! External + intrinsic :: sqrt + + ! Input Variables + integer, intent(in) :: ndim + + real( kind = dp ), dimension(ndim,ndim), intent(in) :: & + covar ! Covariance Matrix [units vary] + + ! Output Variables + real( kind = dp ), dimension(ndim,ndim), intent(out) :: & + corr ! Correlation Matrix [-] + + ! Local Variables + integer :: i, j + + ! ---- Begin Code ---- + + corr = 0._dp ! Initialize to 0 + + do i = 1, ndim + do j = 1, i + corr(i,j) = covar(i,j) / sqrt( covar(i,i) * covar(j,j) ) + end do + end do + + return + end subroutine symm_covar_matrix_2_corr_matrix +!----------------------------------------------------------------------- + subroutine row_mult_lower_tri_matrix( ndim, xvector, tmatrix_in, tmatrix_out ) + +! Description: +! Do a row-wise multiply of the elements of a lower triangular matrix. +! References: +! None +!----------------------------------------------------------------------- + + use clubb_precision, only: & + dp ! double precision + + implicit none + + + ! Input Variables + integer, intent(in) :: ndim + + real( kind = dp ), dimension(ndim), intent(in) :: & + xvector ! Factors to be multiplied across a row [units vary] + + ! Input Variables + real( kind = dp ), dimension(ndim,ndim), intent(in) :: & + tmatrix_in ! nxn matrix (usually a correlation matrix) [units vary] + + ! Output Variables + real( kind = dp ), dimension(ndim,ndim), intent(inout) :: & + tmatrix_out ! nxn matrix (usually a covariance matrix) [units vary] + + ! Local Variables + integer :: i, j + + ! ---- Begin Code ---- + + do i = 1, ndim + do j = 1, i + tmatrix_out(i,j) = tmatrix_in(i,j) * xvector(i) + end do + end do + + return + end subroutine row_mult_lower_tri_matrix + +!------------------------------------------------------------------------------- + subroutine Cholesky_factor( ndim, a_input, a_scaling, a_Cholesky, l_scaled ) +! Description: +! Create a Cholesky factorization of a_input. +! If the factorization fails we use a modified a_input matrix and attempt +! to factorize again. +! +! References: +! dpotrf +! dpoequ +! dlaqsy +!------------------------------------------------------------------------------- + use error_code, only: & + clubb_at_least_debug_level ! Procedure + + use constants_clubb, only: & + fstderr ! Constant + + use clubb_precision, only: & + dp, & ! double precision + core_rknd + + implicit none + + ! External + external :: dpotrf, dpoequ, dlaqsy ! LAPACK subroutines + + ! Constant Parameters + integer, parameter :: itermax = 10 ! Max iterations of the modified method + + real( kind = core_rknd), parameter :: d_coef = 0.1_core_rknd + ! Coefficient applied if the decomposition doesn't work + + ! Input Variables + integer, intent(in) :: ndim + + real( kind = dp ), dimension(ndim,ndim), intent(in) :: a_input + + ! Output Variables + real( kind = dp ), dimension(ndim), intent(out) :: a_scaling + + real( kind = dp ), dimension(ndim,ndim), intent(out) :: a_Cholesky + + logical, intent(out) :: l_scaled + + ! Local Variables + real( kind = dp ), dimension(ndim) :: a_eigenvalues + real( kind = dp ), dimension(ndim,ndim) :: a_corr, a_scaled + + real( kind = dp ) :: tau, d_smallest + + real( kind = dp ) :: amax, scond + integer :: info + integer :: i, j, iter + + character :: equed + + ! ---- Begin code ---- + + a_scaled = a_input ! Copy input array into output array + +! do i = 1, n +! do j = 1, n +! write(6,'(e10.3)',advance='no') a(i,j) +! end do +! write(6,*) "" +! end do +! pause + + equed = 'N' + + ! Compute scaling for a_input + call dpoequ( ndim, a_input, ndim, a_scaling, scond, amax, info ) + + if ( info == 0 ) then + ! Apply scaling to a_input + call dlaqsy( 'Lower', ndim, a_scaled, ndim, a_scaling, scond, amax, equed ) + end if + + ! Determine if scaling was necessary + if ( equed == 'Y' ) then + l_scaled = .true. + a_Cholesky = a_scaled + else + l_scaled = .false. + a_Cholesky = a_input + end if + + do iter = 1, itermax + call dpotrf( 'Lower', ndim, a_Cholesky, ndim, info ) + + select case( info ) + case( :-1 ) + write(fstderr,*) "Cholesky_factor " // & + " illegal value for argument ", -info + stop + case( 0 ) + ! Success! + if ( clubb_at_least_debug_level( 1 ) .and. iter > 1 ) then + write(fstderr,*) "a_factored (worked)=" + do i = 1, ndim + do j = 1, i + write(fstderr,'(g10.3)',advance='no') a_Cholesky(i,j) + end do + write(fstderr,*) "" + end do + end if + exit + case( 1: ) + if ( clubb_at_least_debug_level( 1 ) ) then + ! This shouldn't happen now that the s and t Mellor(chi/eta) elements have been + ! modified to never be perfectly correlated, but it's here just in case. + ! -dschanen 10 Sept 2010 + write(fstderr,*) "Cholesky_factor: leading minor of order ", & + info, " is not positive definite." + write(fstderr,*) "factorization failed." + write(fstderr,*) "a_input=" + do i = 1, ndim + do j = 1, i + write(fstderr,'(g10.3)',advance='no') a_input(i,j) + end do + write(fstderr,*) "" + end do + write(fstderr,*) "a_Cholesky=" + do i = 1, ndim + do j = 1, i + write(fstderr,'(g10.3)',advance='no') a_Cholesky(i,j) + end do + write(fstderr,*) "" + end do + end if + + if ( clubb_at_least_debug_level( 2 ) ) then + call Symm_matrix_eigenvalues( ndim, a_input, a_eigenvalues ) + write(fstderr,*) "a_eigenvalues=" + do i = 1, ndim + write(fstderr,'(g10.3)',advance='no') a_eigenvalues(i) + end do + write(fstderr,*) "" + + call symm_covar_matrix_2_corr_matrix( ndim, a_input, a_corr ) + write(fstderr,*) "a_correlations=" + do i = 1, ndim + do j = 1, i + write(fstderr,'(g10.3)',advance='no') a_corr(i,j) + end do + write(fstderr,*) "" + end do + end if + + if ( iter == itermax ) then + write(fstderr,*) "iteration =", iter, "itermax =", itermax + stop "Fatal error in Cholesky_factor" + else if ( clubb_at_least_debug_level( 1 ) ) then + ! Adding a STOP statement to prevent this problem from slipping under + ! the rug. + stop "Fatal error in Cholesky_factor" + write(fstderr,*) "Attempting to modify matrix to allow factorization." + end if + + if ( l_scaled ) then + a_Cholesky = a_scaled + else + a_Cholesky = a_input + end if + ! The number used for tau here is case specific to the Sigma covariance + ! matrix in the latin hypercube code and is not at all general. + ! Tau should be a number that is small relative to the other diagonal + ! elements of the matrix to have keep the error caused by modifying 'a' low. + ! -dschanen 30 Aug 2010 + d_smallest = a_Cholesky(1,1) + do i = 2, ndim + if ( d_smallest > a_Cholesky(i,i) ) d_smallest = a_Cholesky(i,i) + end do + ! Use the smallest element * d_coef * iteration + tau = d_smallest * real(d_coef, kind = dp) * real( iter, kind=dp ) + +! print *, "tau =", tau, "d_smallest = ", d_smallest + + do i = 1, ndim + do j = 1, ndim + if ( i == j ) then + a_Cholesky(i,j) = a_Cholesky(i,j) + tau ! Add tau to the diagonal + else + a_Cholesky(i,j) = a_Cholesky(i,j) + end if + end do + end do + + if ( clubb_at_least_debug_level( 2 ) ) then + call Symm_matrix_eigenvalues( ndim, a_Cholesky, a_eigenvalues ) + write(fstderr,*) "a_modified eigenvalues=" + do i = 1, ndim + write(fstderr,'(e10.3)',advance='no') a_eigenvalues(i) + end do + write(fstderr,*) "" + end if + + end select ! info + end do ! 1..itermax + + return + end subroutine Cholesky_factor + +!---------------------------------------------------------------------- + subroutine Symm_matrix_eigenvalues( ndim, a_input, a_eigenvalues ) + +! Description: +! Computes the eigevalues of a_input +! +! References: +! None +!----------------------------------------------------------------------- + + use constants_clubb, only: & + fstderr ! Constant + + use clubb_precision, only: & + dp ! double precision + + implicit none + + ! External + external :: dsyev ! LAPACK subroutine + + ! Parameters + integer, parameter :: & + lwork = 180 ! This is the optimal value I obtained for an n of 5 -dschanen 31 Aug 2010 + + ! Input Variables + integer, intent(in) :: ndim + + real( kind = dp ), dimension(ndim,ndim), intent(in) :: a_input + + ! Output Variables + real( kind = dp ), dimension(ndim), intent(out) :: a_eigenvalues + + ! Local Variables + real( kind = dp ), dimension(ndim,ndim) :: a_scratch + + real( kind = dp ), dimension(lwork) :: work + + integer :: info +! integer :: i, j + ! ---- Begin code ---- + + a_scratch = a_input + +! do i = 1, ndim +! do j = 1, ndim +! write(6,'(e10.3)',advance='no') a(i,j) +! end do +! write(6,*) "" +! end do +! pause + + call dsyev( 'No eigenvectors', 'Lower', ndim, a_scratch, ndim, & + a_eigenvalues, work, lwork, info ) + + select case( info ) + case( :-1 ) + write(fstderr,*) "Symm_matrix_eigenvalues:" // & + " illegal value for argument ", -info + stop + case( 0 ) + ! Success! + + case( 1: ) + write(fstderr,*) "Symm_matrix_eigenvalues: Algorithm failed to converge." + stop + end select + + return + end subroutine Symm_matrix_eigenvalues +!------------------------------------------------------------------------------- + subroutine set_lower_triangular_matrix( d_variables, index1, index2, xpyp, & + matrix ) +! Description: +! Set a value for the lower triangular portion of a matrix. +! References: +! None +!------------------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! user defined precision + + implicit none + + ! External + intrinsic :: max, min + + ! Input Variables + integer, intent(in) :: & + d_variables, & ! Number of variates + index1, index2 ! Indices for 2 variates (the order doesn't matter) + + real( kind = core_rknd ), intent(in) :: & + xpyp ! Value for the matrix (usually a correlation or covariance) [units vary] + + ! Input/Output Variables + real( kind = core_rknd ), dimension(d_variables,d_variables), intent(inout) :: & + matrix ! The lower triangular matrix + + integer :: i,j + + ! ---- Begin Code ---- + + ! Reverse these to set the values of upper triangular matrix + i = max( index1, index2 ) + j = min( index1, index2 ) + + if( i > 0 .and. j > 0 ) then + matrix(i,j) = xpyp + end if + + return + end subroutine set_lower_triangular_matrix + +!------------------------------------------------------------------------------- + subroutine set_lower_triangular_matrix_dp( d_variables, index1, index2, xpyp, & + matrix ) +! Description: +! Set a value for the lower triangular portion of a matrix. +! References: +! None +!------------------------------------------------------------------------------- + + use clubb_precision, only: & + dp ! double precision + + implicit none + + ! External + intrinsic :: max, min + + ! Input Variables + integer, intent(in) :: & + d_variables, & ! Number of variates + index1, index2 ! Indices for 2 variates (the order doesn't matter) + + real( kind = dp ), intent(in) :: & + xpyp ! Value for the matrix (usually a correlation or covariance) [units vary] + + ! Input/Output Variables + real( kind = dp ), dimension(d_variables,d_variables), intent(inout) :: & + matrix ! The lower triangular matrix + + integer :: i,j + + ! ---- Begin Code ---- + + ! Reverse these to set the values of upper triangular matrix + i = max( index1, index2 ) + j = min( index1, index2 ) + + if( i > 0 .and. j > 0 ) then + matrix(i,j) = xpyp + end if + + return + end subroutine set_lower_triangular_matrix_dp + +!------------------------------------------------------------------------------- + subroutine get_lower_triangular_matrix( d_variables, index1, index2, matrix, & + xpyp ) +! Description: +! Returns a value from the lower triangular portion of a matrix. +! References: +! None +!------------------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd + + implicit none + + ! External + intrinsic :: max, min + + ! Input Variables + integer, intent(in) :: & + d_variables, & ! Number of variates + index1, index2 ! Indices for 2 variates (the order doesn't matter) + + ! Input/Output Variables + real( kind = core_rknd ), dimension(d_variables,d_variables), intent(in) :: & + matrix ! The covariance matrix + + real( kind = core_rknd ), intent(out) :: & + xpyp ! Value from the matrix (usually a correlation or covariance) [units vary] + + integer :: i,j + + ! ---- Begin Code ---- + + ! Reverse these to set the values of upper triangular matrix + i = max( index1, index2 ) + j = min( index1, index2 ) + + xpyp = matrix(i,j) + + return + end subroutine get_lower_triangular_matrix + +!----------------------------------------------------------------------- + subroutine print_lower_triangular_matrix( iunit, ndim, matrix ) + +! Description: +! Print the values of lower triangular matrix to a file or console. + +! References: +! None +!----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + integer, intent(in) :: & + iunit, & ! File I/O logical unit (usually 6 for stdout and 0 for stderr) + ndim ! Dimension of the matrix + + real( kind = core_rknd ), dimension(ndim,ndim), intent(in) :: & + matrix ! Lower triangular matrix [units vary] + + ! Local Variables + integer :: i, j + + ! ---- Begin Code ---- + + do i = 1, ndim + do j = 1, i + write(iunit,fmt='(g15.6)',advance='no') matrix(i,j) + end do + write(iunit,fmt=*) "" ! newline + end do + + return + end subroutine print_lower_triangular_matrix + + !----------------------------------------------------------------------- + subroutine mirror_lower_triangular_matrix( nvars, matrix ) + + ! Description: + ! Mirrors the elements of a lower triangular matrix to the upper + ! triangle so that it is symmetric. + + ! References: + ! None + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Constant + + implicit none + + ! Input Variables + integer, intent(in) :: & + nvars ! Number of variables in each dimension of square matrix + + ! Input/Output Variables + real( kind = core_rknd ), dimension(nvars,nvars), intent(inout) :: & + matrix ! Lower triangluar square matrix + + ! Local Variables + integer :: row, col + + !----------------------------------------------------------------------- + + !----- Begin Code ----- + + if ( nvars > 1 ) then + + do col=2, nvars + do row=1, col-1 + + matrix(row,col) = matrix(col,row) + + end do + end do + + end if ! nvars > 1 + + return + + end subroutine mirror_lower_triangular_matrix + !----------------------------------------------------------------------- + +end module matrix_operations diff --git a/models/atm/cam/src/physics/clubb/mean_adv.F90 b/models/atm/cam/src/physics/clubb/mean_adv.F90 index c12918a9e4de..d301c39c90d2 100644 --- a/models/atm/cam/src/physics/clubb/mean_adv.F90 +++ b/models/atm/cam/src/physics/clubb/mean_adv.F90 @@ -1,5 +1,5 @@ !----------------------------------------------------------------------- -! $Id: mean_adv.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +! $Id: mean_adv.F90 6805 2014-03-23 04:28:36Z bmg2@uwm.edu $ !=============================================================================== module mean_adv @@ -27,8 +27,9 @@ module mean_adv contains !============================================================================= - pure function term_ma_zt_lhs( wm_zt, invrs_dzt, level, invrs_dzm_k, invrs_dzm_km1 ) & - result( lhs ) + pure function term_ma_zt_lhs( wm_zt, invrs_dzt, level, & + invrs_dzm_k, invrs_dzm_km1 ) & + result( lhs ) ! Description: ! Mean advection of var_zt: implicit portion of the code. @@ -174,11 +175,15 @@ pure function term_ma_zt_lhs( wm_zt, invrs_dzt, level, invrs_dzm_k, invrs_dzm_km use grid_class, only: & gr ! Variable(s) + use constants_clubb, only: & + one, & ! Constant(s) + zero + use model_flags, only: & - l_upwind_xm_ma ! Variable(s) + l_upwind_xm_ma ! Variable(s) use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) implicit none @@ -214,6 +219,7 @@ pure function term_ma_zt_lhs( wm_zt, invrs_dzt, level, invrs_dzm_k, invrs_dzm_km mk, & ! Momentum level directly above central thermodynamic level. mkm1 ! Momentum level directly below central thermodynamic level. + ! Momentum level (k) is between thermodynamic level (k+1) ! and thermodynamic level (k). mk = level @@ -224,126 +230,168 @@ pure function term_ma_zt_lhs( wm_zt, invrs_dzt, level, invrs_dzm_k, invrs_dzm_km if ( level == 1 ) then - ! k = 1 (bottom level); lower boundary level. - ! Thermodynamic level k = 1 is below the model bottom, so all effects - ! are shut off. + ! k = 1 (bottom level); lower boundary level. + ! Thermodynamic level k = 1 is below the model bottom, so all effects + ! are shut off. - ! Thermodynamic superdiagonal: [ x var_zt(k+1,) ] - lhs(kp1_tdiag) & - = 0.0_core_rknd + ! Thermodynamic superdiagonal: [ x var_zt(k+1,) ] + lhs(kp1_tdiag) & + = zero - ! Thermodynamic main diagonal: [ x var_zt(k,) ] - lhs(k_tdiag) & - = 0.0_core_rknd + ! Thermodynamic main diagonal: [ x var_zt(k,) ] + lhs(k_tdiag) & + = zero - ! Thermodynamic subdiagonal: [ x var_zt(k-1,) ] - lhs(km1_tdiag) & - = 0.0_core_rknd + ! Thermodynamic subdiagonal: [ x var_zt(k-1,) ] + lhs(km1_tdiag) & + = zero elseif ( level > 1 .and. level < gr%nz ) then - ! Most of the interior model; normal conditions. + ! Most of the interior model; normal conditions. - if( .not. l_upwind_xm_ma ) then ! Use centered differencing + if( .not. l_upwind_xm_ma ) then ! Use centered differencing - ! Thermodynamic superdiagonal: [ x var_zt(k+1,) ] - lhs(kp1_tdiag) & - = + wm_zt * invrs_dzt * gr%weights_zt2zm(t_above,mk) + ! Thermodynamic superdiagonal: [ x var_zt(k+1,) ] + lhs(kp1_tdiag) & + = + wm_zt * invrs_dzt * gr%weights_zt2zm(t_above,mk) - ! Thermodynamic main diagonal: [ x var_zt(k,) ] - lhs(k_tdiag) & - = + wm_zt * invrs_dzt * ( gr%weights_zt2zm(t_below,mk) & - - gr%weights_zt2zm(t_above,mkm1) ) + ! Thermodynamic main diagonal: [ x var_zt(k,) ] + lhs(k_tdiag) & + = + wm_zt * invrs_dzt * ( gr%weights_zt2zm(t_below,mk) & + - gr%weights_zt2zm(t_above,mkm1) ) - ! Thermodynamic subdiagonal: [ x var_zt(k-1,) ] - lhs(km1_tdiag) & - = - wm_zt * invrs_dzt * gr%weights_zt2zm(t_below,mkm1) + ! Thermodynamic subdiagonal: [ x var_zt(k-1,) ] + lhs(km1_tdiag) & + = - wm_zt * invrs_dzt * gr%weights_zt2zm(t_below,mkm1) - else ! l_upwind_xm_ma == .true. Use upwind differencing + else ! l_upwind_xm_ma == .true.; use "upwind" differencing - if ( wm_zt > 0._core_rknd ) then ! Wind is in upward direction + if ( wm_zt >= zero ) then ! Mean wind is in upward direction - ! Thermodynamic superdiagonal: [ x var_zt(k+1,) ] - lhs(kp1_tdiag) & - = 0.0_core_rknd + ! Thermodynamic superdiagonal: [ x var_zt(k+1,) ] + lhs(kp1_tdiag) & + = zero - ! Thermodynamic main diagonal: [ x var_zt(k,) ] - lhs(k_tdiag) & - = + wm_zt * invrs_dzm_km1 + ! Thermodynamic main diagonal: [ x var_zt(k,) ] + lhs(k_tdiag) & + = + wm_zt * invrs_dzm_km1 - ! Thermodynamic subdiagonal: [ x var_zt(k-1,) ] - lhs(km1_tdiag) & - = - wm_zt * invrs_dzm_km1 + ! Thermodynamic subdiagonal: [ x var_zt(k-1,) ] + lhs(km1_tdiag) & + = - wm_zt * invrs_dzm_km1 - else ! wm_zt < 0 Wind is in downward direction + else ! wm_zt < 0; Mean wind is in downward direction - ! Thermodynamic superdiagonal: [ x var_zt(k+1,) ] - lhs(kp1_tdiag) & - = + wm_zt * invrs_dzm_k + ! Thermodynamic superdiagonal: [ x var_zt(k+1,) ] + lhs(kp1_tdiag) & + = + wm_zt * invrs_dzm_k - ! Thermodynamic main diagonal: [ x var_zt(k,) ] - lhs(k_tdiag) & - = - wm_zt * invrs_dzm_k + ! Thermodynamic main diagonal: [ x var_zt(k,) ] + lhs(k_tdiag) & + = - wm_zt * invrs_dzm_k + + ! Thermodynamic subdiagonal: [ x var_zt(k-1,) ] + lhs(km1_tdiag) & + = zero + + endif ! wm_zt > 0 - ! Thermodynamic subdiagonal: [ x var_zt(k-1,) ] - lhs(km1_tdiag) & - = 0.0_core_rknd - end if ! wm_zt >0 + endif ! l_upwind_xm_ma - end if ! l_upwind_xm_ma elseif ( level == gr%nz ) then - ! k = gr%nz (top level); upper boundary level. + ! k = gr%nz (top level); upper boundary level. + + if( .not. l_upwind_xm_ma ) then ! Use "centered" differencing + + if ( l_ub_const_deriv ) then + + ! Special discretization for constant derivative method (or + ! "one-sided" derivative method). + + ! Thermodynamic superdiagonal: [ x var_zt(k+1,) ] + lhs(kp1_tdiag) & + = zero - if ( l_ub_const_deriv ) then + ! Thermodynamic main diagonal: [ x var_zt(k,) ] + lhs(k_tdiag) & + = + wm_zt * invrs_dzt * ( gr%weights_zt2zm(t_above,mk) & + - gr%weights_zt2zm(t_above,mkm1) ) - ! Special discretization for constant derivative method (or "one-sided" - ! derivative method). + ! Thermodynamic subdiagonal: [ x var_zt(k-1,) ] + lhs(km1_tdiag) & + = + wm_zt * invrs_dzt * ( gr%weights_zt2zm(t_below,mk) & + - gr%weights_zt2zm(t_below,mkm1) ) - ! Thermodynamic superdiagonal: [ x var_zt(k+1,) ] - lhs(kp1_tdiag) & - = 0.0_core_rknd + else - ! Thermodynamic main diagonal: [ x var_zt(k,) ] - lhs(k_tdiag) & - = + wm_zt * invrs_dzt * ( gr%weights_zt2zm(t_above,mk) & - - gr%weights_zt2zm(t_above,mkm1) ) + ! Special discretization for zero derivative method, where the + ! derivative d(var_zt)/dz over the model top is set to 0, in order + ! to stay consistent with the zero-flux boundary condition option + ! in the eddy diffusion code. - ! Thermodynamic subdiagonal: [ x var_zt(k-1,) ] - lhs(km1_tdiag) & - = + wm_zt * invrs_dzt * ( gr%weights_zt2zm(t_below,mk) & - - gr%weights_zt2zm(t_below,mkm1) ) + ! Thermodynamic superdiagonal: [ x var_zt(k+1,) ] + lhs(kp1_tdiag) & + = zero - else + ! Thermodynamic main diagonal: [ x var_zt(k,) ] + lhs(k_tdiag) & + = + wm_zt * invrs_dzt * ( one - gr%weights_zt2zm(t_above,mkm1) ) - ! Special discretization for zero derivative method, where the - ! derivative d(var_zt)/dz over the model top is set to 0, in order to - ! stay consistent with the zero-flux boundary condition option in the - ! eddy diffusion code. + ! Thermodynamic subdiagonal: [ x var_zt(k-1,) ] + lhs(km1_tdiag) & + = - wm_zt * invrs_dzt * gr%weights_zt2zm(t_below,mkm1) - ! Thermodynamic superdiagonal: [ x var_zt(k+1,) ] - lhs(kp1_tdiag) & - = 0.0_core_rknd + endif ! l_ub_const_deriv - ! Thermodynamic main diagonal: [ x var_zt(k,) ] - lhs(k_tdiag) & - = + wm_zt * invrs_dzt * ( 1.0_core_rknd - gr%weights_zt2zm(t_above,mkm1) ) - ! Thermodynamic subdiagonal: [ x var_zt(k-1,) ] - lhs(km1_tdiag) & - = - wm_zt * invrs_dzt * gr%weights_zt2zm(t_below,mkm1) + else ! l_upwind_xm_ma == .true.; use "upwind" differencing - endif + if ( wm_zt >= zero ) then ! Mean wind is in upward direction + + ! Thermodynamic superdiagonal: [ x var_zt(k+1,) ] + lhs(kp1_tdiag) & + = zero + + ! Thermodynamic main diagonal: [ x var_zt(k,) ] + lhs(k_tdiag) & + = + wm_zt * invrs_dzm_km1 + + ! Thermodynamic subdiagonal: [ x var_zt(k-1,) ] + lhs(km1_tdiag) & + = - wm_zt * invrs_dzm_km1 + + + else ! wm_zt < 0; Mean wind is in downward direction + + ! Thermodynamic superdiagonal: [ x var_zt(k+1,) ] + lhs(kp1_tdiag) & + = zero + + ! Thermodynamic main diagonal: [ x var_zt(k,) ] + lhs(k_tdiag) & + = zero + + ! Thermodynamic subdiagonal: [ x var_zt(k-1,) ] + lhs(km1_tdiag) & + = zero + + endif ! wm_zt > 0 + + + endif ! l_upwind_xm_ma endif ! level = gr%nz return + end function term_ma_zt_lhs !============================================================================= @@ -402,10 +450,13 @@ pure function term_ma_zm_lhs( wm_zm, invrs_dzm, level ) & !----------------------------------------------------------------------- use grid_class, only: & - gr + gr ! Variable(s) + + use constants_clubb, only: & + zero ! Constant(s) use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) implicit none @@ -435,6 +486,7 @@ pure function term_ma_zm_lhs( wm_zm, invrs_dzm, level ) & tkp1, & ! Thermodynamic level directly above central momentum level. tk ! Thermodynamic level directly below central momentum level. + ! Thermodynamic level (k+1) is between momentum level (k+1) ! and momentum level (k). tkp1 = level + 1 @@ -445,59 +497,61 @@ pure function term_ma_zm_lhs( wm_zm, invrs_dzm, level ) & if ( level == 1 ) then - ! k = 1; lower boundery level at surface. + ! k = 1; lower boundery level at surface. - ! Momentum superdiagonal: [ x var_zm(k+1,) ] - lhs(kp1_mdiag) & - = 0.0_core_rknd + ! Momentum superdiagonal: [ x var_zm(k+1,) ] + lhs(kp1_mdiag) & + = zero - ! Momentum main diagonal: [ x var_zm(k,) ] - lhs(k_mdiag) & - = 0.0_core_rknd + ! Momentum main diagonal: [ x var_zm(k,) ] + lhs(k_mdiag) & + = zero - ! Momentum subdiagonal: [ x var_zm(k-1,) ] - lhs(km1_mdiag) & - = 0.0_core_rknd + ! Momentum subdiagonal: [ x var_zm(k-1,) ] + lhs(km1_mdiag) & + = zero elseif ( level > 1 .and. level < gr%nz ) then - ! Most of the interior model; normal conditions. + ! Most of the interior model; normal conditions. - ! Momentum superdiagonal: [ x var_zm(k+1,) ] - lhs(kp1_mdiag) & - = + wm_zm * invrs_dzm * gr%weights_zm2zt(m_above,tkp1) + ! Momentum superdiagonal: [ x var_zm(k+1,) ] + lhs(kp1_mdiag) & + = + wm_zm * invrs_dzm * gr%weights_zm2zt(m_above,tkp1) - ! Momentum main diagonal: [ x var_zm(k,) ] - lhs(k_mdiag) & - = + wm_zm * invrs_dzm * ( gr%weights_zm2zt(m_below,tkp1) & - - gr%weights_zm2zt(m_above,tk) ) + ! Momentum main diagonal: [ x var_zm(k,) ] + lhs(k_mdiag) & + = + wm_zm * invrs_dzm * ( gr%weights_zm2zt(m_below,tkp1) & + - gr%weights_zm2zt(m_above,tk) ) - ! Momentum subdiagonal: [ x var_zm(k-1,) ] - lhs(km1_mdiag) & - = - wm_zm * invrs_dzm * gr%weights_zm2zt(m_below,tk) + ! Momentum subdiagonal: [ x var_zm(k-1,) ] + lhs(km1_mdiag) & + = - wm_zm * invrs_dzm * gr%weights_zm2zt(m_below,tk) elseif ( level == gr%nz ) then - ! k = gr%nz (top level); upper boundary level. + ! k = gr%nz (top level); upper boundary level. - ! Momentum superdiagonal: [ x var_zm(k+1,) ] - lhs(kp1_mdiag) & - = 0.0_core_rknd + ! Momentum superdiagonal: [ x var_zm(k+1,) ] + lhs(kp1_mdiag) & + = zero - ! Momentum main diagonal: [ x var_zm(k,) ] - lhs(k_mdiag) & - = 0.0_core_rknd + ! Momentum main diagonal: [ x var_zm(k,) ] + lhs(k_mdiag) & + = zero - ! Momentum subdiagonal: [ x var_zm(k-1,) ] - lhs(km1_mdiag) & - = 0.0_core_rknd + ! Momentum subdiagonal: [ x var_zm(k-1,) ] + lhs(km1_mdiag) & + = zero endif + return + end function term_ma_zm_lhs !=============================================================================== diff --git a/models/atm/cam/src/physics/clubb/mixing_length.F90 b/models/atm/cam/src/physics/clubb/mixing_length.F90 index 8a80c8432616..74f8d5aa2b56 100644 --- a/models/atm/cam/src/physics/clubb/mixing_length.F90 +++ b/models/atm/cam/src/physics/clubb/mixing_length.F90 @@ -1,4 +1,5 @@ -! $Id: mixing_length.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +!----------------------------------------------------------------------- +! $Id: mixing_length.F90 7226 2014-08-19 15:52:41Z betlej@uwm.edu $ !=============================================================================== module mixing_length @@ -11,10 +12,10 @@ module mixing_length contains !============================================================================= - subroutine compute_length( thvm, thlm, rtm, em, & + subroutine compute_length( thvm, thlm, rtm, em, Lscale_max, & p_in_Pa, exner, thv_ds, mu, l_implemented, & err_code, & - Lscale ) + Lscale, Lscale_up, Lscale_down ) ! Description: ! Larson's 5th moist, nonlocal length scale @@ -44,9 +45,6 @@ subroutine compute_length( thvm, thlm, rtm, em, & use parameters_tunable, only: & ! Variable(s) lmin ! Minimum value for Lscale [m] - use parameters_model, only: & - Lscale_max ! Maximum value for Lscale [m] - use grid_class, only: & gr, & ! Variable(s) zm2zt ! Procedure(s) @@ -58,10 +56,6 @@ subroutine compute_length( thvm, thlm, rtm, em, & sat_mixrat_liq, & ! Procedure(s) sat_mixrat_liq_lookup - use variables_diagnostic_module, only: & - Lscale_up, & ! Variable(s) - Lscale_down - use error_code, only: & clubb_at_least_debug_level, & ! Procedure(s) fatal_error @@ -78,12 +72,12 @@ subroutine compute_length( thvm, thlm, rtm, em, & implicit none ! External - intrinsic :: max, sqrt + intrinsic :: min, max, sqrt ! Constant Parameters real( kind = core_rknd ), parameter :: & - zlmin = 0.1_core_rknd !, & - !zeps = 1.e-10 + zlmin = 0.1_core_rknd, & ! Minimum value for Lscale [m] + Lscale_sfclyr_depth = 500._core_rknd ! [m] ! Input Variables real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & @@ -96,6 +90,9 @@ subroutine compute_length( thvm, thlm, rtm, em, & thv_ds ! Dry, base-state theta_v on thermodynamic level [K] ! Note: thv_ds used as a reference theta_l here + real( kind = core_rknd ), intent(in) :: & + Lscale_max ! Maximum allowable value for Lscale [m] + real( kind = core_rknd ), intent(in) :: & mu ! mu Fractional extrainment rate per unit altitude [1/m] @@ -107,9 +104,12 @@ subroutine compute_length( thvm, thlm, rtm, em, & err_code real( kind = core_rknd ), dimension(gr%nz), intent(out) :: & - Lscale ! Mixing length [m] + Lscale, & ! Mixing length [m] + Lscale_up, & ! Mixing length up [m] + Lscale_down ! Mixing length down [m] ! Local Variables + integer :: i, j, & err_code_Lscale @@ -127,7 +127,7 @@ subroutine compute_length( thvm, thlm, rtm, em, & real( kind = core_rknd ) :: thl_par_j, rt_par_j, rc_par_j, thv_par_j ! Used in latent heating calculation - real( kind = core_rknd ) :: tl_par_j, rsl_par_j, beta_par_j, & + real( kind = core_rknd ) :: tl_par_j, rsatl_par_j, beta_par_j, & s_par_j ! Parcel quantities at grid level j-1 @@ -139,9 +139,8 @@ subroutine compute_length( thvm, thlm, rtm, em, & ! Variables to make L nonlocal real( kind = core_rknd ) :: Lscale_up_max_alt, Lscale_down_min_alt - real( kind = core_rknd ), parameter :: Lscale_sfclyr_depth = 500._core_rknd ! [m] - ! ---- Begin Code ---- + err_code_Lscale = clubb_no_error !---------- Mixing length computation ---------------------------------- @@ -292,14 +291,14 @@ subroutine compute_length( thvm, thlm, rtm, em, & ! theta_l of the parcel and r_t of the parcel at grid level j. tl_par_j = thl_par_j*exner(j) if ( l_sat_mixrat_lookup ) then - rsl_par_j = sat_mixrat_liq_lookup( p_in_Pa(j), tl_par_j ) + rsatl_par_j = sat_mixrat_liq_lookup( p_in_Pa(j), tl_par_j ) else - rsl_par_j = sat_mixrat_liq( p_in_Pa(j), tl_par_j ) + rsatl_par_j = sat_mixrat_liq( p_in_Pa(j), tl_par_j ) end if ! SD's beta (eqn. 8) beta_par_j = ep*(Lv/(Rd*tl_par_j))*(Lv/(cp*tl_par_j)) ! s from Lewellen and Yoh 1993 (LY) eqn. 1 - s_par_j = (rt_par_j-rsl_par_j)/(1._core_rknd+beta_par_j*rsl_par_j) + s_par_j = (rt_par_j-rsatl_par_j)/(1._core_rknd+beta_par_j*rsatl_par_j) rc_par_j = max( s_par_j, zero_threshold ) ! theta_v of entraining parcel at grid level j. @@ -589,14 +588,14 @@ subroutine compute_length( thvm, thlm, rtm, em, & ! theta_l of the parcel and r_t of the parcel at grid level j. tl_par_j = thl_par_j*exner(j) if ( l_sat_mixrat_lookup ) then - rsl_par_j = sat_mixrat_liq_lookup( p_in_Pa(j), tl_par_j ) + rsatl_par_j = sat_mixrat_liq_lookup( p_in_Pa(j), tl_par_j ) else - rsl_par_j = sat_mixrat_liq( p_in_Pa(j), tl_par_j ) + rsatl_par_j = sat_mixrat_liq( p_in_Pa(j), tl_par_j ) end if ! SD's beta (eqn. 8) beta_par_j = ep*(Lv/(Rd*tl_par_j))*(Lv/(cp*tl_par_j)) ! s from Lewellen and Yoh 1993 (LY) eqn. 1 - s_par_j = (rt_par_j-rsl_par_j)/(1._core_rknd+beta_par_j*rsl_par_j) + s_par_j = (rt_par_j-rsatl_par_j)/(1._core_rknd+beta_par_j*rsatl_par_j) rc_par_j = max( s_par_j, zero_threshold ) ! theta_v of the entraining parcel at grid level j. diff --git a/models/atm/cam/src/physics/clubb/model_flags.F90 b/models/atm/cam/src/physics/clubb/model_flags.F90 index cc5e4584af60..3ca8a12bb729 100644 --- a/models/atm/cam/src/physics/clubb/model_flags.F90 +++ b/models/atm/cam/src/physics/clubb/model_flags.F90 @@ -1,6 +1,6 @@ +!----------------------------------------------------------------------- +! $Id: model_flags.F90 7367 2014-11-06 18:29:49Z schemena@uwm.edu $ !=============================================================================== -! $Id: model_flags.F90 5585 2011-12-29 21:54:19Z dschanen@uwm.edu $ - module model_flags ! Description: @@ -18,13 +18,12 @@ module model_flags private ! Default Scope logical, parameter, public :: & - l_hyper_dfsn = .false., & ! 4th-order hyper-diffusion - l_pos_def = .false., & ! Flux limiting pos. def. scheme on rtm - l_hole_fill = .true., & ! Hole filling pos. def. scheme on wp2,up2,rtp2,etc - l_clip_semi_implicit = .false., & ! Semi-implicit clipping scheme on wpthlp and wprtp - l_clip_turb_adv = .false., & ! Corrects thlm/rtm when w'th_l'/w'r_t' is clipped - l_gmres = .false., & ! Use GMRES iterative solver rather than LAPACK - l_sat_mixrat_lookup = .false. ! Use a lookup table for mixing length + l_pos_def = .false., & ! Flux limiting positive definite scheme on rtm + l_hole_fill = .true., & ! Hole filling pos def scheme on wp2,up2,rtp2,etc + l_clip_semi_implicit = .false., & ! Semi-implicit clipping scheme on wpthlp and wprtp + l_clip_turb_adv = .false., & ! Corrects thlm/rtm when w'th_l'/w'r_t' is clipped + l_gmres = .false., & ! Use GMRES iterative solver rather than LAPACK + l_sat_mixrat_lookup = .false. ! Use a lookup table for mixing length ! saturation vapor pressure calculations logical, parameter, public :: & @@ -40,6 +39,35 @@ module model_flags ! predictive equations. The predictive ! equations are anelastic by default. + logical, public :: & + l_use_precip_frac = .true. ! Flag to use precipitation fraction in KK + ! microphysics. The precipitation fraction + ! is automatically set to 1 when this flag + ! is turned off. + +!$omp threadprivate( l_use_precip_frac ) + + logical, parameter, public :: & + l_morr_xp2_mc = .false. !Flag to include the effects of rain evaporation + !on rtp2 and thlp2. The moister (rt_1 or rt_2) + !and colder (thl_1 or thl_2) will be fed into + !the morrison microphys, and rain evaporation will + !be allowed to increase variances + + logical, parameter, public :: & + l_evaporate_cold_rcm = .false. ! Flag to evaporate cloud water at temperatures + ! colder than -37C. This is to be used for + ! Morrison microphysics, to prevent excess ice + + logical, parameter, public :: & + l_cubic_interp = .false. ! Flag to convert grid points with cubic monotonic + ! spline interpolation as opposed to linear interpolation. + + ! See clubb:ticket:632 for details + logical, public :: & + l_calc_thlp2_rad = .true. ! Include the contribution of radiation to thlp2 +!$omp threadprivate( l_calc_thlp2_rad ) + ! These are the integer constants that represent the various saturation ! formulas. To add a new formula, add an additional constant here, ! add the logic to check the strings for the new formula in clubb_core and @@ -56,6 +84,14 @@ module model_flags ! The default values are chosen below and overwritten if desired by the user !----------------------------------------------------------------------------- + ! These flags determine whether or not we want CLUBB to do diffusion + ! on thlm and rtm and if a stability correction is applied + logical, public :: & + l_diffuse_rtm_and_thlm = .false., & ! Diffuses rtm and thlm + l_stability_correct_Kh_N2_zm = .false. ! Divides Kh_N2_zm by a stability factor + +!$omp threadprivate(l_diffuse_rtm_and_thlm, l_stability_correct_Kh_N2_zm) + ! These flags determine whether we want to use an upwind differencing approximation ! rather than a centered differencing for turbulent or mean advection terms. ! wpxp_ta affects wprtp, wpthlp, & wpsclrp @@ -75,11 +111,11 @@ module model_flags logical, public :: & - l_uv_nudge = .false., & ! For wind speed nudging. - Michael Falk - l_tke_aniso = .true. ! For anisotropic turbulent kinetic energy, - ! i.e. TKE = 1/2 (u'^2 + v'^2 + w'^2) -! OpenMP directives. -!$omp threadprivate(l_uv_nudge, l_tke_aniso) + l_uv_nudge = .false., & ! For wind speed nudging. - Michael Falk + l_rtm_nudge = .false., & ! For rtm nudging + l_tke_aniso = .true. ! For anisotropic turbulent kinetic energy, + ! i.e. TKE = 1/2 (u'^2 + v'^2 + w'^2) +!$omp threadprivate(l_uv_nudge, l_tke_aniso, l_rtm_nudge) ! Use 2 calls to pdf_closure and the trapezoidal rule to compute the ! varibles that are output from high order closure @@ -132,7 +168,22 @@ module model_flags saturation_formula = saturation_flatau ! Integer that stores the saturation formula to be used !$omp threadprivate(saturation_formula) - + + ! See clubb:ticket:514 for details + logical, public :: & + l_diagnose_correlations = .false., & ! Diagnose correlations instead of using fixed ones + l_calc_w_corr = .false. ! Calculate the correlations between w and the hydrometeors +!$omp threadprivate(l_diagnose_correlations, l_calc_w_corr) + + logical, parameter, public :: & + l_silhs_rad = .false. ! Resolve radiation over subcolumns using SILHS + + logical, public :: & + l_const_Nc_in_cloud = .false., & ! Use a constant cloud droplet conc. within cloud (K&K) + l_fix_chi_eta_correlations = .true. ! Use a fixed correlation for s and t Mellor(chi/eta) + +!$omp threadprivate( l_const_Nc_in_cloud, l_fix_chi_eta_correlations ) + #ifdef GFDL logical, public :: & I_sat_sphum ! h1g, 2010-06-15 @@ -142,7 +193,7 @@ module model_flags namelist /configurable_model_flags/ & l_upwind_wpxp_ta, l_upwind_xpyp_ta, l_upwind_xm_ma, l_quintic_poly_interp, & l_tke_aniso, l_vert_avg_closure, l_single_C2_Skw, l_standard_term_ta, & - l_use_cloud_cover + l_use_cloud_cover, l_calc_thlp2_rad contains @@ -161,8 +212,6 @@ subroutine setup_model_flags & ! References: ! None !------------------------------------------------------------------------------- - use constants_clubb, only: & - fstderr ! Variable(s) implicit none @@ -216,7 +265,7 @@ end subroutine setup_model_flags subroutine read_model_flags_from_file( iunit, filename ) ! Description: -! Read in some of the model flags of interest from a namelist file. If the +! Read in some of the model flags of interest from a namelist file. If the ! variable isn't in the file it will just be the default value. ! ! References: diff --git a/models/atm/cam/src/physics/clubb/mono_flux_limiter.F90 b/models/atm/cam/src/physics/clubb/mono_flux_limiter.F90 index 0a08167c8922..18676497c0b3 100644 --- a/models/atm/cam/src/physics/clubb/mono_flux_limiter.F90 +++ b/models/atm/cam/src/physics/clubb/mono_flux_limiter.F90 @@ -1,5 +1,5 @@ !----------------------------------------------------------------------- -! $Id: mono_flux_limiter.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +! $Id: mono_flux_limiter.F90 7315 2014-09-30 20:49:54Z schemena@uwm.edu $ !=============================================================================== module mono_flux_limiter @@ -289,8 +289,7 @@ subroutine monotonic_turbulent_flux_limit( solve_type, dt, xm_old, & fstderr use clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd + core_rknd ! Variable(s) use error_code, only: & fatal_error, & ! Procedure(s) @@ -299,14 +298,14 @@ subroutine monotonic_turbulent_flux_limit( solve_type, dt, xm_old, & use fill_holes, only: & vertical_integral ! Procedure(s) - use stats_type, only: & + use stats_type_utilities, only: & stat_begin_update, & ! Procedure(s) stat_end_update, & stat_update_var use stats_variables, only: & - zm, & ! Variable(s) - zt, & + stats_zm, & ! Variable(s) + stats_zt, & iwprtp_mfl, & irtm_mfl, & iwpthlp_mfl, & @@ -345,7 +344,7 @@ subroutine monotonic_turbulent_flux_limit( solve_type, dt, xm_old, & integer, intent(in) :: & solve_type ! Variables being solved for. - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dt ! Model timestep length [s] real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & @@ -449,17 +448,17 @@ subroutine monotonic_turbulent_flux_limit( solve_type, dt, xm_old, & if ( l_stats_samp ) then - call stat_begin_update( iwpxp_mfl, wpxp / real( dt, kind = core_rknd ), zm ) - call stat_begin_update( ixm_mfl, xm / real( dt, kind = core_rknd ), zt ) + call stat_begin_update( iwpxp_mfl, wpxp / dt, stats_zm ) + call stat_begin_update( ixm_mfl, xm / dt, stats_zt ) endif if ( l_stats_samp .and. solve_type == mono_flux_thlm ) then - call stat_update_var( ithlm_enter_mfl, xm, zt ) - call stat_update_var( ithlm_old, xm_old, zt ) - call stat_update_var( iwpthlp_entermfl, xm, zm ) + call stat_update_var( ithlm_enter_mfl, xm, stats_zt ) + call stat_update_var( ithlm_old, xm_old, stats_zt ) + call stat_update_var( iwpthlp_entermfl, xm, stats_zm ) elseif ( l_stats_samp .and. solve_type == mono_flux_rtm ) then - call stat_update_var( irtm_enter_mfl, xm, zt ) - call stat_update_var( irtm_old, xm_old, zt ) - call stat_update_var( iwprtp_enter_mfl, xm, zm ) + call stat_update_var( irtm_enter_mfl, xm, stats_zt ) + call stat_update_var( irtm_old, xm_old, stats_zt ) + call stat_update_var( iwprtp_enter_mfl, xm, stats_zm ) endif ! Initialize arrays. @@ -518,8 +517,8 @@ subroutine monotonic_turbulent_flux_limit( solve_type, dt, xm_old, & ! Find the value of xm without the contribution from the turbulent ! advection term. ! Note: the contribution of xm_forcing at level gr%nz should be 0. - xm_without_ta(k) = xm_old(k) + real( dt, kind = core_rknd )*xm_forcing(k) & - + real( dt, kind = core_rknd )*m_adv_term + xm_without_ta(k) = xm_old(k) + dt*xm_forcing(k) & + + dt*m_adv_term ! Find the minimum usuable value of variable x at each vertical level. ! Since variable x must be one of theta_l, r_t, or a scalar, all of @@ -562,14 +561,14 @@ subroutine monotonic_turbulent_flux_limit( solve_type, dt, xm_old, & ! Find the upper limit for w'x' for a monotonic turbulent flux. wpxp_mfl_max(k) & = invrs_rho_ds_zm(k) & - * ( ( rho_ds_zt(k) / (real( dt, kind = core_rknd )*gr%invrs_dzt(k)) ) & + * ( ( rho_ds_zt(k) / (dt*gr%invrs_dzt(k)) ) & * ( xm_without_ta(k) - min_x_allowable(k) ) & + rho_ds_zm(km1) * wpxp(km1) ) ! Find the lower limit for w'x' for a monotonic turbulent flux. wpxp_mfl_min(k) & = invrs_rho_ds_zm(k) & - * ( ( rho_ds_zt(k) / (real( dt, kind = core_rknd )*gr%invrs_dzt(k)) ) & + * ( ( rho_ds_zt(k) / (dt*gr%invrs_dzt(k)) ) & * ( xm_without_ta(k) - max_x_allowable(k) ) & + rho_ds_zm(km1) * wpxp(km1) ) @@ -678,17 +677,17 @@ subroutine monotonic_turbulent_flux_limit( solve_type, dt, xm_old, & wpxp_mfl_max(gr%nz) = 0._core_rknd if ( l_stats_samp .and. solve_type == mono_flux_thlm ) then - call stat_update_var( ithlm_without_ta, xm_without_ta, zt ) - call stat_update_var( ithlm_mfl_min, min_x_allowable, zt ) - call stat_update_var( ithlm_mfl_max, max_x_allowable, zt ) - call stat_update_var( iwpthlp_mfl_min, wpxp_mfl_min, zm ) - call stat_update_var( iwpthlp_mfl_max, wpxp_mfl_max, zm ) + call stat_update_var( ithlm_without_ta, xm_without_ta, stats_zt ) + call stat_update_var( ithlm_mfl_min, min_x_allowable, stats_zt ) + call stat_update_var( ithlm_mfl_max, max_x_allowable, stats_zt ) + call stat_update_var( iwpthlp_mfl_min, wpxp_mfl_min, stats_zm ) + call stat_update_var( iwpthlp_mfl_max, wpxp_mfl_max, stats_zm ) elseif ( l_stats_samp .and. solve_type == mono_flux_rtm ) then - call stat_update_var( irtm_without_ta, xm_without_ta, zt ) - call stat_update_var( irtm_mfl_min, min_x_allowable, zt ) - call stat_update_var( irtm_mfl_max, max_x_allowable, zt ) - call stat_update_var( iwprtp_mfl_min, wpxp_mfl_min, zm ) - call stat_update_var( iwprtp_mfl_max, wpxp_mfl_max, zm ) + call stat_update_var( irtm_without_ta, xm_without_ta, stats_zt ) + call stat_update_var( irtm_mfl_min, min_x_allowable, stats_zt ) + call stat_update_var( irtm_mfl_max, max_x_allowable, stats_zt ) + call stat_update_var( iwprtp_mfl_min, wpxp_mfl_min, stats_zm ) + call stat_update_var( iwprtp_mfl_max, wpxp_mfl_max, stats_zm ) endif @@ -739,7 +738,7 @@ subroutine monotonic_turbulent_flux_limit( solve_type, dt, xm_old, & ! rate of change multiplied by the time step length. Add the ! product to xm to find the new xm resulting from the monotonic ! flux limiter. - xm(k) = xm(k) + dxm_dt_mfl_adjust(k) * real( dt, kind = core_rknd ) + xm(k) = xm(k) + dxm_dt_mfl_adjust(k) * dt enddo @@ -814,16 +813,16 @@ subroutine monotonic_turbulent_flux_limit( solve_type, dt, xm_old, & if ( l_stats_samp ) then - call stat_end_update( iwpxp_mfl, wpxp / real( dt, kind = core_rknd ), zm ) + call stat_end_update( iwpxp_mfl, wpxp / dt, stats_zm ) - call stat_end_update( ixm_mfl, xm / real( dt, kind = core_rknd ), zt ) + call stat_end_update( ixm_mfl, xm / dt, stats_zt ) if ( solve_type == mono_flux_thlm ) then - call stat_update_var( ithlm_exit_mfl, xm, zt ) - call stat_update_var( iwpthlp_exit_mfl, xm, zm ) + call stat_update_var( ithlm_exit_mfl, xm, stats_zt ) + call stat_update_var( iwpthlp_exit_mfl, xm, stats_zm ) elseif ( solve_type == mono_flux_rtm ) then - call stat_update_var( irtm_exit_mfl, xm, zt ) - call stat_update_var( iwprtp_exit_mfl, xm, zm ) + call stat_update_var( irtm_exit_mfl, xm, stats_zt ) + call stat_update_var( iwprtp_exit_mfl, xm, stats_zm ) endif endif @@ -854,8 +853,7 @@ subroutine mfl_xm_lhs( dt, wm_zt, l_implemented, & term_ma_zt_lhs ! Procedure(s) use clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd + core_rknd ! Variable(s) implicit none @@ -866,7 +864,7 @@ subroutine mfl_xm_lhs( dt, wm_zt, l_implemented, & km1_tdiag = 3 ! Thermodynamic subdiagonal index. ! Input Variables - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dt ! Model timestep length [s] real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & @@ -914,7 +912,7 @@ subroutine mfl_xm_lhs( dt, wm_zt, l_implemented, & ! LHS xm time tendency. lhs(k_tdiag,k) & - = lhs(k_tdiag,k) + 1.0_core_rknd / real( dt, kind = core_rknd ) + = lhs(k_tdiag,k) + 1.0_core_rknd / dt enddo ! xm loop: 2..gr%nz @@ -948,13 +946,12 @@ subroutine mfl_xm_rhs( dt, xm_old, wpxp, xm_forcing, & gr ! Variable(s) use clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd + core_rknd ! Variable(s) implicit none ! Input Variables - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dt ! Model timestep length [s] real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & @@ -987,7 +984,7 @@ subroutine mfl_xm_rhs( dt, xm_old, wpxp, xm_forcing, & km1 = max( k-1, 1 ) ! RHS xm time tendency. - rhs(k) = rhs(k) + xm_old(k) / real( dt, kind = core_rknd ) + rhs(k) = rhs(k) + xm_old(k) / dt ! RHS xm turbulent advection (ta) term. ! Note: Normally, the turbulent advection (ta) term is treated @@ -1112,7 +1109,8 @@ subroutine mfl_xm_solve( solve_type, lhs, rhs, & end subroutine mfl_xm_solve !============================================================================= - subroutine calc_turb_adv_range( dt, pdf_params, & + subroutine calc_turb_adv_range( dt, w_1_zm, w_2_zm, varnce_w_1_zm, varnce_w_2_zm, & + mixt_frac_zm, & low_lev_effect, high_lev_effect ) ! Description: @@ -1147,21 +1145,28 @@ subroutine calc_turb_adv_range( dt, pdf_params, & use grid_class, only: & gr ! Variable(s) - use pdf_parameter_module, only: & - pdf_parameter ! Type - use clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd + core_rknd ! Variable(s) implicit none - + + ! Constant parameters + logical, parameter :: & + l_constant_thickness = .false. ! Toggle constant or variable thickness. + + real( kind = core_rknd ), parameter :: & + const_thick = 150.0_core_rknd ! Constant thickness value [m] + ! Input Variables - real(kind=time_precision), intent(in) :: & - dt ! Model timestep length [s] + real( kind = core_rknd ), intent(in) :: & + dt ! Model timestep length [s] - type(pdf_parameter), dimension(gr%nz), intent(in) :: & - pdf_params ! PDF parameters [units vary] + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + w_1_zm, & ! Mean w (1st PDF component) [m/s] + w_2_zm, & ! Mean w (2nd PDF component) [m/s] + varnce_w_1_zm, & ! Variance of w (1st PDF component) [m^2/s^2] + varnce_w_2_zm, & ! Variance of w (2nd PDF component) [m^2/s^2] + mixt_frac_zm ! Weight of 1st PDF component (Sk_w dependent) [-] ! Output Variables integer, dimension(gr%nz), intent(out) :: & @@ -1173,18 +1178,13 @@ subroutine calc_turb_adv_range( dt, pdf_params, & vert_vel_up, & ! Average upwards vertical velocity component [m/s] vert_vel_down ! Average downwards vertical velocity component [m/s] - real(kind=time_precision) :: & + real(kind = core_rknd ) :: & dt_one_grid_lev, & ! Amount of time to travel one grid box [s] dt_all_grid_levs ! Running count of amount of time taken to travel [s] integer :: k, j - logical, parameter :: & - l_constant_thickness = .false. ! Toggle constant or variable thickness. - - real( kind = core_rknd ), parameter :: & - const_thick = 150.0_core_rknd ! Constant thickness value [m] - + ! ---- Begin Code ---- if ( l_constant_thickness ) then ! thickness is a constant value. @@ -1285,7 +1285,8 @@ subroutine calc_turb_adv_range( dt, pdf_params, & ! vertical velocity. ! Note: A level that has all vertical wind moving downwards will have a ! vert_vel_up value that is 0, and vice versa. - call mean_vert_vel_up_down( pdf_params, 0.0_core_rknd, & + call mean_vert_vel_up_down( w_1_zm, w_2_zm, varnce_w_1_zm, varnce_w_2_zm, & ! In + mixt_frac_zm, 0.0_core_rknd, & ! In vert_vel_down, vert_vel_up ) ! The value of w'x' may only be altered between levels 3 and gr%nz-2. @@ -1300,7 +1301,7 @@ subroutine calc_turb_adv_range( dt, pdf_params, & j = k - 1 ! Initialize the overall delta t counter to 0. - dt_all_grid_levs = 0.0_time_precision + dt_all_grid_levs = 0.0_core_rknd do ! loop downwards until answer is found. @@ -1309,8 +1310,8 @@ subroutine calc_turb_adv_range( dt, pdf_params, & ! Compute the amount of time it takes to travel one grid level ! upwards: delta_t = delta_z / vert_vel_up. - dt_one_grid_lev = real( (1.0_core_rknd/gr%invrs_dzm(j)) / vert_vel_up(j), & - kind=time_precision ) + dt_one_grid_lev = (1.0_core_rknd/gr%invrs_dzm(j)) / vert_vel_up(j) + ! Total time elapsed for crossing all grid levels that have been ! passed, thus far. @@ -1374,7 +1375,7 @@ subroutine calc_turb_adv_range( dt, pdf_params, & j = k + 1 ! Initialize the overall delta t counter to 0. - dt_all_grid_levs = 0.0_time_precision + dt_all_grid_levs = 0.0_core_rknd do ! loop upwards until answer is found. @@ -1387,12 +1388,11 @@ subroutine calc_turb_adv_range( dt, pdf_params, & ! distance traveled is downwards. Since vert_vel_down ! has a negative value, dt_one_grid_lev will be a ! positive value. - dt_one_grid_lev = real( -(1.0_core_rknd/gr%invrs_dzm(j-1)) / vert_vel_down(j-1), & - kind=time_precision ) + dt_one_grid_lev = -(1.0_core_rknd/gr%invrs_dzm(j-1)) / vert_vel_down(j-1) ! Total time elapsed for crossing all grid levels that have been ! passed, thus far. - dt_all_grid_levs = real( dt_all_grid_levs + dt_one_grid_lev, kind=time_precision ) + dt_all_grid_levs = dt_all_grid_levs + dt_one_grid_lev ! Stop if has taken more than one model time step (overall) to ! travel the entire extent of the current vertical grid level. @@ -1462,7 +1462,8 @@ subroutine calc_turb_adv_range( dt, pdf_params, & end subroutine calc_turb_adv_range !============================================================================= - subroutine mean_vert_vel_up_down( pdf_params, w_ref, & + subroutine mean_vert_vel_up_down( w_1_zm, w_2_zm, varnce_w_1_zm, varnce_w_2_zm, & + mixt_frac_zm, w_ref, & mean_w_down, mean_w_up ) ! Description @@ -1496,28 +1497,28 @@ subroutine mean_vert_vel_up_down( pdf_params, w_ref, & ! at any vertical level, are considered to approximately follow a ! distribution that is a mixture of two normal (or Gaussian) distributions. ! The values of w that are a part of the 1st normal distribution are - ! referred to as w1, and the values of w that are part of the 2nd normal - ! distribution are referred to as w2. Note that these distributions - ! overlap, and there are many values of w that are found in both w1 and w2. + ! referred to as w_1, and the values of w that are part of the 2nd normal + ! distribution are referred to as w_2. Note that these distributions + ! overlap, and there are many values of w that are found in both w_1 and w_2. ! ! The probability density function (PDF) for w, P(w), is: ! - ! P(w) = mixt_frac*P(w1) + (1-mixt_frac)*P(w2); + ! P(w) = mixt_frac*P(w_1) + (1-mixt_frac)*P(w_2); ! - ! where "mixt_frac" is the weight of the 1st normal distribution, and P(w1) and - ! P(w2) are the equations for the 1st and 2nd normal distributions, + ! where "mixt_frac" is the weight of the 1st normal distribution, and P(w_1) and + ! P(w_2) are the equations for the 1st and 2nd normal distributions, ! respectively: ! - ! P(w1) = 1 / ( sigma_w1 * sqrt(2*PI) ) - ! * EXP[ -(w1-mu_w1)^2 / (2*sigma_w1^2) ]; and + ! P(w_1) = 1 / ( sigma_w_1 * sqrt(2*PI) ) + ! * EXP[ -(w_1-mu_w_1)^2 / (2*sigma_w_1^2) ]; and ! - ! P(w2) = 1 / ( sigma_w2 * sqrt(2*PI) ) - ! * EXP[ -(w2-mu_w2)^2 / (2*sigma_w2^2) ]. + ! P(w_2) = 1 / ( sigma_w_2 * sqrt(2*PI) ) + ! * EXP[ -(w_2-mu_w_2)^2 / (2*sigma_w_2^2) ]. ! - ! The mean of the 1st normal distribution is mu_w1, and the standard - ! deviation of the 1st normal distribution is sigma_w1. The mean of the - ! 2nd normal distribution is mu_w2, and the standard deviation of the 2nd - ! normal distribution is sigma_w2. + ! The mean of the 1st normal distribution is mu_w_1, and the standard + ! deviation of the 1st normal distribution is sigma_w_1. The mean of the + ! 2nd normal distribution is mu_w_2, and the standard deviation of the 2nd + ! normal distribution is sigma_w_2. ! ! The average value of w, distributed according to the probability ! distribution, between limits alpha and beta, is: @@ -1536,8 +1537,8 @@ subroutine mean_vert_vel_up_down( pdf_params, w_ref, & ! -inf <= w <= w|_ref, such that: ! ! = INT(-inf:w|_ref) w P(w) dw. - ! = mixt_frac * INT(-inf:w|_ref) w1 P(w1) dw1 - ! + (1-mixt_frac) * INT(-inf:w|_ref) w2 P(w2) dw2. + ! = mixt_frac * INT(-inf:w|_ref) w_1 P(w_1) dw_1 + ! + (1-mixt_frac) * INT(-inf:w|_ref) w_2 P(w_2) dw_2. ! ! For each normal distribution in the mixture of normal distribution, i ! (where "i" can be 1 or 2): @@ -1553,14 +1554,14 @@ subroutine mean_vert_vel_up_down( pdf_params, w_ref, & ! The mean of all values of w <= w|_ref is: ! ! = - ! mixt_frac * { - ( sigma_w1 / sqrt(2*PI) ) - ! * EXP[ -(w|_ref-mu_w1)^2 / (2*sigma_w1^2) ] - ! + mu_w1 * (1/2) - ! *[1 + erf( (w|_ref-mu_w1) / (sqrt(2)*sigma_w1) )] } - ! + (1-mixt_frac) * { - ( sigma_w2 / sqrt(2*PI) ) - ! * EXP[ -(w|_ref-mu_w2)^2 / (2*sigma_w2^2) ] - ! + mu_w2 * (1/2) - ! *[1 + erf( (w|_ref-mu_w2) / (sqrt(2)*sigma_w2) )] }. + ! mixt_frac * { - ( sigma_w_1 / sqrt(2*PI) ) + ! * EXP[ -(w|_ref-mu_w_1)^2 / (2*sigma_w_1^2) ] + ! + mu_w_1 * (1/2) + ! *[1 + erf( (w|_ref-mu_w_1) / (sqrt(2)*sigma_w_1) )] } + ! + (1-mixt_frac) * { - ( sigma_w_2 / sqrt(2*PI) ) + ! * EXP[ -(w|_ref-mu_w_2)^2 / (2*sigma_w_2^2) ] + ! + mu_w_2 * (1/2) + ! *[1 + erf( (w|_ref-mu_w_2) / (sqrt(2)*sigma_w_2) )] }. ! ! Average Positive Vertical Velocity ! ---------------------------------- @@ -1570,8 +1571,8 @@ subroutine mean_vert_vel_up_down( pdf_params, w_ref, & ! w|_ref <= w <= inf, such that: ! ! = INT(w|_ref:inf) w P(w) dw. - ! = mixt_frac * INT(w|_ref:inf) w1 P(w1) dw1 - ! + (1-mixt_frac) * INT(w|_ref:inf) w2 P(w2) dw2. + ! = mixt_frac * INT(w|_ref:inf) w_1 P(w_1) dw_1 + ! + (1-mixt_frac) * INT(w|_ref:inf) w_2 P(w_2) dw_2. ! ! For each normal distribution in the mixture of normal distribution, i ! (where "i" can be 1 or 2): @@ -1587,14 +1588,14 @@ subroutine mean_vert_vel_up_down( pdf_params, w_ref, & ! The mean of all values of w >= w|_ref is: ! ! = - ! mixt_frac * { ( sigma_w1 / sqrt(2*PI) ) - ! * EXP[ -(w|_ref-mu_w1)^2 / (2*sigma_w1^2) ] - ! + mu_w1 * (1/2) - ! *[1 - erf( (w|_ref-mu_w1) / (sqrt(2)*sigma_w1) )] } - ! + (1-mixt_frac) * { ( sigma_w2 / sqrt(2*PI) ) - ! * EXP[ -(w|_ref-mu_w2)^2 / (2*sigma_w2^2) ] - ! + mu_w2 * (1/2) - ! *[1 - erf( (w|_ref-mu_w2) / (sqrt(2)*sigma_w2) )] }. + ! mixt_frac * { ( sigma_w_1 / sqrt(2*PI) ) + ! * EXP[ -(w|_ref-mu_w_1)^2 / (2*sigma_w_1^2) ] + ! + mu_w_1 * (1/2) + ! *[1 - erf( (w|_ref-mu_w_1) / (sqrt(2)*sigma_w_1) )] } + ! + (1-mixt_frac) * { ( sigma_w_2 / sqrt(2*PI) ) + ! * EXP[ -(w|_ref-mu_w_2)^2 / (2*sigma_w_2^2) ] + ! + mu_w_2 * (1/2) + ! *[1 - erf( (w|_ref-mu_w_2) / (sqrt(2)*sigma_w_2) )] }. ! ! Special Limitations: ! -------------------- @@ -1651,18 +1652,15 @@ subroutine mean_vert_vel_up_down( pdf_params, w_ref, & sqrt_2pi, & sqrt_2 - use pdf_parameter_module, only: & - pdf_parameter ! type - use anl_erf, only: & erf ! Procedure(s) ! The error function - use stats_type, only: & + use stats_type_utilities, only: & stat_update_var_pt ! Procedure(s) use stats_variables, only: & - zm, & ! Variable(s) + stats_zm, & ! Variable(s) imean_w_up, & imean_w_down, & l_stats_samp @@ -1670,14 +1668,15 @@ subroutine mean_vert_vel_up_down( pdf_params, w_ref, & use clubb_precision, only: & core_rknd ! Variable(s) - use constants_clubb, only: & - zero_threshold - implicit none ! Input Variables - type(pdf_parameter), dimension(gr%nz), intent(in) :: & - pdf_params ! PDF parameters + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + w_1_zm, & ! Mean w (1st PDF component) [m/s] + w_2_zm, & ! Mean w (2nd PDF component) [m/s] + varnce_w_1_zm, & ! Variance of w (1st PDF component) [m^2/s^2] + varnce_w_2_zm, & ! Variance of w (2nd PDF component) [m^2/s^2] + mixt_frac_zm ! Weight of 1st PDF component (Sk_w dependent) [-] real( kind = core_rknd ), intent(in) :: & w_ref ! Reference velocity, w|_ref (normally = 0) [m/s] @@ -1689,17 +1688,9 @@ subroutine mean_vert_vel_up_down( pdf_params, w_ref, & ! Local Variables - ! PDF parameters unpacked and interpolated to momentum levels - real( kind = core_rknd ), dimension(gr%nz) :: & - w1, & ! Mean of w for 1st normal distribution [m/s] - w2, & ! Mean of w for 2nd normal distribution [m/s] - varnce_w1, & ! Variance of w for 1st normal distribution [m^2/s^2] - varnce_w2, & ! Variance of w for 2nd normal distribution [m^2/s^2] - mixt_frac ! Weight of 1st normal distribution (Sk_w dependent) [-] - real( kind = core_rknd ) :: & - sigma_w1, & ! Standard deviation of w for 1st normal distribution [m/s] - sigma_w2, & ! Standard deviation of w for 2nd normal distribution [m/s] + sigma_w_1, & ! Standard deviation of w for 1st normal distribution [m/s] + sigma_w_2, & ! Standard deviation of w for 2nd normal distribution [m/s] mean_w_down_1st, & ! Mean w (<= w|_ref) from 1st normal distribution [m/s] mean_w_down_2nd, & ! Mean w (<= w|_ref) from 2nd normal distribution [m/s] mean_w_up_1st, & ! Mean w (>= w|_ref) from 1st normal distribution [m/s] @@ -1709,69 +1700,60 @@ subroutine mean_vert_vel_up_down( pdf_params, w_ref, & integer :: k ! Vertical loop index - - ! All of the PDF parameters are computed on thermodynamic levels. - ! Interpolate the needed PDF parameters from thermodynamic levels - ! to momentum levels. - w1 = zt2zm( pdf_params%w1 ) - w2 = zt2zm( pdf_params%w2 ) - varnce_w1 = max(zt2zm( pdf_params%varnce_w1), zero_threshold ) - varnce_w2 = max(zt2zm( pdf_params%varnce_w2), zero_threshold ) - mixt_frac = zt2zm( pdf_params%mixt_frac ) - + ! ---- Begin Code ---- ! Loop over momentum levels from 2 to gr%nz-1. Levels 1 and gr%nz ! are not needed. do k = 2, gr%nz-1, 1 ! Standard deviation of w for the 1st normal distribution. - sigma_w1 = sqrt( varnce_w1(k) ) + sigma_w_1 = sqrt( varnce_w_1_zm(k) ) ! Standard deviation of w for the 2nd normal distribution. - sigma_w2 = sqrt( varnce_w2(k) ) + sigma_w_2 = sqrt( varnce_w_2_zm(k) ) ! Contributions from the 1st normal distribution. - if ( w1(k) + 3._core_rknd*sigma_w1 <= w_ref ) then + if ( w_1_zm(k) + 3._core_rknd*sigma_w_1 <= w_ref ) then ! The entire 1st normal is on the negative side of w|_ref. - mean_w_down_1st = w1(k) + mean_w_down_1st = w_1_zm(k) mean_w_up_1st = 0.0_core_rknd - elseif ( w1(k) - 3._core_rknd*sigma_w1 >= w_ref ) then + elseif ( w_1_zm(k) - 3._core_rknd*sigma_w_1 >= w_ref ) then ! The entire 1st normal is on the positive side of w|_ref. mean_w_down_1st = 0.0_core_rknd - mean_w_up_1st = w1(k) + mean_w_up_1st = w_1_zm(k) else ! The exponential calculation is pulled out as it is reused in both ! equations. This should save one calculation of the - ! exp( -(w_ref-w1(k))**2 ... etc. part of the formula. + ! exp( -(w_ref-w_1_zm(k))**2 ... etc. part of the formula. ! ~~EIHoppe//20090618 - exp_cache = exp( -(w_ref-w1(k))**2 / (2.0_core_rknd*sigma_w1**2) ) + exp_cache = exp( -(w_ref-w_1_zm(k))**2 / (2.0_core_rknd*sigma_w_1**2) ) ! Added cache of the error function calculations. ! This should save one calculation of the erf(...) part ! of the formula. ! ~~EIHoppe//20090623 - erf_cache = erf( (w_ref-w1(k)) / (sqrt_2*sigma_w1) ) + erf_cache = erf( (w_ref-w_1_zm(k)) / (sqrt_2*sigma_w_1) ) ! The 1st normal has values on both sides of w_ref. mean_w_down_1st = & - - (sigma_w1/sqrt_2pi) & -! * exp( -(w_ref-w1(k))**2 / (2.0_core_rknd*sigma_w1**2) ) & + - (sigma_w_1/sqrt_2pi) & +! * exp( -(w_ref-w_1_zm(k))**2 / (2.0_core_rknd*sigma_w_1**2) ) & * exp_cache & -! + w1(k) * 0.5_core_rknd*( 1.0_core_rknd + erf( (w_ref-w1(k)) / (sqrt_2*sigma_w1) ) ) - + w1(k) * 0.5_core_rknd*( 1.0_core_rknd + erf_cache) +! + w_1(k) * 0.5_core_rknd*( 1.0_core_rknd + erf( (w_ref-w_1(k)) / (sqrt_2*sigma_w_1) ) ) + + w_1_zm(k) * 0.5_core_rknd*( 1.0_core_rknd + erf_cache) mean_w_up_1st = & - + (sigma_w1/sqrt_2pi) & -! * exp( -(w_ref-w1(k))**2 / (2.0_core_rknd*sigma_w1**2) ) & + + (sigma_w_1/sqrt_2pi) & +! * exp( -(w_ref-w_1(k))**2 / (2.0_core_rknd*sigma_w_1**2) ) & * exp_cache & -! + w1(k) * 0.5_core_rknd*( 1.0_core_rknd - erf( (w_ref-w1(k)) / (sqrt_2*sigma_w1) ) ) - + w1(k) * 0.5_core_rknd*( 1.0_core_rknd - erf_cache) +! + w_1(k) * 0.5_core_rknd*( 1.0_core_rknd - erf( (w_ref-w_1(k)) / (sqrt_2*sigma_w_1) ) ) + + w_1_zm(k) * 0.5_core_rknd*( 1.0_core_rknd - erf_cache) ! /EIHoppe changes @@ -1779,64 +1761,64 @@ subroutine mean_vert_vel_up_down( pdf_params, w_ref, & ! Contributions from the 2nd normal distribution. - if ( w2(k) + 3._core_rknd*sigma_w2 <= w_ref ) then + if ( w_2_zm(k) + 3._core_rknd*sigma_w_2 <= w_ref ) then ! The entire 2nd normal is on the negative side of w|_ref. - mean_w_down_2nd = w2(k) + mean_w_down_2nd = w_2_zm(k) mean_w_up_2nd = 0.0_core_rknd - elseif ( w2(k) - 3._core_rknd*sigma_w2 >= w_ref ) then + elseif ( w_2_zm(k) - 3._core_rknd*sigma_w_2 >= w_ref ) then ! The entire 2nd normal is on the positive side of w|_ref. mean_w_down_2nd = 0.0_core_rknd - mean_w_up_2nd = w2(k) + mean_w_up_2nd = w_2_zm(k) else ! The exponential calculation is pulled out as it is reused in both ! equations. This should save one calculation of the - ! exp( -(w_ref-w1(k))**2 ... etc. part of the formula. + ! exp( -(w_ref-w_1(k))**2 ... etc. part of the formula. ! ~~EIHoppe//20090618 - exp_cache = exp( -(w_ref-w2(k))**2 / (2.0_core_rknd*sigma_w2**2) ) + exp_cache = exp( -(w_ref-w_2_zm(k))**2 / (2.0_core_rknd*sigma_w_2**2) ) ! Added cache of the error function calculations. ! This should save one calculation of the erf(...) part ! of the formula. ! ~~EIHoppe//20090623 - erf_cache = erf( (w_ref-w2(k)) / (sqrt_2*sigma_w2) ) + erf_cache = erf( (w_ref-w_2_zm(k)) / (sqrt_2*sigma_w_2) ) ! The 2nd normal has values on both sides of w_ref. mean_w_down_2nd = & - - (sigma_w2/sqrt_2pi) & -! * exp( -(w_ref-w2(k))**2 / (2.0_core_rknd*sigma_w2**2) ) & + - (sigma_w_2/sqrt_2pi) & +! * exp( -(w_ref-w_2_zm(k))**2 / (2.0_core_rknd*sigma_w_2**2) ) & * exp_cache & -! + w2(k) * 0.5_core_rknd*( 1.0_core_rknd + erf( (w_ref-w2(k)) / (sqrt_2*sigma_w2) ) ) - + w2(k) * 0.5_core_rknd*( 1.0_core_rknd + erf_cache) +! + w_2_zm(k) * 0.5_core_rknd*( 1.0_core_rknd + erf( (w_ref-w_2(k)) / (sqrt_2*sigma_w_2) ) ) + + w_2_zm(k) * 0.5_core_rknd*( 1.0_core_rknd + erf_cache) mean_w_up_2nd = & - + (sigma_w2/sqrt_2pi) & -! * exp( -(w_ref-w2(k))**2 / (2.0_core_rknd*sigma_w2**2) ) & + + (sigma_w_2/sqrt_2pi) & +! * exp( -(w_ref-w_2(k))**2 / (2.0_core_rknd*sigma_w_2**2) ) & * exp_cache & -! + w2(k) * 0.5_core_rknd*( 1.0_core_rknd - erf( (w_ref-w2(k)) / (sqrt_2*sigma_w2) ) ) - + w2(k) * 0.5_core_rknd*( 1.0_core_rknd - erf_cache) +! + w_2(k) * 0.5_core_rknd*( 1.0_core_rknd - erf( (w_ref-w_2(k)) / (sqrt_2*sigma_w_2) ) ) + + w_2_zm(k) * 0.5_core_rknd*( 1.0_core_rknd - erf_cache) ! /EIHoppe changes endif ! Overall mean of downwards w. - mean_w_down(k) = mixt_frac(k) * mean_w_down_1st & - + ( 1.0_core_rknd - mixt_frac(k) ) * mean_w_down_2nd + mean_w_down(k) = mixt_frac_zm(k) * mean_w_down_1st & + + ( 1.0_core_rknd - mixt_frac_zm(k) ) * mean_w_down_2nd ! Overall mean of upwards w. - mean_w_up(k) = mixt_frac(k) * mean_w_up_1st & - + ( 1.0_core_rknd - mixt_frac(k) ) * mean_w_up_2nd + mean_w_up(k) = mixt_frac_zm(k) * mean_w_up_1st & + + ( 1.0_core_rknd - mixt_frac_zm(k) ) * mean_w_up_2nd if ( l_stats_samp ) then - call stat_update_var_pt( imean_w_up, k, mean_w_up(k), zm ) + call stat_update_var_pt( imean_w_up, k, mean_w_up(k), stats_zm ) - call stat_update_var_pt( imean_w_down, k, mean_w_down(k), zm ) + call stat_update_var_pt( imean_w_down, k, mean_w_down(k), stats_zm ) endif ! l_stats_samp diff --git a/models/atm/cam/src/physics/clubb/mt95.f90 b/models/atm/cam/src/physics/clubb/mt95.f90 index 36136e0f3b4c..881e1298a0c7 100644 --- a/models/atm/cam/src/physics/clubb/mt95.f90 +++ b/models/atm/cam/src/physics/clubb/mt95.f90 @@ -128,6 +128,7 @@ module mt95 end type genrand_srepr type(genrand_state), private, save :: state +!$omp threadprivate(state) interface assignment( = ) module procedure genrand_load_state diff --git a/models/atm/cam/src/physics/clubb/numerical_check.F90 b/models/atm/cam/src/physics/clubb/numerical_check.F90 index 76664dfb33f6..b5f8cbf078fa 100644 --- a/models/atm/cam/src/physics/clubb/numerical_check.F90 +++ b/models/atm/cam/src/physics/clubb/numerical_check.F90 @@ -1,5 +1,6 @@ !------------------------------------------------------------------------ -! $Id: numerical_check.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +! $Id: numerical_check.F90 7309 2014-09-20 17:06:28Z betlej@uwm.edu $ +!=============================================================================== module numerical_check implicit none @@ -82,10 +83,10 @@ subroutine pdf_closure_check( wp4, wprtp2, wp2rtp, wpthlp2, & wp2thlp, cloud_frac, rcm, wpthvp, wp2thvp, & rtpthvp, thlpthvp, wprcp, wp2rcp, & rtprcp, thlprcp, rcp2, wprtpthlp, & - crt1, crt2, cthl1, cthl2, pdf_params, & - err_code, & + crt_1, crt_2, cthl_1, cthl_2, pdf_params, & sclrpthvp, sclrprcp, wpsclrp2, & - wpsclrprtp, wpsclrpthlp, wp2sclrp ) + wpsclrprtp, wpsclrpthlp, wp2sclrp, & + err_code ) ! Description: This subroutine determines if any of the output ! variables for the pdf_closure subroutine carry values that @@ -135,8 +136,8 @@ subroutine pdf_closure_check( wp4, wprtp2, wp2rtp, wpthlp2, & thlprcp, & ! th_l' r_c' [(K kg)/kg] rcp2, & ! r_c'^2 [(kg^2)/(kg^2)] wprtpthlp, & ! w' r_t' th_l' [(m kg K)/(s kg)] - crt1, crt2, & - cthl1, cthl2 + crt_1, crt_2, & + cthl_1, cthl_2 type(pdf_parameter), intent(in) :: & pdf_params ! PDF parameters [units vary] @@ -175,35 +176,35 @@ subroutine pdf_closure_check( wp4, wprtp2, wp2rtp, wpthlp2, & call check_nan( thlprcp, "thlprcp", proc_name, err_code ) if ( ircp2 > 0 ) call check_nan( rcp2, "rcp2", proc_name, err_code) if ( iwprtpthlp > 0 ) call check_nan( wprtpthlp, "wprtpthlp", proc_name, err_code ) - call check_nan( crt1, "crt1", proc_name, err_code ) - call check_nan( crt2, "crt2", proc_name, err_code ) - call check_nan( cthl1, "cthl1", proc_name, err_code ) - call check_nan( cthl2, "cthl2", proc_name, err_code ) + call check_nan( crt_1, "crt_1", proc_name, err_code ) + call check_nan( crt_2, "crt_2", proc_name, err_code ) + call check_nan( cthl_1, "cthl_1", proc_name, err_code ) + call check_nan( cthl_2, "cthl_2", proc_name, err_code ) ! Check each PDF parameter at the grid level sent in. - call check_nan( pdf_params%w1, "pdf_params%w1", proc_name, err_code ) - call check_nan( pdf_params%w2, "pdf_params%w2", proc_name, err_code ) - call check_nan( pdf_params%varnce_w1, "pdf_params%varnce_w1", proc_name, err_code ) - call check_nan( pdf_params%varnce_w2, "pdf_params%varnce_w2", proc_name, err_code ) - call check_nan( pdf_params%rt1, "pdf_params%rt1", proc_name, err_code ) - call check_nan( pdf_params%rt2, "pdf_params%rt2", proc_name, err_code ) - call check_nan( pdf_params%varnce_rt1, "pdf_params%varnce_rt1", proc_name, err_code ) - call check_nan( pdf_params%varnce_rt2, "pdf_params%varnce_rt2", proc_name, err_code ) - call check_nan( pdf_params%thl1, "pdf_params%thl1", proc_name, err_code ) - call check_nan( pdf_params%thl2, "pdf_params%thl2", proc_name, err_code ) - call check_nan( pdf_params%varnce_thl1, "pdf_params%varnce_thl1", proc_name, err_code ) - call check_nan( pdf_params%varnce_thl2, "pdf_params%varnce_thl2", proc_name, err_code ) + call check_nan( pdf_params%w_1, "pdf_params%w_1", proc_name, err_code ) + call check_nan( pdf_params%w_2, "pdf_params%w_2", proc_name, err_code ) + call check_nan( pdf_params%varnce_w_1, "pdf_params%varnce_w_1", proc_name, err_code ) + call check_nan( pdf_params%varnce_w_2, "pdf_params%varnce_w_2", proc_name, err_code ) + call check_nan( pdf_params%rt_1, "pdf_params%rt_1", proc_name, err_code ) + call check_nan( pdf_params%rt_2, "pdf_params%rt_2", proc_name, err_code ) + call check_nan( pdf_params%varnce_rt_1, "pdf_params%varnce_rt_1", proc_name, err_code ) + call check_nan( pdf_params%varnce_rt_2, "pdf_params%varnce_rt_2", proc_name, err_code ) + call check_nan( pdf_params%thl_1, "pdf_params%thl_1", proc_name, err_code ) + call check_nan( pdf_params%thl_2, "pdf_params%thl_2", proc_name, err_code ) + call check_nan( pdf_params%varnce_thl_1, "pdf_params%varnce_thl_1", proc_name, err_code ) + call check_nan( pdf_params%varnce_thl_2, "pdf_params%varnce_thl_2", proc_name, err_code ) call check_nan( pdf_params%mixt_frac, "pdf_params%mixt_frac", proc_name, err_code ) call check_nan( pdf_params%rrtthl, "pdf_params%rrtthl", proc_name, err_code ) - call check_nan( pdf_params%rc1, "pdf_params%rc1", proc_name, err_code ) - call check_nan( pdf_params%rc2, "pdf_params%rc2", proc_name, err_code ) - call check_nan( pdf_params%rsl1, "pdf_params%rsl1", proc_name, err_code ) - call check_nan( pdf_params%rsl2, "pdf_params%rsl2", proc_name, err_code ) - call check_nan( pdf_params%cloud_frac1, "pdf_params%cloud_frac1", proc_name, err_code ) - call check_nan( pdf_params%cloud_frac2, "pdf_params%cloud_frac2", proc_name, err_code ) - call check_nan( pdf_params%s1, "pdf_params%s1", proc_name, err_code ) - call check_nan( pdf_params%s2, "pdf_params%s2", proc_name, err_code ) - call check_nan( pdf_params%stdev_s1, "pdf_params%stdev_s1", proc_name, err_code ) - call check_nan( pdf_params%stdev_s2, "pdf_params%stdev_s2", proc_name, err_code ) + call check_nan( pdf_params%rc_1, "pdf_params%rc_1", proc_name, err_code ) + call check_nan( pdf_params%rc_2, "pdf_params%rc_2", proc_name, err_code ) + call check_nan( pdf_params%rsatl_1, "pdf_params%rsatl_1", proc_name, err_code ) + call check_nan( pdf_params%rsatl_2, "pdf_params%rsatl_2", proc_name, err_code ) + call check_nan( pdf_params%cloud_frac_1, "pdf_params%cloud_frac_1", proc_name, err_code ) + call check_nan( pdf_params%cloud_frac_2, "pdf_params%cloud_frac_2", proc_name, err_code ) + call check_nan( pdf_params%chi_1, "pdf_params%chi_1", proc_name, err_code ) + call check_nan( pdf_params%chi_2, "pdf_params%chi_2", proc_name, err_code ) + call check_nan( pdf_params%stdev_chi_1, "pdf_params%stdev_chi_1", proc_name, err_code ) + call check_nan( pdf_params%stdev_chi_2, "pdf_params%stdev_chi_2", proc_name, err_code ) call check_nan( pdf_params%alpha_thl, "pdf_params%alpha_thl", proc_name, err_code ) call check_nan( pdf_params%alpha_rt, "pdf_params%alpha_rt", proc_name, err_code ) @@ -431,8 +432,9 @@ end subroutine parameterization_check !----------------------------------------------------------------------- subroutine surface_varnce_check( wp2_sfc, up2_sfc, vp2_sfc, thlp2_sfc, & - rtp2_sfc, rtpthlp_sfc, err_code, & - sclrp2_sfc, sclrprtp_sfc, sclrpthlp_sfc ) + rtp2_sfc, rtpthlp_sfc, & + sclrp2_sfc, sclrprtp_sfc, sclrpthlp_sfc, & + err_code ) ! ! Description:This subroutine determines if any of the output ! variables for the surface_varnce subroutine carry values that @@ -500,16 +502,13 @@ subroutine surface_varnce_check( wp2_sfc, up2_sfc, vp2_sfc, thlp2_sfc, & end subroutine surface_varnce_check !----------------------------------------------------------------------- - subroutine rad_check( thlm, rcm, rtm, ricem, & + subroutine rad_check( thlm, rcm, rtm, rim, & cloud_frac, p_in_Pa, exner, rho_zm ) ! Description: ! Checks radiation input variables. If they are < 0 it reports ! to the console. !------------------------------------------------------------------------ - use constants_clubb, only: & - fstderr ! Variable - use grid_class, only: & gr ! Variable @@ -527,7 +526,7 @@ subroutine rad_check( thlm, rcm, rtm, ricem, & thlm, & ! Liquid Water Potential Temperature [K/s] rcm, & ! Liquid Water Mixing Ratio [kg/kg] rtm, & ! Total Water Mixing Ratio [kg/kg] - ricem, & ! Ice Water Mixing Ratio [kg/kg] + rim, & ! Ice Water Mixing Ratio [kg/kg] cloud_frac, & ! Cloud Fraction [-] p_in_Pa, & ! Pressure [Pa] exner, & ! Exner Function [-] @@ -544,7 +543,7 @@ subroutine rad_check( thlm, rcm, rtm, ricem, & call check_negative( rcm, gr%nz ,"rcm", proc_name ) call check_negative( rtm, gr%nz ,"rtm", proc_name ) call check_negative( rvm, gr%nz ,"rvm", proc_name ) - call check_negative( ricem, gr%nz ,"ricem", proc_name ) + call check_negative( rim, gr%nz ,"rim", proc_name ) call check_negative( cloud_frac, gr%nz ,"cloud_frac", proc_name ) call check_negative( p_in_Pa, gr%nz ,"p_in_Pa", proc_name ) call check_negative( exner, gr%nz ,"exner", proc_name ) @@ -593,7 +592,7 @@ logical function invalid_model_arrays( ) edsclr_dim, & hydromet_dim - use parameters_microphys, only: & + use array_index, only: & hydromet_list ! Variable(s) implicit none diff --git a/models/atm/cam/src/physics/clubb/output_grads.F90 b/models/atm/cam/src/physics/clubb/output_grads.F90 index aee86b2c9ac2..4c1d7d2ef44e 100644 --- a/models/atm/cam/src/physics/clubb/output_grads.F90 +++ b/models/atm/cam/src/physics/clubb/output_grads.F90 @@ -1,5 +1,6 @@ !------------------------------------------------------------------------------- -! $Id: output_grads.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +! $Id: output_grads.F90 7140 2014-07-31 19:14:05Z betlej@uwm.edu $ +!=============================================================================== module output_grads @@ -37,7 +38,7 @@ module output_grads !------------------------------------------------------------------------------- subroutine open_grads( iunit, fdir, fname, & - ia, iz, z, & + ia, iz, nlat, nlon, z, & day, month, year, rlat, rlon, & time, dtwrite, & nvar, grads_file ) @@ -49,8 +50,8 @@ subroutine open_grads( iunit, fdir, fname, & ! None !------------------------------------------------------------------------------- use constants_clubb, only: & - fstderr, & ! Variable - fstdout + fstderr, & ! Constant(s) + sec_per_min use stat_file_module, only: & stat_file ! Type @@ -58,6 +59,9 @@ subroutine open_grads( iunit, fdir, fname, & use clubb_precision, only: & time_precision ! Variable + use stats_variables, only: & + l_allow_small_stats_tout + implicit none ! Input Variables @@ -69,21 +73,28 @@ subroutine open_grads( iunit, fdir, fname, & fname ! Name of file [-] integer, intent(in) :: & - ia, & ! Lower Bound of z [-] - iz ! Upper Bound of z [-] + ia, & ! Lower Bound of z (altitude) [-] + iz, & ! Upper Bound of z (altitude) [-] + nlat, & ! Number of points in the y direction (latitude) [-] + nlon ! Number of points in the x direction (longitude) [-] - real( kind = core_rknd ), dimension(:), intent(in) :: z + real( kind = core_rknd ), dimension(:), intent(in) :: & + z ! Vertical levels [m] integer, intent(in) :: & day, & ! Day of Month at Model Start [dd] month, & ! Month of Year at Model start [mm] year ! Year at Model Start [yyyy] - real( kind = core_rknd ), dimension(1), intent(in) :: & - rlat, rlon ! Latitude and Longitude [Degrees N/E] + real( kind = core_rknd ), dimension(nlat), intent(in) :: & + rlat ! Latitude [Degrees E] - real(kind=time_precision), intent(in) :: & - time, & ! Time since Model start [s] + real( kind = core_rknd ), dimension(nlon), intent(in) :: & + rlon ! Longitude [Degrees N] + + real( kind = time_precision ), intent(in) :: & + time ! Time since Model start [s] + real( kind = core_rknd ), intent(in) :: & dtwrite ! Time interval for output [s] ! Number of GrADS variables to store [#] @@ -124,7 +135,10 @@ subroutine open_grads( iunit, fdir, fname, & grads_file%month = month grads_file%year = year - allocate( grads_file%rlat(1), grads_file%rlon(1) ) + grads_file%nlat = nlat + grads_file%nlon = nlon + + allocate( grads_file%rlat(nlat), grads_file%rlon(nlon) ) grads_file%rlat = rlat grads_file%rlon = rlon @@ -133,6 +147,20 @@ subroutine open_grads( iunit, fdir, fname, & grads_file%nvar = nvar + ! Check to make sure the timestep is appropriate. GrADS does not support an + ! output timestep less than 1 minute. + if (dtwrite < sec_per_min) then + write(fstderr,*) "Warning: GrADS requires an output timestep of at least & + &one minute, but the requested output timestep & + &(stats_tout) is less than one minute." + if (.not. l_allow_small_stats_tout) then + write(fstderr,*) "To override this warning, set l_allow_small_stats_tout = & + &.true. in the stats_setting namelist in the & + &appropriate *_model.in file." + stop "Fatal error in open_grads" + end if + end if + ! Check whether GrADS files already exists ! We don't use this feature for the single-column model. The @@ -213,7 +241,6 @@ subroutine check_grads( iunit, fdir, fname, & use constants_clubb, only: & fstderr, & ! Variable - fstdout, & sec_per_hr, & sec_per_min @@ -230,10 +257,10 @@ subroutine check_grads( iunit, fdir, fname, & character(len=*), intent(in) :: & fdir, fname ! File directory and name - real(kind=time_precision), intent(in) :: & + real( kind = time_precision ), intent(in) :: & time ! Current model time [s] - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dtwrite ! Time interval between writes to the file [s] ! Output Variables @@ -256,7 +283,7 @@ subroutine check_grads( iunit, fdir, fname, & ia_in, iz_in, ntimes_in, nvar_in, & day_in, month_in, year_in - real(kind=time_precision) :: dtwrite_in + real( kind = core_rknd ) :: dtwrite_in real( kind = core_rknd ), dimension(:), allocatable :: z_in @@ -314,8 +341,8 @@ subroutine check_grads( iunit, fdir, fname, & read(unit=line,fmt=*) tmp, ntimes_in, tmp, date, dt read(unit=date(1:2),fmt=*) ihour read(unit=date(4:5),fmt=*) imin - time_grads = real( ihour, kind=time_precision ) * sec_per_hr & - + real( imin, kind=time_precision ) * sec_per_min + time_grads = real( ihour, kind=time_precision) * real(sec_per_hr,kind=time_precision) & + + real( imin, kind=time_precision ) * real(sec_per_min,kind=time_precision) read(unit=date(7:8),fmt=*) day_in read(unit=date(12:15),fmt=*) year_in @@ -468,8 +495,10 @@ subroutine write_grads( grads_file ) stat_file ! Type use clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd + time_precision ! Variable(s) + +! use stat_file_module, only: & +! clubb_i, clubb_j ! Variable(s) implicit none @@ -486,8 +515,8 @@ subroutine write_grads( grads_file ) ! Local Variables integer :: & - i, & ! Loop indices - ios ! I/O status + ivar, & ! Loop indices + ios ! I/O status indicator character(len=15) :: date @@ -505,7 +534,7 @@ subroutine write_grads( grads_file ) open( unit=grads_file%iounit, & file=trim( grads_file%fdir )//trim( grads_file%fname )//'.dat', & form='unformatted', access='direct', & - recl=F_RECL*abs( grads_file%iz-grads_file%ia+1 ), & + recl=F_RECL*abs( grads_file%iz-grads_file%ia+1 )*grads_file%nlon*grads_file%nlat, & status='unknown', iostat=ios ) if ( ios /= 0 ) then write(unit=fstderr,fmt=*) & @@ -515,16 +544,18 @@ subroutine write_grads( grads_file ) end if if ( grads_file%ia <= grads_file%iz ) then - do i=1,grads_file%nvar - write(grads_file%iounit,rec=grads_file%nrecord) & - real( grads_file%var(i)%ptr(1,1,grads_file%ia:grads_file%iz), kind=r4) + do ivar=1,grads_file%nvar + write(grads_file%iounit,rec=grads_file%nrecord) & + real( grads_file%var(ivar)%ptr(1:grads_file%nlon, & + 1:grads_file%nlat,grads_file%ia:grads_file%iz), kind=r4) grads_file%nrecord = grads_file%nrecord + 1 end do else - do i=1, grads_file%nvar + do ivar=1, grads_file%nvar write(grads_file%iounit,rec=grads_file%nrecord) & - real( grads_file%var(i)%ptr(1,1,grads_file%ia:grads_file%iz:-1), kind=r4) + real( grads_file%var(ivar)%ptr(1:grads_file%nlon, & + 1:grads_file%nlat,grads_file%ia:grads_file%iz:-1), kind=r4) grads_file%nrecord = grads_file%nrecord + 1 end do @@ -564,21 +595,34 @@ subroutine write_grads( grads_file ) end if write(unit=grads_file%iounit,fmt='(a)') 'DSET ^'//trim( grads_file%fname )//'.dat' - write(unit=grads_file%iounit,fmt='(a,e11.5)') 'UNDEF ',undef - write(unit=grads_file%iounit,fmt='(a,f8.3,a)') 'XDEF 1 LINEAR ', grads_file%rlon, ' 1.' - write(unit=grads_file%iounit,fmt='(a,f8.3,a)') 'YDEF 1 LINEAR ', grads_file%rlat, ' 1.' - if ( grads_file%ia == grads_file%iz ) then + write(unit=grads_file%iounit,fmt='(a,e12.5)') 'UNDEF ',undef + + if ( grads_file%nlon == 1 ) then ! Use linear for a singleton X dimesion + write(unit=grads_file%iounit,fmt='(a,f8.3,a)') 'XDEF 1 LINEAR ', grads_file%rlon, ' 1.' + else + write(unit=grads_file%iounit,fmt='(a,i5,a)') 'XDEF', grads_file%nlon,' LEVELS ' + write(unit=grads_file%iounit,fmt='(6f13.4)') grads_file%rlon + end if + + if ( grads_file%nlat == 1 ) then ! Use linear for a singleton Y dimension + write(unit=grads_file%iounit,fmt='(a,f8.3,a)') 'YDEF 1 LINEAR ', grads_file%rlat, ' 1.' + else + write(unit=grads_file%iounit,fmt='(a,i5,a)') 'YDEF', grads_file%nlat,' LEVELS ' + write(unit=grads_file%iounit,fmt='(6f13.4)') grads_file%rlat + end if + + if ( grads_file%ia == grads_file%iz ) then ! If ia == iz, then Z is also singleton write(unit=grads_file%iounit,fmt='(a)') 'ZDEF 1 LEVELS 0.' else if ( grads_file%ia < grads_file%iz ) then write(unit=grads_file%iounit,fmt='(a,i5,a)') & 'ZDEF', abs(grads_file%iz-grads_file%ia)+1,' LEVELS ' write(unit=grads_file%iounit,fmt='(6f13.4)') & - (grads_file%z(i-grads_file%ia+1),i=grads_file%ia,grads_file%iz) + (grads_file%z(ivar-grads_file%ia+1),ivar=grads_file%ia,grads_file%iz) else write(unit=grads_file%iounit,fmt='(a,i5,a)') & 'ZDEF',abs(grads_file%iz-grads_file%ia)+1,' LEVELS ' - write(grads_file%iounit,'(6f13.4)') (grads_file%z(grads_file%ia-i+1), & - i=grads_file%ia,grads_file%iz,-1) + write(grads_file%iounit,'(6f13.4)') (grads_file%z(grads_file%ia-ivar+1), & + ivar=grads_file%ia,grads_file%iz,-1) end if call format_date( grads_file%day, grads_file%month, grads_file%year, grads_file%time, & ! In @@ -593,11 +637,11 @@ subroutine write_grads( grads_file ) ! Variables description write(unit=grads_file%iounit,fmt='(a,i5)') 'VARS', grads_file%nvar - do i=1, grads_file%nvar, 1 + do ivar=1, grads_file%nvar, 1 write(unit=grads_file%iounit,fmt='(a,i5,a,a)') & - grads_file%var(i)%name(1:len_trim(grads_file%var(i)%name)), & + grads_file%var(ivar)%name(1:len_trim(grads_file%var(ivar)%name)), & abs(grads_file%iz-grads_file%ia)+1,' 99 ', & - grads_file%var(i)%description(1:len_trim(grads_file%var(i)%description)) + grads_file%var(ivar)%description(1:len_trim(grads_file%var(ivar)%description)) end do write(unit=grads_file%iounit,fmt='(a)') 'ENDVARS' @@ -624,14 +668,13 @@ subroutine format_date( day_in, month_in, year_in, time_in, & ! None !--------------------------------------------------------- use clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd + time_precision ! Variable(s) use calendar, only: & compute_current_date ! Procedure(s) use calendar, only: & - month ! Variable(s) + month_names ! Variable(s) use constants_clubb, only: & sec_per_hr, & ! Variable(s) @@ -674,9 +717,9 @@ subroutine format_date( day_in, month_in, year_in, time_in, & date = 'hh:mmZddmmmyyyy' write(unit=date(7:8),fmt='(i2.2)') iday - write(unit=date(9:11),fmt='(a3)') month(imonth) + write(unit=date(9:11),fmt='(a3)') month_names(imonth) write(unit=date(12:15),fmt='(i4.4)') iyear - write(unit=date(1:2),fmt='(i2.2)') floor( time/sec_per_hr ) + write(unit=date(1:2),fmt='(i2.2)') floor(time/real(sec_per_hr,kind=time_precision )) write(unit=date(4:5),fmt='(i2.2)') & int( mod( nint( time ), nint(sec_per_hr) ) / nint(min_per_hr) ) @@ -697,8 +740,6 @@ subroutine determine_time_inc( dtwrite_sec, & sec_per_hr, & sec_per_min - use clubb_precision, only: & - time_precision ! Variable(s) implicit none @@ -706,7 +747,7 @@ subroutine determine_time_inc( dtwrite_sec, & intrinsic :: max, floor ! Input Variables - real(kind=time_precision), intent(in) :: & + real(kind=core_rknd), intent(in) :: & dtwrite_sec ! Time increment in GrADS [s] ! Output Variables @@ -716,7 +757,7 @@ subroutine determine_time_inc( dtwrite_sec, & character(len=2), intent(out) :: units ! Units on dtwrite_ctl ! Local variables - real(kind=time_precision) :: & + real(kind=core_rknd) :: & dtwrite_min, & ! Time increment [minutes] dtwrite_hrs, & ! Time increment [hours] dtwrite_days ! Time increment [days] @@ -725,20 +766,20 @@ subroutine determine_time_inc( dtwrite_sec, & ! Since GrADs can't handle a time increment of less than a minute we assume ! 1 minute output for an output frequency of less than a minute. - dtwrite_min = real( floor( dtwrite_sec/sec_per_min ), kind=time_precision ) - dtwrite_min = max( 1._time_precision, dtwrite_min ) + dtwrite_min = real( floor( dtwrite_sec/sec_per_min ), kind=core_rknd ) + dtwrite_min = max( 1._core_rknd, dtwrite_min ) - if ( dtwrite_min <= 99._time_precision ) then + if ( dtwrite_min <= 99._core_rknd ) then dtwrite_ctl = int( dtwrite_min ) units = 'mn' else dtwrite_hrs = dtwrite_sec / sec_per_hr - if ( dtwrite_hrs <= 99._time_precision ) then + if ( dtwrite_hrs <= 99._core_rknd ) then dtwrite_ctl = int( dtwrite_hrs ) units = 'hr' else dtwrite_days = dtwrite_sec / sec_per_day - if ( dtwrite_days <= 99._time_precision ) then + if ( dtwrite_days <= 99._core_rknd ) then dtwrite_ctl = int( dtwrite_days ) units = 'dy' else diff --git a/models/atm/cam/src/physics/clubb/output_netcdf.F90 b/models/atm/cam/src/physics/clubb/output_netcdf.F90 index dab33c0a9592..fc48e4b24215 100644 --- a/models/atm/cam/src/physics/clubb/output_netcdf.F90 +++ b/models/atm/cam/src/physics/clubb/output_netcdf.F90 @@ -1,5 +1,6 @@ -! $Id: output_netcdf.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -!------------------------------------------------------------------------------- +!----------------------------------------------------------------------- +! $Id: output_netcdf.F90 7169 2014-08-05 21:42:25Z dschanen@uwm.edu $ +!=============================================================================== module output_netcdf #ifdef NETCDF @@ -20,7 +21,7 @@ module output_netcdf ! This will truncate all timesteps smaller than 1 mn to a minute for ! the purposes of viewing the data in grads logical, parameter, private :: & - l_grads_kludge = .true. + l_grads_netcdf_boost_ts = .false. private ! Default scope @@ -50,7 +51,11 @@ subroutine open_netcdf( nlat, nlon, fdir, fname, ia, iz, zgrid, & core_rknd use constants_clubb, only: & - fstderr ! Variable(s) + fstderr, & ! Variable(s) + sec_per_min + + use stats_variables, only: & + l_allow_small_stats_tout implicit none @@ -71,10 +76,10 @@ subroutine open_netcdf( nlat, nlon, fdir, fname, ia, iz, zgrid, & real( kind = core_rknd ), dimension(nlon), intent(in) :: & rlon ! Longitudes [degrees_N] - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dtwrite ! Time between write intervals [s] - real(kind=time_precision), intent(in) :: & + real( kind = time_precision ), intent(in) :: & time ! Current time [s] real( kind = core_rknd ), dimension(:), intent(in) :: & @@ -113,6 +118,20 @@ subroutine open_netcdf( nlat, nlon, fdir, fname, ia, iz, zgrid, & ncf%dtwrite = dtwrite + ! Check to make sure the timestep is appropriate. The GrADS program does not support an + ! output timestep less than 1 minute. Other programs can read netCDF files like this + if ( dtwrite < sec_per_min ) then + write(fstderr,*) "Warning: GrADS program requires an output timestep of at least & + &one minute, but the requested output timestep & + &(stats_tout) is less than one minute." + if ( .not. l_allow_small_stats_tout ) then + write(fstderr,*) "To override this warning, set l_allow_small_stats_tout = & + &.true. in the stats_setting namelist in the & + &appropriate *_model.in file." + stop "Fatal error in open_netcdf" + end if + end if ! dtwrite < sec_per_min + ! From open_grads. ! This probably for the case of a reversed grid as in COAMPS if ( ia <= iz ) then @@ -138,7 +157,7 @@ subroutine open_netcdf( nlat, nlon, fdir, fname, ia, iz, zgrid, & write(unit=fstderr,fmt=*) "Error opening file: ", & trim( fdir )//trim( fname )//'.nc', & trim( nf90_strerror( stat ) ) - stop + stop "Fatal Error" end if call define_netcdf( ncf%iounit, ncf%nlat, ncf%nlon, ncf%iz, & ! In @@ -202,11 +221,13 @@ subroutine write_netcdf( ncf ) end if allocate( stat( ncf%nvar ) ) - if ( l_grads_kludge ) then - time = real( nint( real( ncf%ntimes, kind=time_precision ) & - * ncf%dtwrite / sec_per_min ), kind=time_precision ) ! minutes(rounded) + if ( l_grads_netcdf_boost_ts ) then + time = real( nint( real(ncf%ntimes, kind=time_precision) & + * real(ncf%dtwrite / sec_per_min, time_precision) ), & + kind=time_precision ) ! minutes(rounded) else - time = real( ncf%ntimes, kind=time_precision ) * ncf%dtwrite ! seconds + time = real( ncf%ntimes, kind=time_precision ) & + * real( ncf%dtwrite, kind=time_precision ) ! seconds end if stat(1) = nf90_put_var( ncid=ncf%iounit, varid=ncf%TimeVarId, & @@ -338,7 +359,7 @@ subroutine define_netcdf( ncid, nlat, nlon, iz, & stat = nf90_def_var( ncid, "latitude", NF90_FLOAT, & (/LatDimId/), LatVarId ) - ! Altitude = meters above the surfac3 = Z + ! Altitude = meters above the surface = Z stat = nf90_def_var( ncid, "altitude", NF90_FLOAT, & (/AltDimId/), AltVarId ) @@ -443,7 +464,7 @@ subroutine close_netcdf( ncf ) if ( stat /= NF90_NOERR ) then write(fstderr,*) "Error closing file "// & trim( ncf%fname )//": ", trim( nf90_strerror( stat ) ) - stop + stop "Fatal error" end if return @@ -461,7 +482,8 @@ subroutine first_write( ncf ) use netcdf, only: & NF90_NOERR, & ! Constants - NF90_FLOAT, & + NF90_FLOAT, & + NF90_DOUBLE, & NF90_GLOBAL, & nf90_def_var, & ! Procedure(s) nf90_strerror, & @@ -498,24 +520,30 @@ subroutine first_write( ncf ) l_uv_nudge, & l_tke_aniso - use parameters_microphys, only: & - micro_scheme, & ! Variable(s) - l_local_kk, & ! Logicals - l_cloud_sed - - use parameters_radiation, only: & - rad_scheme - use clubb_precision, only: & core_rknd ! Variable(s) implicit none + ! External + intrinsic :: date_and_time, huge, selected_real_kind, size, any, trim + + ! Enabling l_output_file_run_date allows the date and time that the netCDF + ! output file is created to be included in the netCDF output file. + ! Disabling l_output_file_run_date means that this information will not be + ! included in the netCDF output file. The advantage of disabling this + ! output is that it allows for a check for binary differences between two + ! netCDF output files. + logical, parameter :: & + l_output_file_run_date = .false. + ! Input/Output Variables type (stat_file), intent(inout) :: ncf ! Local Variables integer, dimension(:), allocatable :: stat + + integer :: netcdf_precision ! Level of precision for netCDF output real( kind = core_rknd ), dimension(nparams) :: params ! Tunable parameters @@ -530,6 +558,7 @@ subroutine first_write( ncf ) ! Dimensions for variables integer, dimension(4) :: var_dim + !------------------------------------------------------------------------------- ! Typical valid ranges (IEEE 754) @@ -539,6 +568,9 @@ subroutine first_write( ncf ) ! We use a 4 byte data model for NetCDF and GrADS to save disk space !------------------------------------------------------------------------------- + + ! ---- Begin Code ---- + var_range(1) = -huge( var_range(1) ) var_range(2) = huge( var_range(2) ) @@ -559,12 +591,22 @@ subroutine first_write( ncf ) l_error = .false. + + select case (core_rknd) + case ( selected_real_kind( p=5 ) ) + netcdf_precision = NF90_FLOAT + case ( selected_real_kind( p=12 ) ) + netcdf_precision = NF90_DOUBLE + case default + netcdf_precision = NF90_DOUBLE + end select + do i = 1, ncf%nvar, 1 ! stat(i) = nf90_def_var( ncf%iounit, trim( ncf%var(i)%name ), & ! NF90_FLOAT, (/ncf%TimeDimId, ncf%AltDimId, & ! ncf%LatDimId, ncf%LongDimId/), ncf%var(i)%indx ) stat(i) = nf90_def_var( ncf%iounit, trim( ncf%var(i)%name ), & - NF90_FLOAT, var_dim(:), ncf%var(i)%indx ) + netcdf_precision, var_dim(:), ncf%var(i)%indx ) if ( stat(i) /= NF90_NOERR ) then write(fstderr,*) "Error defining variable ", & ncf%var(i)%name //": ", trim( nf90_strerror( stat(i) ) ) @@ -596,31 +638,39 @@ subroutine first_write( ncf ) end if end do - if ( l_error ) stop "Error in definition" + if ( l_error ) stop "Error in netCDF file definition." deallocate( stat ) - allocate( stat(5) ) + if ( l_output_file_run_date ) then + allocate( stat(3) ) + else + allocate( stat(2) ) + end if ! Define global attributes of the file, for reproducing the results and ! determining how a run was configured stat(1) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "Conventions", "COARDS" ) stat(2) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "model", "CLUBB" ) - ! Figure out when the model is producing this file - call date_and_time( current_date, current_time ) + if ( l_output_file_run_date ) then + + ! Enabling l_output_file_run_date allows the date and time that the + ! netCDF output file is created to be included in the netCDF output file. + ! Disabling l_output_file_run_date means that this information will not + ! be included in the netCDF output file. The advantage of disabling this + ! output is that it allows for a check for binary differences between two + ! netCDF output files. - stat(3) = nf90_put_att( & - ncf%iounit, NF90_GLOBAL, "created_on", & - current_date(1:4)//'-'//current_date(5:6)//'-'// & - current_date(7:8)//' '// & - current_time(1:2)//':'//current_time(3:4) ) + ! Figure out when the model is producing this file + call date_and_time( current_date, current_time ) - stat(4) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "micro_scheme", & - trim( micro_scheme ) ) + stat(3) = nf90_put_att(ncf%iounit, NF90_GLOBAL, "created_on", & + current_date(1:4)//'-'//current_date(5:6)//'-'// & + current_date(7:8)//' '// & + current_time(1:2)//':'//current_time(3:4) ) - stat(5) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "rad_scheme", & - trim( rad_scheme ) ) + end if ! l_output_file_run_date if ( any( stat /= NF90_NOERR ) ) then write(fstderr,*) "Error writing model information" @@ -632,21 +682,19 @@ subroutine first_write( ncf ) ! Write the model flags to the file deallocate( stat ) - allocate( stat(10) ) ! # of model flags + allocate( stat(8) ) ! # of model flags - stat(1) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_local_kk", lchar( l_local_kk ) ) - stat(2) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_pos_def", lchar( l_pos_def ) ) - stat(3) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_hole_fill", lchar( l_hole_fill ) ) - stat(4) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_clip_semi_implicit", & + stat(1) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_pos_def", lchar( l_pos_def ) ) + stat(2) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_hole_fill", lchar( l_hole_fill ) ) + stat(3) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_clip_semi_implicit", & lchar( l_clip_semi_implicit ) ) - stat(5) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_standard_term_ta", & + stat(4) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_standard_term_ta", & lchar( l_standard_term_ta ) ) - stat(6) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_single_C2_Skw", & + stat(5) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_single_C2_Skw", & lchar( l_single_C2_Skw ) ) - stat(7) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_gamma_Skw", lchar( l_gamma_Skw ) ) - stat(8) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_cloud_sed", lchar( l_cloud_sed ) ) - stat(9) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_uv_nudge", lchar( l_uv_nudge ) ) - stat(10) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_tke_aniso", lchar( l_tke_aniso ) ) + stat(6) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_gamma_Skw", lchar( l_gamma_Skw ) ) + stat(7) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_uv_nudge", lchar( l_uv_nudge ) ) + stat(8) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_tke_aniso", lchar( l_tke_aniso ) ) if ( any( stat /= NF90_NOERR ) ) then write(fstderr,*) "Error writing model flags" @@ -793,7 +841,7 @@ subroutine format_date & iyear, & st_time ) - if ( .not. l_grads_kludge ) then + if ( .not. l_grads_netcdf_boost_ts ) then date = "seconds since YYYY-MM-DD HH:MM:00.0" else date = "minutes since YYYY-MM-DD HH:MM:00.0" @@ -810,7 +858,7 @@ end subroutine format_date !=============================================================================== character function lchar( l_input ) ! Description: -! Cast a logical to a character data type +! Cast a logical to a character data type. ! ! References: ! None @@ -818,6 +866,7 @@ character function lchar( l_input ) implicit none + ! Input Variable logical, intent(in) :: l_input ! ---- Begin Code ---- diff --git a/models/atm/cam/src/physics/clubb/parameter_indices.F90 b/models/atm/cam/src/physics/clubb/parameter_indices.F90 index 808a26abd7cf..e15f966cbc9a 100644 --- a/models/atm/cam/src/physics/clubb/parameter_indices.F90 +++ b/models/atm/cam/src/physics/clubb/parameter_indices.F90 @@ -1,5 +1,6 @@ !------------------------------------------------------------------------------- -! $Id: parameter_indices.F90 5560 2011-12-14 23:37:49Z vondeyle@uwm.edu $ +! $Id: parameter_indices.F90 7361 2014-11-04 21:51:02Z bmg2@uwm.edu $ +!=============================================================================== module parameter_indices ! Description: @@ -25,7 +26,7 @@ module parameter_indices private ! Default Scope integer, parameter, public :: & - nparams = 59 ! Total tunable parameters + nparams = 67 ! Total tunable parameters !*************************************************************** ! ***** IMPORTANT ***** @@ -86,21 +87,29 @@ module parameter_indices ic_K9 = 44, & inu9 = 45, & inu10 = 46, & - ic_Krrainm = 47, & - inu_r = 48, & - inu_hd = 49 + ic_K_hm = 47, & + ic_K_hmb = 48, & + iK_hm_min_coef = 49, & + inu_hm = 50 integer, parameter, public :: & - igamma_coef = 50, & - igamma_coefb = 51, & - igamma_coefc = 52, & - imu = 53, & - ibeta = 54, & - ilmin_coef = 55, & - itaumin = 56, & - itaumax = 57, & - iLscale_mu_coef = 58, & - iLscale_pert_coef = 59 + igamma_coef = 51, & + igamma_coefb = 52, & + igamma_coefc = 53, & + imu = 54, & + ibeta = 55, & + ilmin_coef = 56, & + icoef_hm_1_hm_2_corr_adj = 57, & + imult_coef = 58, & + itaumin = 59, & + itaumax = 60, & + iLscale_mu_coef = 61, & + iLscale_pert_coef = 62, & + ialpha_corr = 63, & + iSkw_denom_coef = 64, & + ic_K10 = 65, & + ithlp2_rad_coef = 66, & + ithlp2_rad_cloud_frac_thresh = 67 end module parameter_indices !----------------------------------------------------------------------- diff --git a/models/atm/cam/src/physics/clubb/parameters_microphys.F90 b/models/atm/cam/src/physics/clubb/parameters_microphys.F90 deleted file mode 100644 index 67294fe84f9a..000000000000 --- a/models/atm/cam/src/physics/clubb/parameters_microphys.F90 +++ /dev/null @@ -1,183 +0,0 @@ -!------------------------------------------------------------------------------- -! $Id: parameters_microphys.F90 5652 2012-01-22 02:20:55Z bmg2@uwm.edu $ -module parameters_microphys - -! Description: -! Parameters for microphysical schemes - -! References: -! None -!------------------------------------------------------------------------------- - use clubb_precision, only: & - time_precision, & - core_rknd - - implicit none - - ! Constant Parameters - integer, parameter, public :: & - LH_microphys_interactive = 1, & ! Feed the samples into the microphysics and allow feedback - LH_microphys_non_interactive = 2, & ! Feed the samples into the microphysics with no feedback - LH_microphys_disabled = 3 ! Disable latin hypercube entirely - - ! Morrison aerosol parameters - integer, parameter, public :: & - morrison_no_aerosol = 0, & - morrison_power_law = 1, & - morrison_lognormal = 2 - - ! Local Variables - logical, public :: & - l_cloud_sed, & ! Cloud water sedimentation (K&K/No microphysics) - l_ice_micro, & ! Compute ice (COAMPS/Morrison) - l_upwind_diff_sed, & ! Use the upwind differencing approximation for sedimentation (K&K/COAMPS) - l_graupel, & ! Compute graupel (COAMPS/Morrison) - l_hail, & ! Assumption about graupel/hail? (Morrison) - l_seifert_beheng, & ! Use Seifert and Behneng warm drizzle (Morrison) - l_predictnc, & ! Predict cloud droplet number conc (Morrison) - l_subgrid_w, & ! Use subgrid w (Morrison) - l_arctic_nucl, & ! Use MPACE observations (Morrison) - l_fix_pgam, & ! Fix pgam (Morrison) - l_in_cloud_Nc_diff ! Use in cloud values of Nc for diffusion - -!$omp threadprivate(l_cloud_sed, l_ice_micro, l_graupel, l_hail, l_upwind_diff_sed, & -!$omp l_seifert_beheng, l_predictnc, l_subgrid_w, & -!$omp l_arctic_nucl, l_fix_pgam, l_in_cloud_Nc_diff) - - logical, public :: & - l_cloud_edge_activation, & ! Activate on cloud edges (Morrison) - l_local_kk ! Local drizzle for Khairoutdinov & Kogan microphysics - -!$omp threadprivate(l_cloud_edge_activation, l_local_kk) - - character(len=30), public :: & - specify_aerosol ! Specify aerosol (Morrison) -!$omp threadprivate(specify_aerosol) - - ! Flags for the Latin Hypercube sampling code - logical, public :: & - l_fix_s_t_correlations, & ! Use a fixed correlation for s and t Mellor - l_lh_cloud_weighted_sampling, & ! Limit noise by sampling in-cloud - l_lh_vert_overlap ! Assume maximum overlap for s_mellor - -!$omp threadprivate(l_fix_s_t_correlations, l_lh_cloud_weighted_sampling, & -!$omp l_lh_vert_overlap) - - integer, public :: & - LH_microphys_calls, & ! Number of latin hypercube samples to call the microphysics with - LH_sequence_length ! Number of timesteps before the latin hypercube seq. repeats -!$omp threadprivate(LH_microphys_calls,LH_sequence_length) - - ! Determines how the latin hypercube samples should be used with the microphysics - integer, public :: & - LH_microphys_type - -!$omp threadprivate(LH_microphys_type) - - character(len=50), public :: & - micro_scheme ! khairoutdinv_kogan, simplified_ice, coamps, etc. - -!$omp threadprivate(micro_scheme) - - character(len=10), dimension(:), allocatable, public :: & - hydromet_list - -!$omp threadprivate(hydromet_list) - - real(kind=time_precision), public :: & - microphys_start_time ! When to start the microphysics [s] - -!$omp threadprivate(microphys_start_time) - - real( kind = core_rknd ), public :: & - Ncm_initial ! Initial cloud droplet number concentration [#/cc] - -!$omp threadprivate(Ncm_initial) - - ! Statistical rain parameters . - - ! Parameters for in-cloud (from SAM RF02 DO). - real( kind = core_rknd ), public :: & ! RF02 value - rrp2_on_rrainm2_cloud, & ! 0.766 - Nrp2_on_Nrm2_cloud, & ! 0.429 - Ncp2_on_Ncm2_cloud, & ! 0.003 - corr_rrNr_LL_cloud, & ! 0.786 - corr_srr_NL_cloud, & ! 0.242 - corr_sNr_NL_cloud, & ! 0.285 - corr_sNc_NL_cloud ! 0.433 - -!$omp threadprivate( rrp2_on_rrainm2_cloud, Nrp2_on_Nrm2_cloud, Ncp2_on_Ncm2_cloud, & -!$omp corr_rrNr_LL_cloud, corr_srr_NL_cloud, corr_sNr_NL_cloud, corr_sNc_NL_cloud ) - - ! Parameters for below-cloud (from SAM RF02 DO). - real( kind = core_rknd ), public :: & ! RF02 value - rrp2_on_rrainm2_below, & ! 8.97 - Nrp2_on_Nrm2_below, & ! 12.03 - Ncp2_on_Ncm2_below, & ! 0.00 ! Not applicable below cloud. - corr_rrNr_LL_below, & ! 0.886 - corr_srr_NL_below, & ! 0.056 - corr_sNr_NL_below, & ! 0.015 - corr_sNc_NL_below ! 0.00 ! Not applicable below cloud. - -!$omp threadprivate( rrp2_on_rrainm2_below, Nrp2_on_Nrm2_below, Ncp2_on_Ncm2_below, & -!$omp corr_rrNr_LL_below, corr_srr_NL_below, corr_sNr_NL_below, corr_sNc_NL_below ) - - ! Other needed parameters - real( kind = core_rknd ), public :: C_evap ! 0.86 ! Khairoutdinov and Kogan (2000) ratio of - ! drizzle drop mean geometric radius to - ! drizzle drop mean volume radius. - ! Khairoutdinov and Kogan (2000); p. 233. - !real, public :: C_evap = 0.86*0.2 ! COAMPS value of KK C_evap - !real, public :: C_evap = 0.55 ! KK 2000, Marshall-Palmer (1948) value. - - real( kind = core_rknd ), public :: r_0 ! 25.0e-6 ! Assumed radius of all new drops; m. - ! Value specified in KK (2000); p. 235. - ! Vince Larson set r_0=28mum to agree with COAMPS-LES formula. 15 April 2005 - !REAL, PARAMETER:: r_0 = 28.0e-6 ! Assumed radius of all new drops; m. - ! ! Value that COAMPS LES has in it. - !REAL, PARAMETER:: r_0 = 30.0e-6 ! Assumed radius of all new drops; m. - ! ! Khairoutdinov said it was okay! - ! End Vince Larson's change. - -!$omp threadprivate( C_evap, r_0 ) - - ! Values of exponents in KK microphysics - real( kind = core_rknd ), public :: & - KK_evap_Supersat_exp, & ! Exponent on Supersaturation (S) in KK evap. eq.; 1 - KK_evap_rr_exp, & ! Exponent on r_r in KK evaporation eq.; 1/3 - KK_evap_Nr_exp, & ! Exponent on N_r in KK evaporation eq.; 2/3 - KK_auto_rc_exp, & ! Exponent on r_c in KK autoconversion eq.; 2.47 - KK_auto_Nc_exp, & ! Exponent on N_c in KK autoconversion eq.; -1.79 - KK_accr_rc_exp, & ! Exponent on r_c in KK accretion eq.; 1.15 - KK_accr_rr_exp, & ! Exponent on r_r in KK accretion eq.; 1.15 - KK_mvr_rr_exp, & ! Exponent on r_r in KK mean volume radius eq.; 1/3 - KK_mvr_Nr_exp ! Exponent on N_r in KK mean volume radius eq.; -1/3 - -!$omp threadprivate( KK_evap_Supersat_exp, KK_evap_rr_exp, KK_evap_Nr_exp) -!$omp threadprivate( KK_auto_rc_exp, KK_auto_Nc_exp, KK_accr_rc_exp, KK_accr_rr_exp) -!$omp threadprivate( KK_mvr_rr_exp, KK_mvr_Nr_exp) - - ! Parameters added for ice microphysics and latin hypercube sampling - - real( kind = core_rknd ), public :: & - rsnowp2_on_rsnowm2_cloud, & - Nsnowp2_on_Nsnowm2_cloud, & - ricep2_on_ricem2_cloud, & - Nicep2_on_Nicem2_cloud - -!$omp threadprivate( rsnowp2_on_rsnowm2_cloud, Nsnowp2_on_Nsnowm2_cloud, & -!$omp ricep2_on_ricem2_cloud, Nicep2_on_Nicem2_cloud ) - - real( kind = core_rknd ), public :: & - rsnowp2_on_rsnowm2_below, & - Nsnowp2_on_Nsnowm2_below, & - ricep2_on_ricem2_below, & - Nicep2_on_Nicem2_below - -!$omp threadprivate( rsnowp2_on_rsnowm2_below, Nsnowp2_on_Nsnowm2_below, & -!$omp ricep2_on_ricem2_below, Nicep2_on_Nicem2_below ) - - private ! Default Scope - - -end module parameters_microphys diff --git a/models/atm/cam/src/physics/clubb/parameters_model.F90 b/models/atm/cam/src/physics/clubb/parameters_model.F90 index 67d7a41da4f8..4ae9254936f3 100644 --- a/models/atm/cam/src/physics/clubb/parameters_model.F90 +++ b/models/atm/cam/src/physics/clubb/parameters_model.F90 @@ -1,5 +1,5 @@ !------------------------------------------------------------------------------- -! $Id: parameters_model.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +! $Id: parameters_model.F90 7226 2014-08-19 15:52:41Z betlej@uwm.edu $ !=============================================================================== module parameters_model @@ -18,13 +18,6 @@ module parameters_model private ! Default scope - ! Maximum allowable value for Lscale [m]. - ! Value depends on whether the model is run by itself or as part of a - ! host model. - real( kind = core_rknd ), public :: Lscale_max - -!$omp threadprivate(Lscale_max) - ! Maximum magnitude of PDF parameter 'mixt_frac'. real( kind = core_rknd ), public :: mixt_frac_max_mag @@ -32,8 +25,8 @@ module parameters_model ! Model parameters and constraints setup in the namelists real( kind = core_rknd ), public :: & - T0, & ! Reference temperature (usually 300) [K] - ts_nudge ! Timescale of u/v nudging [s] + T0 = 300._core_rknd, & ! Reference temperature (usually 300) [K] + ts_nudge = 0._core_rknd ! Timescale of u/v nudging [s] #ifdef GFDL real( kind = core_rknd ), public :: & ! h1g, 2010-06-15 @@ -43,10 +36,16 @@ module parameters_model !$omp threadprivate(T0, ts_nudge) + + real( kind = core_rknd), public :: & + rtm_min = epsilon( rtm_min ), & ! Value below which rtm will be nudged [kg/kg] + rtm_nudge_max_altitude = 10000._core_rknd ! Highest altitude at which to nudge rtm [m] +!$omp threadprivate(rtm_min, rtm_nudge_max_altitude) + integer, public :: & - sclr_dim, & ! Number of passive scalars - edsclr_dim, & ! Number of eddy-diff. passive scalars - hydromet_dim ! Number of hydrometeor species + sclr_dim = 0, & ! Number of passive scalars + edsclr_dim = 0, & ! Number of eddy-diff. passive scalars + hydromet_dim = 0 ! Number of hydrometeor species !$omp threadprivate(sclr_dim, edsclr_dim, hydromet_dim) @@ -67,9 +66,7 @@ module parameters_model subroutine setup_parameters_model & ( T0_in, ts_nudge_in, & hydromet_dim_in, & - sclr_dim_in, sclr_tol_in, edsclr_dim_in, & - Lscale_max_in & - + sclr_dim_in, sclr_tol_in, edsclr_dim_in & #ifdef GFDL , cloud_frac_min_in & ! hlg, 2010-6-15 #endif @@ -98,8 +95,7 @@ subroutine setup_parameters_model & ! Input Variables real( kind = core_rknd ), intent(in) :: & T0_in, & ! Ref. temperature [K] - ts_nudge_in, & ! Timescale for u/v nudging [s] - Lscale_max_in ! Largest value for Lscale [m] + ts_nudge_in ! Timescale for u/v nudging [s] #ifdef GFDL real( kind = core_rknd ), intent(in) :: cloud_frac_min_in ! h1g, 2010-06-15 @@ -124,8 +120,6 @@ subroutine setup_parameters_model & sqrt( 4.0_core_rknd * ( 1.0_core_rknd - 0.4_core_rknd )**3 & + Skw_max_mag_sqd ) ) ) ! Known magic number - Lscale_max = Lscale_max_in - T0 = T0_in ts_nudge = ts_nudge_in diff --git a/models/atm/cam/src/physics/clubb/parameters_radiation.F90 b/models/atm/cam/src/physics/clubb/parameters_radiation.F90 deleted file mode 100644 index aab0ba472e8d..000000000000 --- a/models/atm/cam/src/physics/clubb/parameters_radiation.F90 +++ /dev/null @@ -1,79 +0,0 @@ -!------------------------------------------------------------------------------- -! $Id: parameters_radiation.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -module parameters_radiation - -! Description: -! Parameters for radiation schemes - -! References: -! None -!------------------------------------------------------------------------------- - - use clubb_precision, only: & - dp, & ! double precision - core_rknd - - implicit none - - character(len=20), public :: & - rad_scheme ! Either BUGSrad, simplified, or simplied_bomex - - real( kind = dp ), dimension(1), public :: & - sol_const ! Solar constant - - real( kind = core_rknd ), public :: & - radiation_top ! The top of the atmosphere fed into a radiation scheme. - ! The computational grid should be extended to reach this - ! altitude. - - ! Albedo values (alvdr is used in the simplifed schemes as well) - real( kind = dp ), public :: & - alvdr, & !Visible direct surface albedo [-] - alndr, & !Near-IR direct surface albedo [-] - alvdf, & !Visible diffuse surface albedo [-] - alndf !Near-IR diffuse surface albedo [-] - - - ! Long-wave constants (simplified radiation) - real( kind = core_rknd ), public :: & - kappa, & ! A constant (Duynkerke eqn. 5) [m^2/kg] - F0, & ! Coefficient for cloud top heating (see Stevens) [W/m^2] - F1 ! Coefficient for cloud base heating (see Stevens)[W/m^2] - - ! Short-wave constants - real( kind = core_rknd ), public :: & - eff_drop_radius, & ! Effective droplet radius [m] - gc, & ! Asymmetry parameter, "g" in Duynkerke [-] - omega ! Single-scattering albedo [-] - - real( kind = dp ), public :: & - slr ! Fraction of daylight -!$omp threadprivate(slr) - - real( kind = core_rknd ), public, dimension(20) :: & - Fs_values, & ! List of Fs0 values for simplified radiation - cos_solar_zen_times, & ! List of cosine of the solar zenith angle times - cos_solar_zen_values ! List of cosine of the solar zenith angle values - - logical, public :: & - l_fix_cos_solar_zen, l_sw_radiation - - logical, public :: & - l_rad_above_cloud ! Use DYCOMS II RF02 heaviside step function - - integer, public :: & - nparam - - ! Flag to signal the use of the U.S. Standard Atmosphere Profile, 1976 - logical, public :: l_use_default_std_atmosphere - - private ! Default Scope - -! OpenMP directives. The first column of these cannot be indented. -!$omp threadprivate(rad_scheme, sol_const, alvdr, alvdf, alndr, alndf, & -!$omp kappa, F0, F1, eff_drop_radius, gc, omega, radiation_top, Fs_values, & -!$omp l_rad_above_cloud, cos_solar_zen_times, cos_solar_zen_values, & -!$omp l_fix_cos_solar_zen, nparam, & -!$omp l_sw_radiation, l_use_default_std_atmosphere) - -end module parameters_radiation diff --git a/models/atm/cam/src/physics/clubb/parameters_tunable.F90 b/models/atm/cam/src/physics/clubb/parameters_tunable.F90 index 50fe233f5d8d..487909bf560d 100644 --- a/models/atm/cam/src/physics/clubb/parameters_tunable.F90 +++ b/models/atm/cam/src/physics/clubb/parameters_tunable.F90 @@ -1,5 +1,5 @@ !----------------------------------------------------------------------- -! $Id: parameters_tunable.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +! $Id: parameters_tunable.F90 7416 2014-12-04 20:16:51Z schemena@uwm.edu $ !=============================================================================== module parameters_tunable @@ -15,6 +15,11 @@ module parameters_tunable ! ! References: ! None + ! + ! Notes: + ! To make it easier to verify of code correctness, please keep the omp threadprivate + ! directives just after the variable declaration. All parameters in this + ! module should be declared threadprivate because of the CLUBB tuner. !----------------------------------------------------------------------- use parameter_indices, only: nparams ! Variable(s) @@ -34,111 +39,164 @@ module parameters_tunable ! Model constant parameters real( kind = core_rknd ), public :: & - C1 = 2.500000_core_rknd, & ! Low Skewness in C1 Skewness Function. - C1b = 2.500000_core_rknd, & ! High Skewness in C1 Skewness Function. - C1c = 1.000000_core_rknd, & ! Degree of Slope of C1 Skewness Function. - C2 = 1.300000_core_rknd, & ! Low Skewness in C2 Skewness Function. - C2rt = 1.000000_core_rknd, & ! C2 coefficient for the rtp2_dp1 term. - C2thl = 1.000000_core_rknd, & ! C2 coefficient for the thlp2_dp1 term. - C2rtthl = 2.000000_core_rknd, & ! C2 coefficient for the rtpthlp_dp1 term. - C2b = 1.300000_core_rknd, & ! High Skewness in C2 Skewness Function. - C2c = 5.000000_core_rknd, & ! Degree of Slope of C2 Skewness Function. - C4 = 5.200000_core_rknd, & ! Used only when l_tke_aniso is true. - C5 = 0.300000_core_rknd, & ! Coefficient in pressure terms in the w'^2 eqn. - C6rt = 4.000000_core_rknd, & ! Low Skewness in C6rt Skewness Function. - C6rtb = 6.000000_core_rknd, & ! High Skewness in C6rt Skewness Function. - C6rtc = 1.000000_core_rknd, & ! Degree of Slope of C6rt Skewness Function. - C6thl = 4.000000_core_rknd, & ! Low Skewness in C6thl Skewness Function. - C6thlb = 6.000000_core_rknd, & ! High Skewness in C6thl Skewness Function. - C6thlc = 1.000000_core_rknd, & ! Degree of Slope of C6thl Skewness Function. - C7 = 0.500000_core_rknd, & ! Low Skewness in C7 Skewness Function. - C7b = 0.800000_core_rknd, & ! High Skewness in C7 Skewness Function. - C7c = 0.500000_core_rknd, & ! Degree of Slope of C7 Skewness Function. - C8 = 3.000000_core_rknd, & ! Coefficient #1 in C8 Skewness Equation. - C8b = 0.000000_core_rknd, & ! Coefficient #2 in C8 Skewness Equation. - C10 = 3.300000_core_rknd, & ! Currently Not Used in the Model. - C11 = 0.80000_core_rknd, & ! Low Skewness in C11 Skewness Function. - C11b = 0.350000_core_rknd, & ! High Skewness in C11 Skewness Function. - C11c = 0.500000_core_rknd, & ! Degree of Slope of C11 Skewness Function. - C12 = 1.000000_core_rknd, & ! Constant in w'^3 Crank-Nicholson diffusional term. - C13 = 0.100000_core_rknd, & ! Not currently used in model. - C14 = 1.000000_core_rknd, & ! Constant for u'^2 and v'^2 terms. - C15 = 0.4_core_rknd ! Coefficient for the wp3_bp2 term + C1 = 1.000000_core_rknd, & ! Low Skewness in C1 Skw. Function [-] + C1b = 1.000000_core_rknd, & ! High Skewness in C1 Skw. Function [-] + C1c = 1.000000_core_rknd, & ! Degree of Slope of C1 Skw. Function [-] + C2 = 1.300000_core_rknd, & ! Low Skewness in C2 Skw. Function [-] + C2rt = 1.000000_core_rknd, & ! C2 coef. for the rtp2_dp1 term [-] + C2thl = 1.000000_core_rknd, & ! C2 coef. for the thlp2_dp1 term [-] + C2rtthl = 1.300000_core_rknd, & ! C2 coef. for the rtpthlp_dp1 term [-] + C2b = 1.300000_core_rknd, & ! High Skewness in C2 Skw. Function [-] + C2c = 5.000000_core_rknd, & ! Degree of Slope of C2 Skw. Function [-] + C4 = 5.200000_core_rknd, & ! Used only when l_tke_aniso is true [-] + C5 = 0.300000_core_rknd, & ! Coef. in pressure terms: w'^2 eqn [-] + C6rt = 4.000000_core_rknd, & ! Low Skewness in C6rt Skw. Function [-] + C6rtb = 6.000000_core_rknd, & ! High Skewness in C6rt Skw. Function [-] + C6rtc = 1.000000_core_rknd, & ! Degree of Slope of C6rt Skw. Fnct. [-] + C6thl = 4.000000_core_rknd, & ! Low Skewness in C6thl Skw. Function [-] + C6thlb = 6.000000_core_rknd, & ! High Skewness in C6thl Skw. Fnct. [-] + C6thlc = 1.000000_core_rknd, & ! Degree of Slope of C6thl Skw. Fnct. [-] + C7 = 0.500000_core_rknd, & ! Low Skewness in C7 Skw. Function [-] + C7b = 0.500000_core_rknd, & ! High Skewness in C7 Skw. Function [-] + C7c = 0.500000_core_rknd, & ! Degree of Slope of C7 Skw. Function [-] + C8 = 4.200000_core_rknd, & ! Coef. #1 in C8 Skewness Equation [-] + C8b = 0.000000_core_rknd, & ! Coef. #2 in C8 Skewness Equation [-] + C10 = 3.300000_core_rknd, & ! Currently Not Used in the Model [-] +#if defined(CLUBB_CAM) && !defined(CLUBBND_CAM) + C11 = 0.70000_core_rknd, & ! Low Skewness in C11 Skw. Function [-] + C11b = 0.350000_core_rknd, & ! High Skewness in C11 Skw. Function [-] +#else + C11 = 0.80000_core_rknd, & ! Low Skewness in C11 Skw. Function [-] + C11b = 0.350000_core_rknd, & ! High Skewness in C11 Skw. Function [-] +#endif + C11c = 0.500000_core_rknd, & ! Degree of Slope of C11 Skw. Fnct. [-] + C12 = 1.000000_core_rknd, & ! Constant in w'^3 Crank-Nich. diff. [-] + C13 = 0.100000_core_rknd, & ! Not currently used in model [-] + C14 = 1.000000_core_rknd, & ! Constant for u'^2 and v'^2 terms [-] + C15 = 0.4_core_rknd ! Coefficient for the wp3_bp2 term [-] +!$omp threadprivate(C1, C1b, C1c, C2, C2b, C2c, & +!$omp C2rt, C2thl, C2rtthl, C4, C5, C6rt, C6rtb, C6rtc, & +!$omp C6thl, C6thlb, C6thlc, & +!$omp C7, C7b, C7c, C8, C8b, C10, C11, C11b, C11c, C12, & +!$omp C13, C14, C15) real( kind = core_rknd ), public :: & - C6rt_Lscale0 = 14.0_core_rknd, & ! Damp C6rt as a function of Lscale - C6thl_Lscale0 = 14.0_core_rknd, & ! Damp C6thl as a function of Lscale - C7_Lscale0 = 0.8500000_core_rknd, & ! Damp C7 as a function of Lscale - wpxp_L_thresh = 60.0_core_rknd ! Lscale threshold for damping C6 and C7 coefficients -!$omp threadprivate(C6rt_Lscale0, C6thl_Lscale0, C7_Lscale0, wpxp_L_thresh) + C6rt_Lscale0 = 14.0_core_rknd, & ! Damp C6rt as a fnct. of Lscale [-] + C6thl_Lscale0 = 14.0_core_rknd, & ! Damp C6thl as a fnct. of Lscale [-] + C7_Lscale0 = 0.8500000_core_rknd, & ! Damp C7 as a fnct. of Lscale [-] + wpxp_L_thresh = 60.0_core_rknd ! Lscale threshold: damp C6 & C7 [m] +!$omp threadprivate(C6rt_Lscale0, C6thl_Lscale0, C7_Lscale0, wpxp_L_thresh) + ! Note: DD 1987 is Duynkerke & Driedonks (1987). real( kind = core_rknd ), public :: & - c_K = 0.200000_core_rknd, & ! Constant C_mu^(1/4) in Duynkerke & Driedonks 1987. - c_K1 = 0.750000_core_rknd, & ! Coefficient of Eddy Diffusion for wp2. - c_K2 = 0.125000_core_rknd, & ! Coefficient of Eddy Diffusion for xp2. - c_K6 = 0.375000_core_rknd, & ! Coefficient of Eddy Diffusion for wpthlp and wprtp. - c_K8 = 1.250000_core_rknd, & ! Coefficient of Eddy Diffusion for wp3. - c_K9 = 0.250000_core_rknd, & ! Coefficient of Eddy Diffusion for up2 and vp2. - c_Krrainm = 0.200000_core_rknd, & ! Coefficient of Eddy Diffusion for hydrometeors. - gamma_coef = 0.320000_core_rknd, & ! Low Skewness in gamma coefficient Skewness Function. - gamma_coefb = 0.320000_core_rknd, & ! High Skewness in gamma coefficient Skewness Function. - gamma_coefc = 5.000000_core_rknd, & ! Degree of Slope of gamma coefficient Skewness Function. - mu = 1.000E-3_core_rknd, & ! Fractional entrainment rate per unit altitude. - taumin = 90.00000_core_rknd, & ! Minimum allowable value of time-scale tau. - taumax = 3600.000_core_rknd, & ! Maximum allowable value of time-scale tau. - lmin ! Minimum value for the length scale. + c_K = 0.200000_core_rknd, & ! Constant C_mu^(1/4) in DD 1987 [m^2/s] + c_K1 = 0.750000_core_rknd, & ! Coef. of Eddy Diffusion: wp2 [m^2/s] + c_K2 = 0.125000_core_rknd, & ! Coef. of Eddy Diffusion: xp2 [m^2/s] + c_K6 = 0.375000_core_rknd, & ! Coef. of Eddy Diffusion: wpxp [m^2/s] + c_K8 = 1.250000_core_rknd, & ! Coef. of Eddy Diffusion: wp3 [m^2/s] + c_K9 = 0.250000_core_rknd, & ! Coef. of Eddy Diff.: up2/vp2 [m^2/s] + c_K_hm = 0.750000_core_rknd, & ! Coef. of Eddy Diffusion: hmm [m^2/s] + c_K_hmb = 0.10000_core_rknd, & ! Coef. of Non-Local Factor, Eddy Diffusion: hmm [m^2/s] + K_hm_min_coef = 0.10000_core_rknd,& ! Min. of Non-Local Factor, Eddy Diffusion: hmm [m^2/s] + gamma_coef = 0.320000_core_rknd, & ! Low Skw.: gamma coef. Skw. Fnct. [-] + gamma_coefb = 0.320000_core_rknd, & ! High Skw.: gamma coef. Skw. Fnct. [-] + gamma_coefc = 5.000000_core_rknd, & ! Deg. Slope: gamma coef. Skw. Fnct. [-] +#ifdef CLUBBND_CAM + mu = 1.000E-3_core_rknd, & ! Fract entrain rate per unit alt [1/m] +#else + mu = 1.000E-3_core_rknd, & ! Fract entrain rate per unit alt [1/m] +#endif +#ifdef CLUBBND_CAM + mult_coef = 1.500000_core_rknd, & +#else + mult_coef = 1.000000_core_rknd, & ! Coef. applied to log(avg dz/thresh)[-] +#endif + taumin = 90.00000_core_rknd, & ! Min. allow. value: time-scale tau [s] + taumax = 3600.000_core_rknd, & ! Max. allow. value: time-scale tau [s] + lmin = 20.00000_core_rknd ! Min. value for the length scale [m] +!$omp threadprivate(c_K, c_K1, c_K2, c_K6, & +!$omp c_K8, c_K9, c_K_hm, c_K_hmb, K_hm_min_coef, gamma_coef, gamma_coefb, gamma_coefc, & +!$omp mu, mult_coef, taumin, taumax, lmin) real( kind = core_rknd ), public :: & - Lscale_mu_coef = 2.0_core_rknd, & ! Coefficient to perturb mu for an avg calculation of Lscale - Lscale_pert_coef = 0.1_core_rknd ! Coeff to perturb thlm and rtm for an avg calc of Lscale. + Lscale_mu_coef = 2.0_core_rknd, & ! Coef perturb mu: av calc Lscale [-] + Lscale_pert_coef = 0.1_core_rknd ! Coef pert thlm/rtm: av calc Lscale [-] +!$omp threadprivate(Lscale_mu_coef, Lscale_pert_coef) + + real( kind = core_rknd ), public :: & + alpha_corr = 0.15_core_rknd ! Coef. for the corr. diagnosis algorithm [-] + +!$omp threadprivate(alpha_corr) real( kind = core_rknd ), private :: & - nu1 = 20.00000_core_rknd, & ! Background Coefficient of Eddy Diffusion for wp2. - nu2 = 5.000000_core_rknd, & ! Background Coefficient of Eddy Diffusion for xp2. - nu6 = 5.000000_core_rknd, & ! Background Coefficient of Eddy Diffusion for wpxp. - nu8 = 20.00000_core_rknd, & ! Background Coefficient of Eddy Diffusion for wp3. - nu9 = 20.00000_core_rknd, & ! Background Coefficient of Eddy Diffusion for up2 and vp2. - nu10 = 0.00000_core_rknd,&! Background Coef of Eddy Dfsn for edsclrm, um, vm, upwp, vpwp - nu_r = 1.500000_core_rknd,& ! Background Coefficient of Eddy Diffusion for hydrometeors. - nu_hd = 20000.00_core_rknd ! Constant coefficient for 4th-order hyper-diffusion. - -!$omp threadprivate(C1, C1b, C1c, C2, C2b, C2c, & -!$omp C2rt, C2thl, C2rtthl, C4, C5, C6rt, C6rtb, C6rtc, & -!$omp C6thl, C6thlb, C6thlc, & -!$omp C7, C7b, C7c, C8, C8b, C10, C11, C11b, C11c, C12, & -!$omp C13, C14, C15, & -!$omp c_K, c_K1, nu1, c_K2, nu2, c_K6, nu6, & -!$omp c_K8, nu8, c_K9, nu9, nu10, c_Krrainm, nu_r, nu_hd, & -!$omp gamma_coef, gamma_coefb, gamma_coefc, & -!$omp taumin, taumax, mu, lmin, Lscale_mu_coef, Lscale_pert_coef) + nu1 = 20.00000_core_rknd, & ! Bg. Coef. Eddy Diffusion: wp2 [m^2/s] + nu2 = 5.000000_core_rknd, & ! Bg. Coef. Eddy Diffusion: xp2 [m^2/s] + nu6 = 5.000000_core_rknd, & ! Bg. Coef. Eddy Diffusion: wpxp [m^2/s] + nu8 = 20.00000_core_rknd, & ! Bg. Coef. Eddy Diffusion: wp3 [m^2/s] + nu9 = 20.00000_core_rknd, & ! Bg. Coef. Eddy Diffusion: up2/vp2 [m^2/s] + nu10 = 0.000000_core_rknd, & ! Bg. Coef. Eddy Diffusion: edsclrm [m^2/s] + nu_hm = 1.500000_core_rknd ! Bg. Coef. Eddy Diffusion: hmm [m^2/s] +!$omp threadprivate(nu1, nu2, nu6, nu8, nu9, nu10, nu_hm) - real( kind = core_rknd ), public, allocatable, dimension(:) :: & - nu1_vert_res_dep, & ! Background Coefficient of Eddy Diffusion for wp2. - nu2_vert_res_dep, & ! Background Coefficient of Eddy Diffusion for xp2. - nu6_vert_res_dep, & ! Background Coefficient of Eddy Diffusion for wpxp. - nu8_vert_res_dep, & ! Background Coefficient of Eddy Diffusion for wp3. - nu9_vert_res_dep, & ! Background Coefficient of Eddy Diffusion for up2 and vp2. - nu10_vert_res_dep, & ! Background Coef of Eddy Dfsn for edsclrm,um,vm,upwp,vpwp. - nu_r_vert_res_dep ! Background Coefficient of Eddy Diffusion for hydrometeors. - real( kind = core_rknd ), public :: & - nu_hd_vert_res_dep ! Constant coefficient for 4th-order hyper-diffusion. + real( kind = core_rknd ), public, allocatable, dimension(:) :: & + nu1_vert_res_dep, & ! Background Coef. of Eddy Diffusion: wp2 [m^2/s] + nu2_vert_res_dep, & ! Background Coef. of Eddy Diffusion: xp2 [m^2/s] + nu6_vert_res_dep, & ! Background Coef. of Eddy Diffusion: wpxp [m^2/s] + nu8_vert_res_dep, & ! Background Coef. of Eddy Diffusion: wp3 [m^2/s] + nu9_vert_res_dep, & ! Background Coef. of Eddy Diffusion: up2/vp2 [m^2/s] + nu10_vert_res_dep, & ! Background Coef. of Eddy Diffusion: edsclrm [m^2/s] + nu_hm_vert_res_dep ! Background Coef. of Eddy Diffusion: hydromet [m^2/s] !$omp threadprivate(nu1_vert_res_dep, nu2_vert_res_dep, nu6_vert_res_dep, & -!$omp nu8_vert_res_dep, nu9_vert_res_dep, nu10_vert_res_dep, nu_r_vert_res_dep, & -!$omp nu_hd_vert_res_dep ) +!$omp nu8_vert_res_dep, nu9_vert_res_dep, nu10_vert_res_dep, nu_hm_vert_res_dep) ! Vince Larson added a constant to set plume widths for theta_l and rt - ! beta should vary between 0 and 3, with 1.5 the standard value + ! beta should vary between 0 and 3. - real( kind = core_rknd ), public :: beta = 1.750000_core_rknd + real( kind = core_rknd ), public :: & + beta = 2.400000_core_rknd ! Beta coefficient [-] !$omp threadprivate(beta) - real( kind = core_rknd ), private :: lmin_coef = 0.500000_core_rknd ! Coefficient of lmin + real( kind = core_rknd ), private :: & + lmin_coef = 0.100000_core_rknd ! Coefficient of lmin [-] !$omp threadprivate(lmin_coef) + ! Coefficient for adjusted overall correlation in hm_1/hm_2 calculation [-] + real( kind = core_rknd ), public :: & + coef_hm_1_hm_2_corr_adj = 1.0_core_rknd + +!$omp threadprivate( coef_hm_1_hm_2_corr_adj ) + + ! Factor to decrease sensitivity in the denominator of Skw calculation + real( kind = core_rknd ), public :: & +#ifdef CLUBB_CAM +#ifdef CLUBBND_CAM + Skw_denom_coef = 0.0_core_rknd +#else + Skw_denom_coef = 0.0_core_rknd +#endif +#else + Skw_denom_coef = 4.0_core_rknd +#endif + +!$omp threadprivate( Skw_denom_coef ) + + ! Coefficient of Kh_zm + real( kind = core_rknd ), public :: & + c_K10 = 0.6_core_rknd + +!$omp threadprivate( c_K10 ) + + real( kind = core_rknd ), public :: & + thlp2_rad_coef = 1.0_core_rknd, & ! Coefficient of thlp2_rad [-] + thlp2_rad_cloud_frac_thresh = 0.1_core_rknd ! Minimum cloud fraction for computation + ! of thlp2_rad [-] + +!$omp threadprivate( thlp2_rad_coef, thlp2_rad_cloud_frac_thresh ) + ! used in adj_low_res_nu. If .true., avg_deltaz = deltaz #ifdef GFDL logical, public :: l_prescribed_avg_deltaz = .true. @@ -157,9 +215,11 @@ module parameters_tunable C7, C7b, C7c, C8, C8b, C10, C11, C11b, C11c, & C12, C13, C14, C15, C6rt_Lscale0, C6thl_Lscale0, & C7_Lscale0, wpxp_L_thresh, c_K, c_K1, nu1, c_K2, nu2, & - c_K6, nu6, c_K8, nu8, c_K9, nu9, nu10, c_Krrainm, nu_r, & - nu_hd, beta, gamma_coef, gamma_coefb, gamma_coefc, & - lmin_coef, taumin, taumax, mu, Lscale_mu_coef, Lscale_pert_coef + c_K6, nu6, c_K8, nu8, c_K9, nu9, nu10, c_K_hm, c_K_hmb, K_hm_min_coef, & + nu_hm, beta, gamma_coef, gamma_coefb, gamma_coefc, lmin_coef, & + coef_hm_1_hm_2_corr_adj, mult_coef, taumin, taumax, mu, Lscale_mu_coef, & + Lscale_pert_coef, alpha_corr, Skw_denom_coef, c_K10, thlp2_rad_coef, & + thlp2_rad_cloud_frac_thresh ! These are referenced together often enough that it made sense to ! make a list of them. Note that lmin_coef is the input parameter, @@ -171,25 +231,44 @@ module parameters_tunable ! tuner will break! ! ***** IMPORTANT ***** !*************************************************************** - character(len=16), dimension(nparams), parameter, public :: & + character(len=27), dimension(nparams), parameter, public :: & params_list = & - (/"C1 ", "C1b ", "C1c ", "C2 ", & - "C2b ", "C2c ", "C2rt ", "C2thl ", & - "C2rtthl ", "C4 ", "C5 ", "C6rt ", & - "C6rtb ", "C6rtc ", "C6thl ", "C6thlb ", & - "C6thlc ", "C7 ", "C7b ", "C7c ", & - "C8 ", "C8b ", "C10 ", "C11 ", & - "C11b ", "C11c ", "C12 ", "C13 ", & - "C14 ", "C15 ", "C6rt_Lscale0 ", "C6thl_Lscale0 ", & - "C7_Lscale0 ", "wpxp_L_thresh ", "c_K ", "c_K1 ", & - "nu1 ", "c_K2 ", "nu2 ", "c_K6 ", & - "nu6 ", "c_K8 ", "nu8 ", "c_K9 ", & - "nu9 ", "nu10 ", "c_Krrainm ", "nu_r ", & - "nu_hd ", "gamma_coef ", "gamma_coefb ", "gamma_coefc ", & - "mu ", "beta ", "lmin_coef ", "taumin ", & - "taumax ", "Lscale_mu_coef ", "Lscale_pert_coef" /) - - real( kind = core_rknd ), parameter :: & + (/"C1 ", "C1b ", & + "C1c ", "C2 ", & + "C2b ", "C2c ", & + "C2rt ", "C2thl ", & + "C2rtthl ", "C4 ", & + "C5 ", "C6rt ", & + "C6rtb ", "C6rtc ", & + "C6thl ", "C6thlb ", & + "C6thlc ", "C7 ", & + "C7b ", "C7c ", & + "C8 ", "C8b ", & + "C10 ", "C11 ", & + "C11b ", "C11c ", & + "C12 ", "C13 ", & + "C14 ", "C15 ", & + "C6rt_Lscale0 ", "C6thl_Lscale0 ", & + "C7_Lscale0 ", "wpxp_L_thresh ", & + "c_K ", "c_K1 ", & + "nu1 ", "c_K2 ", & + "nu2 ", "c_K6 ", & + "nu6 ", "c_K8 ", & + "nu8 ", "c_K9 ", & + "nu9 ", "nu10 ", & + "c_K_hm ", "c_K_hmb ", & + "K_hm_min_coef ", "nu_hm ", & + "gamma_coef ", "gamma_coefb ", & + "gamma_coefc ", "mu ", & + "beta ", "lmin_coef ", & + "coef_hm_1_hm_2_corr_adj ", "mult_coef ", & + "taumin ", "taumax ", & + "Lscale_mu_coef ", "Lscale_pert_coef ", & + "alpha_corr ", "Skw_denom_coef ", & + "c_K10 ", "thlp2_rad_coef ", & + "thlp2_rad_cloud_frac_thresh" /) + + real( kind = core_rknd ), parameter, private :: & init_value = -999._core_rknd ! Initial value for the parameters, used to detect missing values contains @@ -219,6 +298,11 @@ subroutine setup_parameters & implicit none + + ! Constant Parameters + real( kind = core_rknd ), parameter :: & + lmin_deltaz = 40.0_core_rknd ! Fixed value for minimum value for the length scale. + ! Input Variables real( kind = core_rknd ), intent(in) :: & deltaz ! Change per height level [m] @@ -257,10 +341,6 @@ subroutine setup_parameters & integer, intent(out) :: & err_code ! Error condition - ! Local Variables - real( kind = core_rknd ), parameter :: & - lmin_deltaz = 40.0_core_rknd ! Fixed value for minimum value for the length scale. - !-------------------- Begin code -------------------- call unpack_parameters( params, & @@ -269,11 +349,13 @@ subroutine setup_parameters & C7, C7b, C7c, C8, C8b, C10, & C11, C11b, C11c, C12, C13, C14, C15, & C6rt_Lscale0, C6thl_Lscale0, C7_Lscale0, wpxp_L_thresh, & - c_K, c_K1, nu1, c_K2, nu2, c_K6, nu6, & - c_K8, nu8, c_K9, nu9, nu10, c_Krrainm, nu_r, & - nu_hd, gamma_coef, gamma_coefb, gamma_coefc, & - mu, beta, lmin_coef, taumin, taumax, Lscale_mu_coef, & - Lscale_pert_coef ) + c_K, c_K1, nu1, c_K2, nu2, c_K6, nu6, & + c_K8, nu8, c_K9, nu9, nu10, c_K_hm, c_K_hmb, K_hm_min_coef, & + nu_hm, gamma_coef, gamma_coefb, gamma_coefc, & + mu, beta, lmin_coef, coef_hm_1_hm_2_corr_adj, mult_coef, taumin, & + taumax, Lscale_mu_coef, Lscale_pert_coef, alpha_corr, & + Skw_denom_coef, c_K10, thlp2_rad_coef, & + thlp2_rad_cloud_frac_thresh ) ! It was decided after some experimentation, that the best @@ -288,32 +370,46 @@ subroutine setup_parameters & momentum_heights, thermodynamic_heights ) ! Intent(in) ! Sanity check + ! Initialize err_code to clubb_no_error. Only overwrite it if a variable + ! out-of-bounds error is found. + err_code = clubb_no_error + if ( beta < 0.0_core_rknd .or. beta > 3.0_core_rknd ) then - ! Constraints on beta - write(fstderr,*) "beta = ", beta - write(fstderr,*) "beta cannot be < 0 or > 3" - err_code = clubb_var_out_of_bounds + ! Constraints on beta + write(fstderr,*) "beta = ", beta + write(fstderr,*) "beta cannot be < 0 or > 3" + err_code = clubb_var_out_of_bounds + + endif ! beta < 0 or beta > 3 + + if ( coef_hm_1_hm_2_corr_adj < 0.0_core_rknd & + .or. coef_hm_1_hm_2_corr_adj > 1.0_core_rknd ) then - else if ( mu < 0.0_core_rknd ) then + ! Constraints on coef_hm_1_hm_2_corr_adj + write(fstderr,*) "coef_hm_1_hm_2_corr_adj = ", coef_hm_1_hm_2_corr_adj + write(fstderr,*) "coef_hm_1_hm_2_corr_adj cannot be < 0 or > 1" + err_code = clubb_var_out_of_bounds - ! Constraints on entrainment rate, mu. - write(fstderr,*) "mu = ", mu - write(fstderr,*) "mu cannot be < 0" - err_code = clubb_var_out_of_bounds + endif ! beta < 0 or beta > 3 - else if ( lmin < 4.0_core_rknd ) then + if ( mu < 0.0_core_rknd ) then - ! Constraints on mixing length - write(fstderr,*) "lmin = ", lmin - write(fstderr,*) "lmin is < 4.0_core_rknd" - err_code = clubb_var_out_of_bounds + ! Constraints on entrainment rate, mu. + write(fstderr,*) "mu = ", mu + write(fstderr,*) "mu cannot be < 0" + err_code = clubb_var_out_of_bounds - else + endif ! mu < 0.0 - err_code = clubb_no_error + if ( lmin < 4.0_core_rknd ) then - end if ! A parameter is outside the acceptable range + ! Constraints on mixing length + write(fstderr,*) "lmin = ", lmin + write(fstderr,*) "lmin is < 4.0_core_rknd" + err_code = clubb_var_out_of_bounds + + endif ! lmin < 4.0 ! write(*,nml=initvars) ! %% debug @@ -363,8 +459,7 @@ subroutine adj_low_res_nu & ! are increased. Traditionally, the threshold grid spacing has been set to ! 40.0 meters. This is only relevant if l_adj_low_res_nu is turned on. real( kind = core_rknd ), parameter :: & - grid_spacing_thresh = 40.0_core_rknd, & ! grid spacing threshold [m] - mult_coef = 1.5_core_rknd ! Coefficient applied to log( avg dz / threshold ) + grid_spacing_thresh = 40.0_core_rknd ! grid spacing threshold [m] ! Input Variables @@ -433,8 +528,8 @@ subroutine adj_low_res_nu & if ( .not. allocated( nu10_vert_res_dep ) ) then allocate( nu10_vert_res_dep(1:gr%nz) ) end if - if ( .not. allocated( nu_r_vert_res_dep ) ) then - allocate( nu_r_vert_res_dep(1:gr%nz) ) + if ( .not. allocated( nu_hm_vert_res_dep ) ) then + allocate( nu_hm_vert_res_dep(1:gr%nz) ) end if ! Flag for adjusting the values of the constant diffusivity coefficients @@ -486,7 +581,8 @@ subroutine adj_low_res_nu & = ( thermodynamic_heights(nzmax) - thermodynamic_heights(1) ) & / real( nzmax - 1, kind = core_rknd ) else - + ! Eric Raut added to remove compiler warning. (Obviously, this value is not used) + avg_deltaz = 0.0_core_rknd write(fstderr,*) "Invalid grid_type:", grid_type stop "Fatal error" @@ -521,34 +617,23 @@ subroutine adj_low_res_nu & end if ! l_nu_grid_dependent !mult_factor = 1.0_core_rknd + mult_coef * log( avg_deltaz / grid_spacing_thresh ) - nu1_vert_res_dep = nu1 * mult_factor_zm - nu2_vert_res_dep = nu2 * mult_factor_zm - nu6_vert_res_dep = nu6 * mult_factor_zm - nu8_vert_res_dep = nu8 * mult_factor_zt - nu9_vert_res_dep = nu9 * mult_factor_zm - nu10_vert_res_dep = nu10 * mult_factor_zt !We're unsure of the grid - nu_r_vert_res_dep = nu_r * mult_factor_zt - - ! The value of nu_hd is based on an average grid box spacing of - ! 40 m. The value of nu_hd should be adjusted proportionally to - ! the average grid box size, whether the average grid box size is - ! less than 40 m. or greater than 40 m. - ! Since nu_hd should be very large for large grid boxes, but - ! substantially smaller for small grid boxes, the grid spacing - ! adjuster is squared. - - nu_hd_vert_res_dep = nu_hd * ( avg_deltaz / grid_spacing_thresh )**2 + nu1_vert_res_dep = nu1 * mult_factor_zm + nu2_vert_res_dep = nu2 * mult_factor_zm + nu6_vert_res_dep = nu6 * mult_factor_zm + nu8_vert_res_dep = nu8 * mult_factor_zt + nu9_vert_res_dep = nu9 * mult_factor_zm + nu10_vert_res_dep = nu10 * mult_factor_zt !We're unsure of the grid + nu_hm_vert_res_dep = nu_hm * mult_factor_zt else ! nu values are not adjusted - nu1_vert_res_dep = nu1 - nu2_vert_res_dep = nu2 - nu6_vert_res_dep = nu6 - nu8_vert_res_dep = nu8 - nu9_vert_res_dep = nu9 - nu10_vert_res_dep = nu10 - nu_r_vert_res_dep = nu_r - nu_hd_vert_res_dep = nu_hd + nu1_vert_res_dep = nu1 + nu2_vert_res_dep = nu2 + nu6_vert_res_dep = nu6 + nu8_vert_res_dep = nu8 + nu9_vert_res_dep = nu9 + nu10_vert_res_dep = nu10 + nu_hm_vert_res_dep = nu_hm end if ! l_adj_low_res_nu @@ -599,14 +684,16 @@ subroutine read_parameters( iunit, filename, params ) ! Put the variables in the output array call pack_parameters( C1, C1b, C1c, C2, C2b, C2c, C2rt, C2thl, C2rtthl, & C4, C5, C6rt, C6rtb, C6rtc, C6thl, C6thlb, C6thlc, & - C7, C7b, C7c, C8, C8b, C10, & - C11, C11b, C11c, C12, C13, C14, C15, & + C7, C7b, C7c, C8, C8b, C10, & + C11, C11b, C11c, C12, C13, C14, C15, & C6rt_Lscale0, C6thl_Lscale0, C7_Lscale0, wpxp_L_thresh, & - c_K, c_K1, nu1, c_K2, nu2, c_K6, nu6, & - c_K8, nu8, c_K9, nu9, nu10, c_Krrainm, nu_r, & - nu_hd, gamma_coef, gamma_coefb, gamma_coefc, & - mu, beta, lmin_coef, taumin, taumax, Lscale_mu_coef, & - Lscale_pert_coef, params ) + c_K, c_K1, nu1, c_K2, nu2, c_K6, nu6, & + c_K8, nu8, c_K9, nu9, nu10, c_K_hm, c_K_hmb, K_hm_min_coef, & + nu_hm, gamma_coef, gamma_coefb, gamma_coefc, & + mu, beta, lmin_coef, coef_hm_1_hm_2_corr_adj, mult_coef, & + taumin, taumax, Lscale_mu_coef, Lscale_pert_coef, alpha_corr, & + Skw_denom_coef, c_K10, thlp2_rad_coef, & + thlp2_rad_cloud_frac_thresh, params ) l_error = .false. @@ -672,9 +759,11 @@ subroutine read_param_spread & C7, C7b, C7c, C8, C8b, C10, C11, C11b, C11c, & C12, C13, C14, C15, C6rt_Lscale0, C6thl_Lscale0, & C7_Lscale0, wpxp_L_thresh, c_K, c_K1, nu1, c_K2, nu2, & - c_K6, nu6, c_K8, nu8, c_K9, nu9, nu10, c_Krrainm, nu_r, & - nu_hd, beta, gamma_coef, gamma_coefb, gamma_coefc, & - lmin_coef, taumin, taumax, mu, Lscale_mu_coef, Lscale_pert_coef + c_K6, nu6, c_K8, nu8, c_K9, nu9, nu10, c_K_hm, c_K_hmb, K_hm_min_coef, & + nu_hm, beta, gamma_coef, gamma_coefb, gamma_coefc, & + lmin_coef, coef_hm_1_hm_2_corr_adj, mult_coef, taumin, taumax, mu, & + Lscale_mu_coef, Lscale_pert_coef, alpha_corr, Skw_denom_coef, c_K10, & + thlp2_rad_coef, thlp2_rad_cloud_frac_thresh ! Initialize values to -999. call init_parameters_999( ) @@ -689,14 +778,16 @@ subroutine read_param_spread & ! Put the variables in the output array call pack_parameters( C1, C1b, C1c, C2, C2b, C2c, C2rt, C2thl, C2rtthl, & C4, C5, C6rt, C6rtb, C6rtc, C6thl, C6thlb, C6thlc, & - C7, C7b, C7c, C8, C8b, C10, & - C11, C11b, C11c, C12, C13, C14, C15, & + C7, C7b, C7c, C8, C8b, C10, & + C11, C11b, C11c, C12, C13, C14, C15, & C6rt_Lscale0, C6thl_Lscale0, C7_Lscale0, wpxp_L_thresh, & - c_K, c_K1, nu1, c_K2, nu2, c_K6, nu6, & - c_K8, nu8, c_K9, nu9, nu10, c_Krrainm, nu_r, & - nu_hd, gamma_coef, gamma_coefb, gamma_coefc, & - mu, beta, lmin_coef, taumin, taumax, Lscale_mu_coef, & - Lscale_pert_coef, param_spread ) + c_K, c_K1, nu1, c_K2, nu2, c_K6, nu6, & + c_K8, nu8, c_K9, nu9, nu10, c_K_hm, c_K_hmb, K_hm_min_coef, & + nu_hm, gamma_coef, gamma_coefb, gamma_coefc, & + mu, beta, lmin_coef, coef_hm_1_hm_2_corr_adj, mult_coef, & + taumin, taumax, Lscale_mu_coef, Lscale_pert_coef, alpha_corr, & + Skw_denom_coef, c_K10, thlp2_rad_coef, & + thlp2_rad_cloud_frac_thresh, param_spread ) l_error = .false. @@ -736,10 +827,12 @@ subroutine pack_parameters & C11, C11b, C11c, C12, C13, C14, C15, & C6rt_Lscale0, C6thl_Lscale0, C7_Lscale0, wpxp_L_thresh, & c_K, c_K1, nu1, c_K2, nu2, c_K6, nu6, & - c_K8, nu8, c_K9, nu9, nu10, c_Krrainm, nu_r, & - nu_hd, gamma_coef, gamma_coefb, gamma_coefc, & - mu, beta, lmin_coef, taumin, taumax, Lscale_mu_coef, & - Lscale_pert_coef, params ) + c_K8, nu8, c_K9, nu9, nu10, c_K_hm, c_K_hmb, K_hm_min_coef, & + nu_hm, gamma_coef, gamma_coefb, gamma_coefc, & + mu, beta, lmin_coef, coef_hm_1_hm_2_corr_adj, mult_coef, & + taumin, taumax, Lscale_mu_coef, Lscale_pert_coef, alpha_corr, & + Skw_denom_coef, c_K10, thlp2_rad_coef, & + thlp2_rad_cloud_frac_thresh, params ) ! Description: ! Takes the list of scalar variables and puts them into a 1D vector. @@ -801,19 +894,27 @@ subroutine pack_parameters & ic_K9, & inu9, & inu10, & - ic_Krrainm, & - inu_r, & - inu_hd, & + ic_K_hm, & + ic_K_hmb, & + iK_hm_min_coef, & + inu_hm, & igamma_coef, & igamma_coefb, & igamma_coefc, & imu, & ibeta, & - ilmin_coef, & + ilmin_coef, & + icoef_hm_1_hm_2_corr_adj, & + imult_coef, & itaumin, & itaumax, & iLscale_mu_coef, & iLscale_pert_coef, & + ialpha_corr, & + iSkw_denom_coef, & + ic_K10, & + ithlp2_rad_coef, & + ithlp2_rad_cloud_frac_thresh, & nparams implicit none @@ -826,9 +927,11 @@ subroutine pack_parameters & C11, C11b, C11c, C12, C13, C14, C15, & C6rt_Lscale0, C6thl_Lscale0, C7_Lscale0, wpxp_L_thresh, & c_K, c_K1, nu1, c_K2, nu2, c_K6, nu6, c_K8, nu8, & - c_K9, nu9, nu10, c_Krrainm, nu_r, nu_hd, gamma_coef, & - gamma_coefb, gamma_coefc, mu, beta, lmin_coef, taumin, & - taumax, Lscale_mu_coef, Lscale_pert_coef + c_K9, nu9, nu10, c_K_hm, c_K_hmb, K_hm_min_coef, nu_hm, gamma_coef, & + gamma_coefb, gamma_coefc, mu, beta, lmin_coef, coef_hm_1_hm_2_corr_adj, & + mult_coef, taumin, taumax, Lscale_mu_coef, Lscale_pert_coef, & + alpha_corr, Skw_denom_coef, c_K10, thlp2_rad_coef, & + thlp2_rad_cloud_frac_thresh ! Output variables real( kind = core_rknd ), intent(out), dimension(nparams) :: params @@ -881,9 +984,10 @@ subroutine pack_parameters & params(ic_K9) = c_K9 params(inu9) = nu9 params(inu10) = nu10 - params(ic_Krrainm) = c_Krrainm - params(inu_r) = nu_r - params(inu_hd) = nu_hd + params(ic_K_hm) = c_K_hm + params(ic_K_hmb) = c_K_hmb + params(iK_hm_min_coef) = K_hm_min_coef + params(inu_hm) = nu_hm params(igamma_coef) = gamma_coef params(igamma_coefb) = gamma_coefb @@ -895,11 +999,20 @@ subroutine pack_parameters & params(ilmin_coef) = lmin_coef + params(icoef_hm_1_hm_2_corr_adj) = coef_hm_1_hm_2_corr_adj + + params(imult_coef) = mult_coef + params(itaumin) = taumin params(itaumax) = taumax params(iLscale_mu_coef) = Lscale_mu_coef params(iLscale_pert_coef) = Lscale_pert_coef + params(ialpha_corr) = alpha_corr + params(iSkw_denom_coef) = Skw_denom_coef + params(ic_K10) = c_K10 + params(ithlp2_rad_coef) = thlp2_rad_coef + params(ithlp2_rad_cloud_frac_thresh) = thlp2_rad_cloud_frac_thresh return end subroutine pack_parameters @@ -913,10 +1026,12 @@ subroutine unpack_parameters & C11, C11b, C11c, C12, C13, C14, C15, & C6rt_Lscale0, C6thl_Lscale0, C7_Lscale0, wpxp_L_thresh, & c_K, c_K1, nu1, c_K2, nu2, c_K6, nu6, & - c_K8, nu8, c_K9, nu9, nu10, c_Krrainm, nu_r, & - nu_hd, gamma_coef, gamma_coefb, gamma_coefc, & - mu, beta, lmin_coef, taumin, taumax, Lscale_mu_coef, & - Lscale_pert_coef ) + c_K8, nu8, c_K9, nu9, nu10, c_K_hm, c_K_hmb, K_hm_min_coef, & + nu_hm, gamma_coef, gamma_coefb, gamma_coefc, & + mu, beta, lmin_coef, coef_hm_1_hm_2_corr_adj, mult_coef, taumin, & + taumax, Lscale_mu_coef, Lscale_pert_coef, alpha_corr, & + Skw_denom_coef, c_K10, thlp2_rad_coef, & + thlp2_rad_cloud_frac_thresh ) ! Description: ! Takes the 1D vector and returns the list of scalar variables. @@ -978,19 +1093,27 @@ subroutine unpack_parameters & ic_K9, & inu9, & inu10, & - ic_Krrainm, & - inu_r, & - inu_hd, & + ic_K_hm, & + ic_K_hmb, & + iK_hm_min_coef, & + inu_hm, & igamma_coef, & igamma_coefb, & igamma_coefc, & imu, & ibeta, & - ilmin_coef, & + ilmin_coef, & + icoef_hm_1_hm_2_corr_adj, & + imult_coef, & itaumin, & itaumax, & iLscale_mu_coef, & iLscale_pert_coef, & + ialpha_corr, & + iSkw_denom_coef, & + ic_K10, & + ithlp2_rad_coef, & + ithlp2_rad_cloud_frac_thresh, & nparams implicit none @@ -1006,10 +1129,11 @@ subroutine unpack_parameters & C11, C11b, C11c, C12, C13, C14, C15, & C6rt_Lscale0, C6thl_Lscale0, C7_Lscale0, wpxp_L_thresh, & c_K, c_K1, nu1, c_K2, nu2, c_K6, nu6, & - c_K8, nu8, c_K9, nu9, nu10, c_Krrainm, nu_r, & - nu_hd, gamma_coef, gamma_coefb, gamma_coefc, & - mu, beta, lmin_coef, taumin, taumax, Lscale_mu_coef, & - Lscale_pert_coef + c_K8, nu8, c_K9, nu9, nu10, c_K_hm, c_K_hmb, K_hm_min_coef, nu_hm, & + gamma_coef, gamma_coefb, gamma_coefc, & + mu, beta, lmin_coef, coef_hm_1_hm_2_corr_adj, mult_coef, taumin, taumax, & + Lscale_mu_coef, Lscale_pert_coef, alpha_corr, Skw_denom_coef, c_K10, & + thlp2_rad_coef, thlp2_rad_cloud_frac_thresh C1 = params(iC1) C1b = params(iC1b) @@ -1059,9 +1183,10 @@ subroutine unpack_parameters & c_K9 = params(ic_K9) nu9 = params(inu9) nu10 = params(inu10) - c_Krrainm = params(ic_Krrainm) - nu_r = params(inu_r) - nu_hd = params(inu_hd) + c_K_hm = params(ic_K_hm) + c_K_hmb = params(ic_K_hmb) + K_hm_min_coef = params(iK_hm_min_coef) + nu_hm = params(inu_hm) gamma_coef = params(igamma_coef) gamma_coefb = params(igamma_coefb) @@ -1073,11 +1198,21 @@ subroutine unpack_parameters & lmin_coef = params(ilmin_coef) + coef_hm_1_hm_2_corr_adj = params(icoef_hm_1_hm_2_corr_adj) + + mult_coef = params(imult_coef) + taumin = params(itaumin) taumax = params(itaumax) Lscale_mu_coef = params(iLscale_mu_coef) Lscale_pert_coef = params(iLscale_pert_coef) + alpha_corr = params(ialpha_corr) + Skw_denom_coef = params(iSkw_denom_coef) + c_K10 = params(ic_K10) + + thlp2_rad_coef = params(ithlp2_rad_coef) + thlp2_rad_cloud_frac_thresh = params(ithlp2_rad_cloud_frac_thresh) return end subroutine unpack_parameters @@ -1099,14 +1234,16 @@ subroutine get_parameters( params ) call pack_parameters( C1, C1b, C1c, C2, C2b, C2c, C2rt, C2thl, C2rtthl, & C4, C5, C6rt, C6rtb, C6rtc, C6thl, C6thlb, C6thlc, & - C7, C7b, C7c, C8, C8b, C10, & - C11, C11b, C11c, C12, C13, C14, C15, & + C7, C7b, C7c, C8, C8b, C10, & + C11, C11b, C11c, C12, C13, C14, C15, & C6rt_Lscale0, C6thl_Lscale0, C7_Lscale0, wpxp_L_thresh, & - c_K, c_K1, nu1, c_K2, nu2, c_K6, nu6, & - c_K8, nu8, c_K9, nu9, nu10, c_Krrainm, nu_r, & - nu_hd, gamma_coef, gamma_coefb, gamma_coefc, & - mu, beta, lmin_coef, taumin, taumax, Lscale_mu_coef, & - Lscale_pert_coef, params ) + c_K, c_K1, nu1, c_K2, nu2, c_K6, nu6, & + c_K8, nu8, c_K9, nu9, nu10, c_K_hm, c_K_hmb, K_hm_min_coef, & + nu_hm, gamma_coef, gamma_coefb, gamma_coefc, & + mu, beta, lmin_coef, coef_hm_1_hm_2_corr_adj, mult_coef, & + taumin, taumax, Lscale_mu_coef, Lscale_pert_coef, alpha_corr, & + Skw_denom_coef, c_K10, thlp2_rad_coef, & + thlp2_rad_cloud_frac_thresh, params ) return @@ -1122,76 +1259,80 @@ subroutine init_parameters_999( ) ! None !----------------------------------------------------------------------- - use clubb_precision, only: & - core_rknd ! Variable(s) - implicit none ! --- Begin Code --- - C1 = init_value - C1b = init_value - C1c = init_value - C2rt = init_value - C2thl = init_value - C2rtthl = init_value - C2 = init_value - C2b = init_value - C2c = init_value - C4 = init_value - C5 = init_value - C6rt = init_value - C6rtb = init_value - C6rtc = init_value - C6thl = init_value - C6thlb = init_value - C6thlc = init_value - C7 = init_value - C7b = init_value - C7c = init_value - C8 = init_value - C8b = init_value - C10 = init_value - C11 = init_value - C11b = init_value - C11c = init_value - C12 = init_value - C13 = init_value - C14 = init_value - C15 = init_value - C6rt_Lscale0 = init_value - C6thl_Lscale0 = init_value - C7_Lscale0 = init_value - wpxp_L_thresh = init_value - c_K = init_value - c_K1 = init_value - nu1 = init_value - c_K2 = init_value - nu2 = init_value - c_K6 = init_value - nu6 = init_value - c_K8 = init_value - nu8 = init_value - c_K9 = init_value - nu9 = init_value - nu10 = init_value - c_Krrainm = init_value - nu_r = init_value - nu_hd = init_value - beta = init_value - gamma_coef = init_value - gamma_coefb = init_value - gamma_coefc = init_value - taumin = init_value - taumax = init_value - lmin_coef = init_value - mu = init_value - Lscale_mu_coef = init_value - Lscale_pert_coef = init_value - - nu_hd_vert_res_dep = init_value + C1 = init_value + C1b = init_value + C1c = init_value + C2rt = init_value + C2thl = init_value + C2rtthl = init_value + C2 = init_value + C2b = init_value + C2c = init_value + C4 = init_value + C5 = init_value + C6rt = init_value + C6rtb = init_value + C6rtc = init_value + C6thl = init_value + C6thlb = init_value + C6thlc = init_value + C7 = init_value + C7b = init_value + C7c = init_value + C8 = init_value + C8b = init_value + C10 = init_value + C11 = init_value + C11b = init_value + C11c = init_value + C12 = init_value + C13 = init_value + C14 = init_value + C15 = init_value + C6rt_Lscale0 = init_value + C6thl_Lscale0 = init_value + C7_Lscale0 = init_value + wpxp_L_thresh = init_value + c_K = init_value + c_K1 = init_value + nu1 = init_value + c_K2 = init_value + nu2 = init_value + c_K6 = init_value + nu6 = init_value + c_K8 = init_value + nu8 = init_value + c_K9 = init_value + nu9 = init_value + nu10 = init_value + c_K_hm = init_value + c_K_hmb = init_value + K_hm_min_coef = init_value + nu_hm = init_value + beta = init_value + gamma_coef = init_value + gamma_coefb = init_value + gamma_coefc = init_value + mult_coef = init_value + taumin = init_value + taumax = init_value + lmin_coef = init_value + coef_hm_1_hm_2_corr_adj = init_value + mu = init_value + Lscale_mu_coef = init_value + Lscale_pert_coef = init_value + alpha_corr = init_value + Skw_denom_coef = init_value + c_K10 = init_value + thlp2_rad_coef = init_value + thlp2_rad_cloud_frac_thresh = init_value return + end subroutine init_parameters_999 !============================================================================= @@ -1216,10 +1357,10 @@ subroutine cleanup_nu( ) deallocate( nu1_vert_res_dep, nu2_vert_res_dep, nu6_vert_res_dep, & nu8_vert_res_dep, nu9_vert_res_dep, nu10_vert_res_dep, & - nu_r_vert_res_dep, stat = ierr ) + nu_hm_vert_res_dep, stat = ierr ) if ( ierr /= 0 ) then - write(fstderr,*) "Nu deallocation failed." + write(fstderr,*) "Deallocation of vertically depedent nu arrays failed." end if return diff --git a/models/atm/cam/src/physics/clubb/pdf_closure_module.F90 b/models/atm/cam/src/physics/clubb/pdf_closure_module.F90 index 13743291c389..89d2fa0b6ec2 100644 --- a/models/atm/cam/src/physics/clubb/pdf_closure_module.F90 +++ b/models/atm/cam/src/physics/clubb/pdf_closure_module.F90 @@ -1,132 +1,134 @@ -! $Id: pdf_closure_module.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +!--------------------------------------------------------------------------- +! $Id: pdf_closure_module.F90 7309 2014-09-20 17:06:28Z betlej@uwm.edu $ +!=============================================================================== module pdf_closure_module implicit none - public :: pdf_closure + public :: pdf_closure, calc_vert_avg_cf_component private ! Set Default Scope contains !------------------------------------------------------------------------ - subroutine pdf_closure & - ( p_in_Pa, exner, thv_ds, wm, & - wp2, wp3, sigma_sqd_w, & - Skw, rtm, rtp2, & - wprtp, thlm, thlp2, & - wpthlp, rtpthlp, sclrm, & - wpsclrp, sclrp2, sclrprtp, & - sclrpthlp, level, & + + !####################################################################### + !####################################################################### + ! If you change the argument list of pdf_closure you also have to + ! change the calls to this function in the host models CAM, WRF, SAM + ! and GFDL. + !####################################################################### + !####################################################################### + subroutine pdf_closure( hydromet_dim, p_in_Pa, exner, thv_ds, wm, & + wp2, wp3, sigma_sqd_w, & + Skw, rtm, rtp2, & + wprtp, thlm, thlp2, & + wpthlp, rtpthlp, sclrm, & + wpsclrp, sclrp2, sclrprtp, & + sclrpthlp, level, & #ifdef GFDL - RH_crit, & ! h1g, 2010-06-15 + RH_crit, do_liquid_only_in_clubb, & ! h1g, 2010-06-15 #endif - wp4, wprtp2, wp2rtp, & - wpthlp2, wp2thlp, wprtpthlp, & - cloud_frac, rcm, wpthvp, & - wp2thvp, rtpthvp, thlpthvp, & - wprcp, wp2rcp, rtprcp, & - thlprcp, rcp2, pdf_params, & - err_code, & - wpsclrprtp, wpsclrp2, sclrpthvp, & - wpsclrpthlp, sclrprcp, wp2sclrp, & - sptp_mellor_1, sptp_mellor_2, & - tp2_mellor_1, tp2_mellor_2, & - corr_st_mellor1, corr_st_mellor2 ) - - -! Description: -! Subroutine that computes pdf parameters analytically. - -! Based of the original formulation, but with some tweaks -! to remove some of the less realistic assumptions and -! improve transport terms. - -! Corrected version that should remove inconsistency - -! References: -! Eqn. 29, 30, 31, 32 & 33 on p. 3547 of -! ``A PDF-Based Model for Boundary Layer Clouds. Part I: -! Method and Model Description'' Golaz, et al. (2002) -! JAS, Vol. 59, pp. 3540--3551. -!------------------------------------------------------------------------ - - use constants_clubb, only: & - ! Constants - sqrt_2pi, & ! sqrt(2*pi) - sqrt_2, & ! sqrt(2) - pi, & ! The ratio of radii to their circumference - Cp, & ! Dry air specific heat at constant p [J/kg/K] - Lv, & ! Latent heat of vaporization [J/kg] - Rd, & ! Dry air gas constant [J/kg/K] - Rv, & ! Water vapor gas constant [J/kg/K] - ep, & ! Rd / Rv; ep = 0.622 [-] - ep1, & ! (1.0-ep)/ep; ep1 = 0.61 [-] - ep2, & ! 1.0/ep; ep2 = 1.61 [-] - w_tol_sqd, & ! Tolerance for w'^2 [m^2/s^2] - rt_tol, & ! Tolerance for r_t [kg/kg] - thl_tol, & ! Tolerance for th_l [K] - s_mellor_tol, & ! Tolerance for pdf parameter s [kg/kg] - fstderr, & - zero_threshold + wphydrometp, wp2hmp, & + rtphmp, thlphmp, & + wp4, wprtp2, wp2rtp, & + wpthlp2, wp2thlp, wprtpthlp, & + cloud_frac, ice_supersat_frac, & + rcm, wpthvp, wp2thvp, rtpthvp, & + thlpthvp, wprcp, wp2rcp, rtprcp, & + thlprcp, rcp2, pdf_params, & + err_code, & + wpsclrprtp, wpsclrp2, sclrpthvp, & + wpsclrpthlp, sclrprcp, wp2sclrp, & + rc_coef ) + + + ! Description: + ! Subroutine that computes pdf parameters analytically. + ! + ! Based of the original formulation, but with some tweaks + ! to remove some of the less realistic assumptions and + ! improve transport terms. + + ! Corrected version that should remove inconsistency + + ! References: + ! Eqn. 29, 30, 31, 32 & 33 on p. 3547 of + ! ``A PDF-Based Model for Boundary Layer Clouds. Part I: + ! Method and Model Description'' Golaz, et al. (2002) + ! JAS, Vol. 59, pp. 3540--3551. + !---------------------------------------------------------------------- + + use constants_clubb, only: & ! Constants + two, & ! 2 + one, & ! 1 + one_half, & ! 1/2 + zero, & ! 0 + Cp, & ! Dry air specific heat at constant p [J/kg/K] + Lv, & ! Latent heat of vaporization [J/kg] + Rd, & ! Dry air gas constant [J/kg/K] + ep, & ! Rd / Rv; ep = 0.622 [-] + ep1, & ! (1.0-ep)/ep; ep1 = 0.61 [-] + ep2, & ! 1.0/ep; ep2 = 1.61 [-] + w_tol_sqd, & ! Tolerance for w'^2 [m^2/s^2] + rt_tol, & ! Tolerance for r_t [kg/kg] + thl_tol, & ! Tolerance for th_l [K] + T_freeze_K, & ! Freezing point of water [K] + fstderr, & + zero_threshold, & + chi_tol use parameters_model, only: & - sclr_tol, & ! Array of passive scalar tolerances [units vary] - sclr_dim, & ! Number of passive scalar variables - mixt_frac_max_mag ! Maximum values for PDF parameter 'mixt_frac' + sclr_tol, & ! Array of passive scalar tolerances [units vary] + sclr_dim, & ! Number of passive scalar variables + mixt_frac_max_mag ! Maximum values for PDF parameter 'mixt_frac' use parameters_tunable, only: & - beta ! Variable(s) + beta ! Variable(s) ! Plume widths for th_l and r_t [-] use pdf_parameter_module, only: & pdf_parameter ! type + use array_index, only: & + l_mix_rat_hm ! Variable(s) + use anl_erf, only: & - erf ! Procedure(s) + erf ! Procedure(s) ! The error function use numerical_check, only: & - pdf_closure_check ! Procedure(s) + pdf_closure_check ! Procedure(s) use saturation, only: & - sat_mixrat_liq ! Procedure(s) - -#ifdef GFDL - ! including ice clouds - use saturation, only: & ! h1g, 2010-06-15 - sat_mixrat_ice -#endif + sat_mixrat_liq, & ! Procedure(s) + sat_mixrat_ice - use error_code, only: & - clubb_var_equals_NaN, & ! Constant(s) - clubb_no_error + use error_code, only: & + clubb_no_error ! Constant(s) use error_code, only: & - clubb_at_least_debug_level ! Procedure(s) - - use stats_variables, only: & - iwp4, & ! Variables - ircp2, & - iwprtp2, & - iwprtpthlp, & - iwpthlp2 + clubb_at_least_debug_level, & ! Procedure(s) + fatal_error use stats_variables, only: & - itp2_mellor_1, & - itp2_mellor_2, & - isptp_mellor_1, & - isptp_mellor_2, & - icorr_st_mellor1, & - icorr_st_mellor2 + iwp4, & ! Variables + ircp2, & + iwprtp2, & + iwprtpthlp, & + iwpthlp2 use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) implicit none intrinsic :: sqrt, exp, min, max, abs, present ! Input Variables + integer, intent(in) :: & + hydromet_dim ! Number of hydrometeor species [#] + real( kind = core_rknd ), intent(in) :: & p_in_Pa, & ! Pressure [Pa] exner, & ! Exner function [-] @@ -155,38 +157,40 @@ subroutine pdf_closure & ! critial relative humidity for nucleation real( kind = core_rknd ), dimension( min(1,sclr_dim), 2 ), intent(in) :: & ! h1g, 2010-06-15 RH_crit ! critical relative humidity for droplet and ice nucleation +! ---> h1g, 2012-06-14 + logical, intent(in) :: do_liquid_only_in_clubb +! <--- h1g, 2012-06-14 #endif integer, intent(in) :: & level ! Thermodynamic level for which calculations are taking place. - ! Output Variables + real( kind = core_rknd ), dimension(hydromet_dim), intent(in) :: & + wphydrometp, & ! Covariance of w and a hydrometeor [(m/s) ] + wp2hmp, & ! Third-order moment: < w'^2 hm' > [(m/s)^2 ] + rtphmp, & ! Covariance of rt and a hydrometeor [(kg/kg) ] + thlphmp ! Covariance of thl and a hydrometeor [K ] + ! Output Variables real( kind = core_rknd ), intent(out) :: & - wp4, & ! w'^4 [m^4/s^4] - wprtp2, & ! w' r_t' [(m kg)/(s kg)] - wp2rtp, & ! w'^2 r_t' [(m^2 kg)/(s^2 kg)] - wpthlp2, & ! w' th_l'^2 [(m K^2)/s] - wp2thlp, & ! w'^2 th_l' [(m^2 K)/s^2] - cloud_frac, & ! Cloud fraction [-] - rcm, & ! Mean liquid water [kg/kg] - wpthvp, & ! Buoyancy flux [(K m)/s] - wp2thvp, & ! w'^2 th_v' [(m^2 K)/s^2] - rtpthvp, & ! r_t' th_v' [(kg K)/kg] - thlpthvp, & ! th_l' th_v' [K^2] - wprcp, & ! w' r_c' [(m kg)/(s kg)] - wp2rcp, & ! w'^2 r_c' [(m^2 kg)/(s^2 kg)] - rtprcp, & ! r_t' r_c' [(kg^2)/(kg^2)] - thlprcp, & ! th_l' r_c' [(K kg)/kg] - rcp2, & ! r_c'^2 [(kg^2)/(kg^2)] - wprtpthlp ! w' r_t' th_l' [(m kg K)/(s kg)] - - ! Some variables for when we're computing the correlation or covariance of - ! s and t for diagnostic purposes - real( kind = core_rknd ), optional, intent(out) :: & - sptp_mellor_1, sptp_mellor_2, & ! Covariance of s and t [kg^2/kg^2] - tp2_mellor_1, tp2_mellor_2, & ! Variance of t [kg^2/kg^2] - corr_st_mellor1, corr_st_mellor2 ! Correlation of s and t [-] + wp4, & ! w'^4 [m^4/s^4] + wprtp2, & ! w' r_t' [(m kg)/(s kg)] + wp2rtp, & ! w'^2 r_t' [(m^2 kg)/(s^2 kg)] + wpthlp2, & ! w' th_l'^2 [(m K^2)/s] + wp2thlp, & ! w'^2 th_l' [(m^2 K)/s^2] + cloud_frac, & ! Cloud fraction [-] + ice_supersat_frac, & ! Ice cloud fracion [-] + rcm, & ! Mean liquid water [kg/kg] + wpthvp, & ! Buoyancy flux [(K m)/s] + wp2thvp, & ! w'^2 th_v' [(m^2 K)/s^2] + rtpthvp, & ! r_t' th_v' [(kg K)/kg] + thlpthvp, & ! th_l' th_v' [K^2] + wprcp, & ! w' r_c' [(m kg)/(s kg)] + wp2rcp, & ! w'^2 r_c' [(m^2 kg)/(s^2 kg)] + rtprcp, & ! r_t' r_c' [(kg^2)/(kg^2)] + thlprcp, & ! th_l' r_c' [(K kg)/kg] + rcp2, & ! r_c'^2 [(kg^2)/(kg^2)] + wprtpthlp ! w' r_t' th_l' [(m kg K)/(s kg)] type(pdf_parameter), intent(out) :: & pdf_params ! pdf paramters [units vary] @@ -207,47 +211,55 @@ subroutine pdf_closure & ! Local Variables real( kind = core_rknd ) :: & - w1_n, w2_n -! thl1_n, thl2_n, -! rt1_n, rt2_n + w_1_n, w_2_n +! thl_1_n, thl_2_n, +! rt_1_n, rt_2_n ! Variables that are stored in derived data type pdf_params. real( kind = core_rknd ) :: & - w1, & ! Mean of w for 1st normal distribution [m/s] - w2, & ! Mean of w for 2nd normal distribution [m/s] - varnce_w1, & ! Variance of w for 1st normal distribution [m^2/s^2] - varnce_w2, & ! Variance of w for 2nd normal distribution [m^2/s^2] - rt1, & ! Mean of r_t for 1st normal distribution [kg/kg] - rt2, & ! Mean of r_t for 2nd normal distribution [kg/kg] - varnce_rt1, & ! Variance of r_t for 1st normal distribution [kg^2/kg^2] - varnce_rt2, & ! Variance of r_t for 2nd normal distribution [kg^2/kg^2] - crt1, & ! Coefficient for s' [-] - crt2, & ! Coefficient for s' [-] - cthl1, & ! Coefficient for s' [1/K] - cthl2, & ! Coefficient for s' [1/K] - thl1, & ! Mean of th_l for 1st normal distribution [K] - thl2, & ! Mean of th_l for 2nd normal distribution [K] - varnce_thl1, & ! Variance of th_l for 1st normal distribution [K^2] - varnce_thl2, & ! Variance of th_l for 2nd normal distribution [K^2] - mixt_frac, & ! Weight of 1st normal distribution (Sk_w dependent) [-] - rc1, & ! Mean of r_c for 1st normal distribution [kg/kg] - rc2, & ! Mean of r_c for 2nd normal distribution [kg/kg] - rsl1, & ! Mean of r_sl for 1st normal distribution [kg/kg] - rsl2, & ! Mean of r_sl for 2nd normal distribution [kg/kg] - cloud_frac1, & ! Cloud fraction for 1st normal distribution [-] - cloud_frac2, & ! Cloud fraction for 2nd normal distribution [-] - s1, & ! Mean of s for 1st normal distribution [kg/kg] - s2, & ! Mean of s for 2nd normal distribution [kg/kg] - stdev_s1, & ! Standard deviation of s for 1st normal distribution [kg/kg] - stdev_s2, & ! Standard deviation of s for 2nd normal distribution [kg/kg] - rrtthl, & ! Within-a-normal (sub-plume) correlation of r_t and th_l [-] - alpha_thl, & ! Factor relating to normalized variance for th_l [-] - alpha_rt ! Factor relating to normalized variance for r_t [-] + w_1, & ! Mean of w (1st PDF component) [m/s] + w_2, & ! Mean of w (2nd PDF component) [m/s] + varnce_w_1, & ! Variance of w (1st PDF component) [m^2/s^2] + varnce_w_2, & ! Variance of w (2nd PDF component) [m^2/s^2] + rt_1, & ! Mean of r_t (1st PDF component) [kg/kg] + rt_2, & ! Mean of r_t (2nd PDF component) [kg/kg] + varnce_rt_1, & ! Variance of r_t (1st PDF component) [kg^2/kg^2] + varnce_rt_2, & ! Variance of r_t (2nd PDF component) [kg^2/kg^2] + thl_1, & ! Mean of th_l (1st PDF component) [K] + thl_2, & ! Mean of th_l (2nd PDF component) [K] + varnce_thl_1, & ! Variance of th_l (1st PDF component) [K^2] + varnce_thl_2, & ! Variance of th_l (2nd PDF component) [K^2] + rrtthl, & ! Correlation of r_t and th_l (both components) [-] + alpha_thl, & ! Factor relating to normalized variance for th_l [-] + alpha_rt, & ! Factor relating to normalized variance for r_t [-] + crt_1, & ! Coef. on r_t in s/t eqns. (1st PDF comp.) [-] + crt_2, & ! Coef. on r_t in s/t eqns. (2nd PDF comp.) [-] + cthl_1, & ! Coef. on th_l in s/t eqns. (1st PDF comp.) [(kg/kg)/K] + cthl_2 ! Coef. on th_l in s/t eqns. (2nd PDF comp.) [(kg/kg)/K] + + real( kind = core_rknd ) :: & + chi_1, & ! Mean of chi (old s) (1st PDF component) [kg/kg] + chi_2, & ! Mean of chi (old s) (2nd PDF component) [kg/kg] + stdev_chi_1, & ! Standard deviation of chi (1st PDF component) [kg/kg] + stdev_chi_2, & ! Standard deviation of chi (2nd PDF component) [kg/kg] + stdev_eta_1, & ! Standard dev. of eta (old t) (1st PDF comp.) [kg/kg] + stdev_eta_2, & ! Standard dev. of eta (old t) (2nd PDF comp.) [kg/kg] + covar_chi_eta_1, & ! Covariance of chi and eta (1st PDF comp.) [kg^2/kg^2] + covar_chi_eta_2, & ! Covariance of chi and eta (2nd PDF comp.) [kg^2/kg^2] + corr_chi_eta_1, & ! Correlation of chi and eta (1st PDF component) [-] + corr_chi_eta_2, & ! Correlation of chi and eta (2nd PDF component) [-] + rsatl_1, & ! Mean of r_sl (1st PDF component) [kg/kg] + rsatl_2, & ! Mean of r_sl (2nd PDF component) [kg/kg] + rc_1, & ! Mean of r_c (1st PDF component) [kg/kg] + rc_2, & ! Mean of r_c (2nd PDF component) [kg/kg] + cloud_frac_1, & ! Cloud fraction (1st PDF component) [-] + cloud_frac_2, & ! Cloud fraction (2nd PDF component) [-] + mixt_frac ! Weight of 1st PDF component (Sk_w dependent) [-] ! Note: alpha coefficients = 0.5 * ( 1 - correlations^2 ). ! These are used to calculate the scalar widths - ! varnce_thl1, varnce_thl2, varnce_rt1, and varnce_rt2 as in Eq. (34) of - ! Larson and Golaz (2005) + ! varnce_thl_1, varnce_thl_2, varnce_rt_1, and varnce_rt_2 as in Eq. (34) + ! of Larson and Golaz (2005) ! Passive scalar local variables @@ -259,28 +271,50 @@ subroutine pdf_closure & ! sclr1_n, sclr2_n, logical :: & - l_scalar_calc, & ! True if sclr_dim > 0 - l_corr_calc ! True if the diagnostic correlation and covariance variables are present + l_scalar_calc, & ! True if sclr_dim > 0 + l_calc_ice_supersat_frac ! True if we should calculate ice_supersat_frac ! Quantities needed to predict higher order moments real( kind = core_rknd ) :: & tl1, tl2, & - beta1, beta2, & - zeta1, zeta2 + beta1, beta2 real( kind = core_rknd ) :: sqrt_wp2 ! Thermodynamic quantity - real( kind = core_rknd ) :: rc_coef + real( kind = core_rknd ), intent(out) :: rc_coef + + real( kind = core_rknd ) :: & + wp2rxp, & ! Sum total < w'^2 r_x' > for all hm species x [(m/s)^2(kg/kg)] + wprxp, & ! Sum total < w'r_x' > for all hm species x [(m/s)(kg/kg)] + thlprxp, & ! Sum total < th_l'r_x' > for all hm species x [K(kg/kg)] + rtprxp ! Sum total < r_t'r_x' > for all hm species x [(kg/kg)^2] ! variables for a generalization of Chris Golaz' closure ! varies width of plumes in theta_l, rt real( kind = core_rknd ) :: width_factor_1, width_factor_2 + + ! variables for computing ice cloud fraction + real( kind = core_rknd) :: & + ice_supersat_frac1, & ! first pdf component of ice_supersat_frac + ice_supersat_frac2, & ! second pdf component of ice_supersat_frac + rt_at_ice_sat1, rt_at_ice_sat2, & + chi_at_ice_sat1, chi_at_ice_sat2, rc_1_ice, rc_2_ice + + real( kind = core_rknd ), parameter :: & + chi_at_liq_sat = 0.0_core_rknd ! Always zero + + logical, parameter :: & + l_liq_ice_loading_test = .false. ! Temp. flag liq./ice water loading test + + integer :: i, hm_idx ! Indices - real( kind = core_rknd ) :: stdev_s_times_stdev_t - - integer :: i ! Index +#ifdef GFDL + real ( kind = core_rknd ), parameter :: t1_combined = 273.16, & + t2_combined = 268.16, & + t3_combined = 238.16 +#endif !------------------------ Code Begins ---------------------------------- @@ -292,36 +326,29 @@ subroutine pdf_closure & l_scalar_calc = .false. end if - if ( present( sptp_mellor_1 ) .and. present( sptp_mellor_2 ) .and. & - present( tp2_mellor_1 ) .and. present( tp2_mellor_2 ) .and. & - present( corr_st_mellor1 ) .and. present( corr_st_mellor2 ) )then - l_corr_calc = .true. - else - l_corr_calc = .false. - end if - err_code = clubb_no_error ! Initialize to the value for no errors - ! If there is no velocity, then use single delta fnc. as pdf - ! Otherwise width parameters (e.g. varnce_w1, varnce_w2, etc.) are non-zero. + ! If there is no variance in vertical velocity, then treat rt and theta-l as + ! constant, as well. Otherwise width parameters (e.g. varnce_w_1, + ! varnce_w_2, etc.) are non-zero. if ( wp2 <= w_tol_sqd ) then - mixt_frac = 0.5_core_rknd - w1 = wm - w2 = wm - varnce_w1 = 0._core_rknd - varnce_w2 = 0._core_rknd - rt1 = rtm - rt2 = rtm - alpha_rt = 0.5_core_rknd - varnce_rt1 = 0._core_rknd - varnce_rt2 = 0._core_rknd - thl1 = thlm - thl2 = thlm - alpha_thl = 0.5_core_rknd - varnce_thl1 = 0._core_rknd - varnce_thl2 = 0._core_rknd - rrtthl = 0._core_rknd + mixt_frac = one_half + w_1 = wm + w_2 = wm + varnce_w_1 = 0._core_rknd + varnce_w_2 = 0._core_rknd + rt_1 = rtm + rt_2 = rtm + alpha_rt = one_half + varnce_rt_1 = 0._core_rknd + varnce_rt_2 = 0._core_rknd + thl_1 = thlm + thl_2 = thlm + alpha_thl = one_half + varnce_thl_1 = 0._core_rknd + varnce_thl_2 = 0._core_rknd + rrtthl = 0._core_rknd if ( l_scalar_calc ) then do i = 1, sclr_dim, 1 @@ -329,7 +356,7 @@ subroutine pdf_closure & sclr2(i) = sclrm(i) varnce_sclr1(i) = 0.0_core_rknd varnce_sclr2(i) = 0.0_core_rknd - alpha_sclr(i) = 0.5_core_rknd + alpha_sclr(i) = one_half rsclrrt(i) = 0.0_core_rknd rsclrthl(i) = 0.0_core_rknd end do ! 1..sclr_dim @@ -337,20 +364,21 @@ subroutine pdf_closure & else ! Width (standard deviation) parameters are non-zero - ! The variable "mixt_frac" is the weight of Gaussian "plume" 1. The weight of - ! Gaussian "plume" 2 is "1-mixt_frac". If there isn't any skewness of w - ! (Sk_w = 0 because w'^3 = 0), mixt_frac = 0.5, and both Gaussian "plumes" are - ! equally weighted. If there is positive skewness of w (Sk_w > 0 because - ! w'^3 > 0), 0 < mixt_frac < 0.5, and Gaussian "plume" 2 has greater weight than - ! does Gaussian "plume" 1. If there is negative skewness of w (Sk_w < 0 - ! because w'^3 < 0), 0.5 < mixt_frac < 1, and Gaussian "plume" 1 has greater - ! weight than does Gaussian "plume" 2. - if ( abs( Skw ) <= 1e-5_core_rknd ) then - mixt_frac = 0.5_core_rknd - else - mixt_frac = 0.5_core_rknd * ( 1.0_core_rknd - Skw/ & - sqrt( 4.0_core_rknd*( 1.0_core_rknd - sigma_sqd_w )**3 + Skw**2 ) ) - endif + ! The variable "mixt_frac" is the weight of the 1st PDF component. The + ! weight of the 2nd PDF component is "1-mixt_frac". If there isn't any + ! skewness of w (Sk_w = 0 because w'^3 = 0), mixt_frac = 0.5, and both + ! PDF components are equally weighted. If there is positive skewness of + ! w (Sk_w > 0 because w'^3 > 0), 0 < mixt_frac < 0.5, and the 2nd PDF + ! component has greater weight than does the 1st PDF component. If there + ! is negative skewness of w (Sk_w < 0 because w'^3 < 0), + ! 0.5 < mixt_frac < 1, and the 1st PDF component has greater weight than + ! does the 2nd PDF component. + if ( abs( Skw ) <= 1e-5_core_rknd ) then + mixt_frac = one_half + else + mixt_frac = one_half * ( one - Skw/ & + sqrt( 4.0_core_rknd*( one - sigma_sqd_w )**3 + Skw**2 ) ) + endif ! Determine sqrt( wp2 ) here to avoid re-computing it sqrt_wp2 = sqrt( wp2 ) @@ -358,29 +386,29 @@ subroutine pdf_closure & ! Clip mixt_frac, 1-mixt_frac, to avoid dividing by zero ! Formula for mixt_frac_max_mag = ! 1 - ( 1/2 * ( 1 - Skw_max/sqrt( 4*( 1 - sigma_sqd_w )^3 + Skw_max^2 ) ) ) - ! Where sigma_sqd_w is fixed at 0.4_core_rknd - mixt_frac = min( max( mixt_frac, 1.0_core_rknd-mixt_frac_max_mag ), mixt_frac_max_mag ) + ! Where sigma_sqd_w is fixed at 0.4. + mixt_frac = min( max( mixt_frac, one-mixt_frac_max_mag ), mixt_frac_max_mag ) - ! The normalized mean of w for Gaussian "plume" 1 is w1_n. It's value + ! The normalized mean of w for Gaussian "plume" 1 is w_1_n. It's value ! will always be greater than 0. As an example, a value of 1.0 would ! indicate that the actual mean of w for Gaussian "plume" 1 is found ! 1.0 standard deviation above the overall mean for w. - w1_n = sqrt( ( (1._core_rknd-mixt_frac)/mixt_frac )*(1._core_rknd-sigma_sqd_w) ) - ! The normalized mean of w for Gaussian "plume" 2 is w2_n. It's value + w_1_n = sqrt( ( (one-mixt_frac)/mixt_frac )*(one-sigma_sqd_w) ) + ! The normalized mean of w for Gaussian "plume" 2 is w_2_n. It's value ! will always be less than 0. As an example, a value of -0.5 would ! indicate that the actual mean of w for Gaussian "plume" 2 is found ! 0.5 standard deviations below the overall mean for w. - w2_n = -sqrt( ( mixt_frac/(1._core_rknd-mixt_frac) )*(1._core_rknd-sigma_sqd_w) ) - ! The mean of w for Gaussian "plume" 1 is w1. - w1 = wm + sqrt_wp2*w1_n - ! The mean of w for Gaussian "plume" 2 is w2. - w2 = wm + sqrt_wp2*w2_n - - ! The variance of w for Gaussian "plume" 1 for varnce_w1. - varnce_w1 = sigma_sqd_w*wp2 - ! The variance of w for Gaussian "plume" 2 for varnce_w2. + w_2_n = -sqrt( ( mixt_frac/(one-mixt_frac) )*(one-sigma_sqd_w) ) + ! The mean of w for Gaussian "plume" 1 is w_1. + w_1 = wm + sqrt_wp2*w_1_n + ! The mean of w for Gaussian "plume" 2 is w_2. + w_2 = wm + sqrt_wp2*w_2_n + + ! The variance of w for Gaussian "plume" 1 for varnce_w_1. + varnce_w_1 = sigma_sqd_w*wp2 + ! The variance of w for Gaussian "plume" 2 for varnce_w_2. ! The variance in both Gaussian "plumes" is defined to be the same. - varnce_w2 = sigma_sqd_w*wp2 + varnce_w_2 = sigma_sqd_w*wp2 ! The normalized variance for thl, rt, and sclr for "plume" 1 is: @@ -396,7 +424,7 @@ subroutine pdf_closure & ! as width_factor_1. ! ! The factor { 1 - [1/(1-sigma_sqd_w)]*[ (w'x')^2 / (w'^2 * x'^2) ] / mixt_frac } - ! depends on which variable "x" stands for. It is multiplied by 0.5_core_rknd and + ! depends on which variable "x" stands for. It is multiplied by one_half and ! defined as alpha_x, where "x" stands for thl, rt, or sclr. ! Vince Larson added a dimensionless factor so that the @@ -407,56 +435,56 @@ subroutine pdf_closure & ! 3 Nov 2003 width_factor_1 = ( 2.0_core_rknd/3.0_core_rknd )*beta + 2.0_core_rknd& - *mixt_frac*( 1.0_core_rknd - ( 2.0_core_rknd/3.0_core_rknd )*beta ) + *mixt_frac*( one - ( 2.0_core_rknd/3.0_core_rknd )*beta ) width_factor_2 = 2.0_core_rknd - width_factor_1 if ( thlp2 <= thl_tol**2 ) then - thl1 = thlm - thl2 = thlm - varnce_thl1 = 0.0_core_rknd - varnce_thl2 = 0.0_core_rknd - alpha_thl = 0.5_core_rknd + thl_1 = thlm + thl_2 = thlm + varnce_thl_1 = 0.0_core_rknd + varnce_thl_2 = 0.0_core_rknd + alpha_thl = one_half else -! thl1_n = - (wpthlp/(sqrt( wp2 )*sqrt( thlp2 )))/w2_n -! thl2_n = - (wpthlp/(sqrt( wp2 )*sqrt( thlp2 )))/w1_n +! thl_1_n = - (wpthlp/(sqrt( wp2 )*sqrt( thlp2 )))/w_2_n +! thl_2_n = - (wpthlp/(sqrt( wp2 )*sqrt( thlp2 )))/w_1_n - thl1 = thlm - ( wpthlp/sqrt_wp2 )/w2_n - thl2 = thlm - ( wpthlp/sqrt_wp2 )/w1_n + thl_1 = thlm - ( wpthlp/sqrt_wp2 )/w_2_n + thl_2 = thlm - ( wpthlp/sqrt_wp2 )/w_1_n - alpha_thl = 0.5_core_rknd * ( 1.0_core_rknd - wpthlp*wpthlp / & - ((1.0_core_rknd-sigma_sqd_w)*wp2*thlp2) ) + alpha_thl = one_half * ( one - wpthlp*wpthlp / & + ((one-sigma_sqd_w)*wp2*thlp2) ) - alpha_thl = max( min( alpha_thl, 1.0_core_rknd ), zero_threshold ) + alpha_thl = max( min( alpha_thl, one ), zero_threshold ) ! Vince Larson multiplied original expressions by width_factor_1,2 ! to generalize scalar skewnesses. 05 Nov 03 - varnce_thl1 = ( alpha_thl / mixt_frac * thlp2 ) * width_factor_1 - varnce_thl2 = ( alpha_thl / (1._core_rknd-mixt_frac) * thlp2 ) * width_factor_2 + varnce_thl_1 = ( alpha_thl / mixt_frac * thlp2 ) * width_factor_1 + varnce_thl_2 = ( alpha_thl / (one-mixt_frac) * thlp2 ) * width_factor_2 end if ! thlp2 <= thl_tol**2 if ( rtp2 <= rt_tol**2 ) then - rt1 = rtm - rt2 = rtm - varnce_rt1 = 0.0_core_rknd - varnce_rt2 = 0.0_core_rknd - alpha_rt = 0.5_core_rknd + rt_1 = rtm + rt_2 = rtm + varnce_rt_1 = 0.0_core_rknd + varnce_rt_2 = 0.0_core_rknd + alpha_rt = one_half else -! rt1_n = -( wprtp / ( sqrt( wp2 )*sqrt( rtp2 ) ) ) / w2_n -! rt2_n = -( wprtp / ( sqrt( wp2 )*sqrt( rtp2 ) ) ) / w1_n +! rt_1_n = -( wprtp / ( sqrt( wp2 )*sqrt( rtp2 ) ) ) / w_2_n +! rt_2_n = -( wprtp / ( sqrt( wp2 )*sqrt( rtp2 ) ) ) / w_1_n - rt1 = rtm - ( wprtp / sqrt_wp2 ) / w2_n - rt2 = rtm - ( wprtp / sqrt_wp2 ) / w1_n + rt_1 = rtm - ( wprtp / sqrt_wp2 ) / w_2_n + rt_2 = rtm - ( wprtp / sqrt_wp2 ) / w_1_n - alpha_rt = 0.5_core_rknd * ( 1.0_core_rknd - wprtp*wprtp / & - ((1.0_core_rknd-sigma_sqd_w)*wp2*rtp2) ) + alpha_rt = one_half * ( one - wprtp*wprtp / & + ((one-sigma_sqd_w)*wp2*rtp2) ) - alpha_rt = max( min( alpha_rt, 1.0_core_rknd ), zero_threshold ) + alpha_rt = max( min( alpha_rt, one ), zero_threshold ) ! Vince Larson multiplied original expressions by width_factor_1,2 ! to generalize scalar skewnesses. 05 Nov 03 - varnce_rt1 = ( alpha_rt / mixt_frac * rtp2 ) * width_factor_1 - varnce_rt2 = ( alpha_rt / (1._core_rknd-mixt_frac) * rtp2 ) * width_factor_2 + varnce_rt_1 = ( alpha_rt / mixt_frac * rtp2 ) * width_factor_1 + varnce_rt_2 = ( alpha_rt / (one-mixt_frac) * rtp2 ) * width_factor_2 end if ! rtp2 <= rt_tol**2 @@ -471,27 +499,27 @@ subroutine pdf_closure & varnce_sclr1(i) = 0.0_core_rknd varnce_sclr2(i) = 0.0_core_rknd - alpha_sclr(i) = 0.5_core_rknd + alpha_sclr(i) = one_half else ! sclr1_n(i) = - ( wpsclrp(i) / (sqrt( wp2 ) & -! * sqrt( sclrp2(i) )) )/w2_n +! * sqrt( sclrp2(i) )) )/w_2_n ! sclr2_n(i) = - ( wpsclrp(i) / (sqrt( wp2 ) & -! * sqrt( sclrp2(i) )) )/w1_n +! * sqrt( sclrp2(i) )) )/w_1_n sclr1(i) = sclrm(i) & - - ( wpsclrp(i) / sqrt_wp2 ) / w2_n + - ( wpsclrp(i) / sqrt_wp2 ) / w_2_n sclr2(i) = sclrm(i) & - - ( wpsclrp(i) / sqrt_wp2 ) / w1_n + - ( wpsclrp(i) / sqrt_wp2 ) / w_1_n - alpha_sclr(i) = 0.5_core_rknd * ( 1.0_core_rknd - wpsclrp(i)*wpsclrp(i) & - / ((1.0_core_rknd-sigma_sqd_w)*wp2*sclrp2(i)) ) + alpha_sclr(i) = one_half * ( one - wpsclrp(i)*wpsclrp(i) & + / ((one-sigma_sqd_w)*wp2*sclrp2(i)) ) - alpha_sclr(i) = max( min( alpha_sclr(i), 1.0_core_rknd ), zero_threshold ) + alpha_sclr(i) = max( min( alpha_sclr(i), one ), zero_threshold ) ! Vince Larson multiplied original expressions by width_factor_1,2 ! to generalize scalar skewnesses. 05 Nov 03 varnce_sclr1(i) = ( alpha_sclr(i) / mixt_frac * sclrp2(i) ) * width_factor_1 - varnce_sclr2(i) = ( alpha_sclr(i) / (1._core_rknd-mixt_frac) * & + varnce_sclr2(i) = ( alpha_sclr(i) / (one-mixt_frac) * & sclrp2(i) ) * width_factor_2 end if ! sclrp2(i) <= sclr_tol(i)**2 end do ! i=1, sclr_dim @@ -499,56 +527,55 @@ subroutine pdf_closure & ! We include sub-plume correlation with coeff rrtthl. - if ( varnce_rt1*varnce_thl1 > 0._core_rknd .and. & - varnce_rt2*varnce_thl2 > 0._core_rknd ) then - rrtthl = ( rtpthlp - mixt_frac * ( rt1-rtm ) * ( thl1-thlm ) & - - (1._core_rknd-mixt_frac) * ( rt2-rtm ) * ( thl2-thlm ) ) & - / ( mixt_frac*sqrt( varnce_rt1*varnce_thl1 ) & - + (1._core_rknd-mixt_frac)*sqrt( varnce_rt2*varnce_thl2 ) ) - if ( rrtthl < -1.0_core_rknd ) then - rrtthl = -1.0_core_rknd + if ( varnce_rt_1*varnce_thl_1 > 0._core_rknd .and. & + varnce_rt_2*varnce_thl_2 > 0._core_rknd ) then + rrtthl = ( rtpthlp - mixt_frac * ( rt_1-rtm ) * ( thl_1-thlm ) & + - (one-mixt_frac) * ( rt_2-rtm ) * ( thl_2-thlm ) ) & + / ( mixt_frac*sqrt( varnce_rt_1*varnce_thl_1 ) & + + (one-mixt_frac)*sqrt( varnce_rt_2*varnce_thl_2 ) ) + if ( rrtthl < -one ) then + rrtthl = -one end if - if ( rrtthl > 1.0_core_rknd ) then - rrtthl = 1.0_core_rknd + if ( rrtthl > one ) then + rrtthl = one end if else rrtthl = 0.0_core_rknd - end if ! varnce_rt1*varnce_thl1 > 0 .and. varnce_rt2*varnce_thl2 > 0 + end if ! varnce_rt_1*varnce_thl_1 > 0 .and. varnce_rt_2*varnce_thl_2 > 0 - ! Sub-plume correlation, rsclrthl, between passive scalar and theta_l. + ! Sub-plume correlation, rsclrthl, of passive scalar and theta_l. if ( l_scalar_calc ) then do i=1, sclr_dim - if ( varnce_sclr1(i)*varnce_thl1 > 0._core_rknd .and. & - varnce_sclr2(i)*varnce_thl2 > 0._core_rknd ) then + if ( varnce_sclr1(i)*varnce_thl_1 > 0._core_rknd .and. & + varnce_sclr2(i)*varnce_thl_2 > 0._core_rknd ) then rsclrthl(i) = ( sclrpthlp(i) & - - mixt_frac * ( sclr1(i)-sclrm(i) ) * ( thl1-thlm ) & - - (1._core_rknd-mixt_frac) * ( sclr2(i)-sclrm(i) ) * ( thl2-thlm ) ) & - / ( mixt_frac*sqrt( varnce_sclr1(i)*varnce_thl1 ) & - + (1._core_rknd-mixt_frac)*sqrt( varnce_sclr2(i)*varnce_thl2 ) ) - if ( rsclrthl(i) < -1.0_core_rknd ) then - rsclrthl(i) = -1.0_core_rknd + - mixt_frac * ( sclr1(i)-sclrm(i) ) * ( thl_1-thlm ) & + - (one-mixt_frac) * ( sclr2(i)-sclrm(i) ) * ( thl_2-thlm ) ) & + / ( mixt_frac*sqrt( varnce_sclr1(i)*varnce_thl_1 ) & + + (one-mixt_frac)*sqrt( varnce_sclr2(i)*varnce_thl_2 ) ) + if ( rsclrthl(i) < -one ) then + rsclrthl(i) = -one end if - if ( rsclrthl(i) > 1.0_core_rknd ) then - rsclrthl(i) = 1.0_core_rknd + if ( rsclrthl(i) > one ) then + rsclrthl(i) = one end if else rsclrthl(i) = 0.0_core_rknd end if - ! Sub-plume correlation, rsclrrt, between passive scalar - ! and total water. - - if ( varnce_sclr1(i)*varnce_rt1 > 0._core_rknd .and. & - varnce_sclr2(i)*varnce_rt2 > 0._core_rknd ) then - rsclrrt(i) = ( sclrprtp(i) - mixt_frac * ( sclr1(i)-sclrm(i) ) * ( rt1-rtm )& - - (1._core_rknd-mixt_frac) * ( sclr2(i)-sclrm(i) ) * ( rt2-rtm ) ) & - / ( mixt_frac*sqrt( varnce_sclr1(i)*varnce_rt1 ) & - + (1._core_rknd-mixt_frac)*sqrt( varnce_sclr2(i)*varnce_rt2 ) ) - if ( rsclrrt(i) < -1.0_core_rknd ) then - rsclrrt(i) = -1.0_core_rknd + ! Sub-plume correlation, rsclrrt, of passive scalar and total water. + + if ( varnce_sclr1(i)*varnce_rt_1 > 0._core_rknd .and. & + varnce_sclr2(i)*varnce_rt_2 > 0._core_rknd ) then + rsclrrt(i) = ( sclrprtp(i) - mixt_frac * ( sclr1(i)-sclrm(i) ) * ( rt_1-rtm )& + - (one-mixt_frac) * ( sclr2(i)-sclrm(i) ) * ( rt_2-rtm ) ) & + / ( mixt_frac*sqrt( varnce_sclr1(i)*varnce_rt_1 ) & + + (one-mixt_frac)*sqrt( varnce_sclr2(i)*varnce_rt_2 ) ) + if ( rsclrrt(i) < -one ) then + rsclrrt(i) = -one end if - if ( rsclrrt(i) > 1.0_core_rknd ) then - rsclrrt(i) = 1.0_core_rknd + if ( rsclrrt(i) > one ) then + rsclrrt(i) = one end if else rsclrrt(i) = 0.0_core_rknd @@ -559,35 +586,35 @@ subroutine pdf_closure & end if ! Widths non-zero ! Compute higher order moments (these are interactive) - wp2rtp = mixt_frac * ( (w1-wm)**2+varnce_w1 ) * ( rt1-rtm ) & - + (1._core_rknd-mixt_frac) * ( (w2-wm)**2+varnce_w2 ) * ( rt2-rtm ) + wp2rtp = mixt_frac * ( (w_1-wm)**2+varnce_w_1 ) * ( rt_1-rtm ) & + + (one-mixt_frac) * ( (w_2-wm)**2+varnce_w_2 ) * ( rt_2-rtm ) - wp2thlp = mixt_frac * ( (w1-wm)**2+varnce_w1 ) * ( thl1-thlm ) & - + (1._core_rknd-mixt_frac) * ( (w2-wm)**2+varnce_w2 ) * ( thl2-thlm ) + wp2thlp = mixt_frac * ( (w_1-wm)**2+varnce_w_1 ) * ( thl_1-thlm ) & + + (one-mixt_frac) * ( (w_2-wm)**2+varnce_w_2 ) * ( thl_2-thlm ) ! Compute higher order moments (these are non-interactive diagnostics) if ( iwp4 > 0 ) then - wp4 = mixt_frac * ( 3._core_rknd*varnce_w1**2 + & - 6._core_rknd*((w1-wm)**2)*varnce_w1 + (w1-wm)**4 ) & - + (1._core_rknd-mixt_frac) * ( 3._core_rknd*varnce_w2**2 + & - 6._core_rknd*((w2-wm)**2)*varnce_w2 + (w2-wm)**4 ) + wp4 = mixt_frac * ( 3._core_rknd*varnce_w_1**2 + & + 6._core_rknd*((w_1-wm)**2)*varnce_w_1 + (w_1-wm)**4 ) & + + (one-mixt_frac) * ( 3._core_rknd*varnce_w_2**2 + & + 6._core_rknd*((w_2-wm)**2)*varnce_w_2 + (w_2-wm)**4 ) end if if ( iwprtp2 > 0 ) then - wprtp2 = mixt_frac * ( w1-wm )*( (rt1-rtm)**2 + varnce_rt1 ) & - + (1._core_rknd-mixt_frac) * ( w2-wm )*( (rt2-rtm)**2 + varnce_rt2) + wprtp2 = mixt_frac * ( w_1-wm )*( (rt_1-rtm)**2 + varnce_rt_1 ) & + + (one-mixt_frac) * ( w_2-wm )*( (rt_2-rtm)**2 + varnce_rt_2) end if if ( iwpthlp2 > 0 ) then - wpthlp2 = mixt_frac * ( w1-wm )*( (thl1-thlm)**2 + varnce_thl1 ) & - + (1._core_rknd-mixt_frac) * ( w2-wm )*( (thl2-thlm)**2+varnce_thl2 ) + wpthlp2 = mixt_frac * ( w_1-wm )*( (thl_1-thlm)**2 + varnce_thl_1 ) & + + (one-mixt_frac) * ( w_2-wm )*( (thl_2-thlm)**2+varnce_thl_2 ) end if if ( iwprtpthlp > 0 ) then - wprtpthlp = mixt_frac * ( w1-wm )*( (rt1-rtm)*(thl1-thlm) & - + rrtthl*sqrt( varnce_rt1*varnce_thl1 ) ) & - + ( 1._core_rknd-mixt_frac ) * ( w2-wm )*( (rt2-rtm)*(thl2-thlm) & - + rrtthl*sqrt( varnce_rt2*varnce_thl2 ) ) + wprtpthlp = mixt_frac * ( w_1-wm )*( (rt_1-rtm)*(thl_1-thlm) & + + rrtthl*sqrt( varnce_rt_1*varnce_thl_1 ) ) & + + ( one-mixt_frac ) * ( w_2-wm )*( (rt_2-rtm)*(thl_2-thlm) & + + rrtthl*sqrt( varnce_rt_2*varnce_thl_2 ) ) end if @@ -595,23 +622,23 @@ subroutine pdf_closure & if ( l_scalar_calc ) then do i=1, sclr_dim - wp2sclrp(i) = mixt_frac * ( (w1-wm)**2+varnce_w1 )*( sclr1(i)-sclrm(i) ) & - + (1._core_rknd-mixt_frac) * ( (w2-wm)**2+varnce_w2 ) * ( sclr2(i)-sclrm(i) ) + wp2sclrp(i) = mixt_frac * ( (w_1-wm)**2+varnce_w_1 )*( sclr1(i)-sclrm(i) ) & + + (one-mixt_frac) * ( (w_2-wm)**2+varnce_w_2 ) * ( sclr2(i)-sclrm(i) ) - wpsclrp2(i) = mixt_frac * ( w1-wm ) * ( (sclr1(i)-sclrm(i))**2 + varnce_sclr1(i) ) & - + (1._core_rknd-mixt_frac) * ( w2-wm ) * & + wpsclrp2(i) = mixt_frac * ( w_1-wm ) * ( (sclr1(i)-sclrm(i))**2 + varnce_sclr1(i) ) & + + (one-mixt_frac) * ( w_2-wm ) * & ( (sclr2(i)-sclrm(i))**2 + varnce_sclr2(i) ) - wpsclrprtp(i) = mixt_frac * ( w1-wm ) * ( ( rt1-rtm )*( sclr1(i)-sclrm(i) ) & - + rsclrrt(i)*sqrt( varnce_rt1*varnce_sclr1(i) ) ) & - + ( 1._core_rknd-mixt_frac )*( w2-wm ) * & - ( ( rt2-rtm )*( sclr2(i)-sclrm(i) ) + rsclrrt(i)*sqrt( varnce_rt2*varnce_sclr2(i) ) ) + wpsclrprtp(i) = mixt_frac * ( w_1-wm ) * ( ( rt_1-rtm )*( sclr1(i)-sclrm(i) ) & + + rsclrrt(i)*sqrt( varnce_rt_1*varnce_sclr1(i) ) ) & + + ( one-mixt_frac )*( w_2-wm ) * & + ( ( rt_2-rtm )*( sclr2(i)-sclrm(i) ) + rsclrrt(i)*sqrt( varnce_rt_2*varnce_sclr2(i) ) ) - wpsclrpthlp(i) = mixt_frac * ( w1-wm ) * ( ( sclr1(i)-sclrm(i) )*( thl1-thlm ) & - + rsclrthl(i)*sqrt( varnce_sclr1(i)*varnce_thl1 ) ) & - + ( 1._core_rknd-mixt_frac ) * ( w2-wm ) * & - ( ( sclr2(i)-sclrm(i) )*( thl2-thlm ) & - + rsclrthl(i)*sqrt( varnce_sclr2(i)*varnce_thl2 ) ) + wpsclrpthlp(i) = mixt_frac * ( w_1-wm ) * ( ( sclr1(i)-sclrm(i) )*( thl_1-thlm ) & + + rsclrthl(i)*sqrt( varnce_sclr1(i)*varnce_thl_1 ) ) & + + ( one-mixt_frac ) * ( w_2-wm ) * & + ( ( sclr2(i)-sclrm(i) )*( thl_2-thlm ) & + + rsclrthl(i)*sqrt( varnce_sclr2(i)*varnce_thl_2 ) ) end do ! i=1, sclr_dim end if ! l_scalar_calc @@ -622,42 +649,46 @@ subroutine pdf_closure & ! "1" denotes first Gaussian; "2" denotes 2nd Gaussian ! liq water temp (Sommeria & Deardorff 1977 (SD), eqn. 3) - tl1 = thl1*exner - tl2 = thl2*exner + tl1 = thl_1*exner + tl2 = thl_2*exner #ifdef GFDL - if( sclr_dim > 0 ) then ! h1g, 2010-06-16 begin mod - - if( tl1 > 250.0_core_rknd) then - rsl1 = sat_mixrat_liq( p_in_Pa, tl1 ) + if( sclr_dim > 0 .and. (.not. do_liquid_only_in_clubb) ) then ! h1g, 2010-06-16 begin mod + + if( tl1 > t1_combined ) then + rsatl_1 = sat_mixrat_liq( p_in_Pa, tl1 ) + elseif( tl1 > t2_combined ) then + rsatl_1 = sat_mixrat_liq( p_in_Pa, tl1 ) * (tl1 - t2_combined)/(t1_combined - t2_combined) & + + sat_mixrat_ice( p_in_Pa, tl1 ) * (t1_combined - tl1)/(t1_combined - t2_combined) + elseif( tl1 > t3_combined ) then + rsatl_1 = sat_mixrat_ice( p_in_Pa, tl1 ) & + + sat_mixrat_ice( p_in_Pa, tl1 ) * (RH_crit(1, 1) -one ) & + * ( t2_combined -tl1)/(t2_combined - t3_combined) else - rsl1 = sat_mixrat_ice( p_in_Pa, tl1 ) - if( tl1 > 238.15_core_rknd) then - rsl1 = 1.2_core_rknd * rsl1 - else - rsl1 = RH_crit(1, 1) * rsl1 - endif + rsatl_1 = sat_mixrat_ice( p_in_Pa, tl1 ) * RH_crit(1, 1) endif - if( tl2 > 250.0_core_rknd) then - rsl2 = sat_mixrat_liq( p_in_Pa, tl2 ) + if( tl2 > t1_combined ) then + rsatl_2 = sat_mixrat_liq( p_in_Pa, tl2 ) + elseif( tl2 > t2_combined ) then + rsatl_2 = sat_mixrat_liq( p_in_Pa, tl2 ) * (tl2 - t2_combined)/(t1_combined - t2_combined) & + + sat_mixrat_ice( p_in_Pa, tl2 ) * (t1_combined - tl2)/(t1_combined - t2_combined) + elseif( tl2 > t3_combined ) then + rsatl_2 = sat_mixrat_ice( p_in_Pa, tl2 ) & + + sat_mixrat_ice( p_in_Pa, tl2 )* (RH_crit(1, 2) -one) & + * ( t2_combined -tl2)/(t2_combined - t3_combined) else - rsl2 = sat_mixrat_ice( p_in_Pa, tl2 ) - if( tl2 > 238.15_core_rknd) then - rsl2 = 1.2_core_rknd * rsl2 - else - rsl2 = RH_crit(1, 2)* rsl2 - endif + rsatl_2 = sat_mixrat_ice( p_in_Pa, tl2 ) * RH_crit(1, 2) endif - else !sclr_dim <= 0 - rsl1 = sat_mixrat_liq( p_in_Pa, tl1 ) - rsl2 = sat_mixrat_liq( p_in_Pa, tl2 ) + else !sclr_dim <= 0 or do_liquid_only_in_clubb = .T. + rsatl_1 = sat_mixrat_liq( p_in_Pa, tl1 ) + rsatl_2 = sat_mixrat_liq( p_in_Pa, tl2 ) endif !sclr_dim > 0 #else - rsl1 = sat_mixrat_liq( p_in_Pa, tl1 ) - rsl2 = sat_mixrat_liq( p_in_Pa, tl2 ) ! h1g, 2010-06-16 end mod + rsatl_1 = sat_mixrat_liq( p_in_Pa, tl1 ) + rsatl_2 = sat_mixrat_liq( p_in_Pa, tl2 ) ! h1g, 2010-06-16 end mod #endif ! SD's beta (eqn. 8) @@ -665,8 +696,8 @@ subroutine pdf_closure & beta2 = ep * ( Lv/(Rd*tl2) ) * ( Lv/(Cp*tl2) ) ! s from Lewellen and Yoh 1993 (LY) eqn. 1 - s1 = ( rt1 - rsl1 ) / ( 1._core_rknd + beta1 * rsl1 ) - s2 = ( rt2 - rsl2 ) / ( 1._core_rknd + beta2 * rsl2 ) + chi_1 = ( rt_1 - rsatl_1 ) / ( one + beta1 * rsatl_1 ) + chi_2 = ( rt_2 - rsatl_2 ) / ( one + beta2 * rsatl_2 ) ! Coefficients for s' ! For each normal distribution in the sum of two normal distributions, @@ -674,65 +705,121 @@ subroutine pdf_closure & ! therefore, x's' = crt * x'rt' + cthl * x'thl'. ! Larson et al. May, 2001. - crt1 = 1._core_rknd/( 1._core_rknd + beta1*rsl1) - crt2 = 1._core_rknd/( 1._core_rknd + beta2*rsl2) + crt_1 = one/( one + beta1*rsatl_1) + crt_2 = one/( one + beta2*rsatl_2) - cthl1 = ( (1._core_rknd + beta1 * rt1) / ( 1._core_rknd + beta1*rsl1)**2 ) & - * ( Cp/Lv ) * beta1 * rsl1 * exner - cthl2 = ( (1._core_rknd + beta2 * rt2) / ( 1._core_rknd + beta2*rsl2 )**2 ) & - * ( Cp/Lv ) * beta2 * rsl2 * exner + cthl_1 = ( (one + beta1 * rt_1) / ( one + beta1*rsatl_1)**2 ) & + * ( Cp/Lv ) * beta1 * rsatl_1 * exner + cthl_2 = ( (one + beta2 * rt_2) / ( one + beta2*rsatl_2 )**2 ) & + * ( Cp/Lv ) * beta2 * rsatl_2 * exner - ! Standard deviation of s - ! include subplume correlation of qt, thl + ! Standard deviation of chi for each component. + ! Include subplume correlation of qt, thl ! Because of round-off error, - ! stdev_s1 (and probably stdev_s2) can become negative when rrtthl=1 + ! stdev_chi_1 (and probably stdev_chi_2) can become negative when rrtthl=1 ! One could also write this as a squared term ! plus a postive correction; this might be a neater format + stdev_chi_1 = sqrt( max( crt_1**2 * varnce_rt_1 & + - two * rrtthl * crt_1 * cthl_1 & + * sqrt( varnce_rt_1 * varnce_thl_1 ) & + + cthl_1**2 * varnce_thl_1, & + zero_threshold ) ) + + stdev_chi_2 = sqrt( max( crt_2**2 * varnce_rt_2 & + - two * rrtthl * crt_2 * cthl_2 & + * sqrt( varnce_rt_2 * varnce_thl_2 ) & + + cthl_2**2 * varnce_thl_2, & + zero_threshold ) ) + + ! We need to introduce a threshold value for the variance of chi + if ( stdev_chi_1 <= chi_tol ) then + ! Treat chi as a delta function in this component. + stdev_chi_1 = zero + end if + + if ( stdev_chi_2 <= chi_tol ) then + ! Treat chi as a delta function in this component. + stdev_chi_2 = zero + end if - stdev_s1 = sqrt( max( zero_threshold, ( varnce_rt1*crt1**2 + varnce_thl1*cthl1**2 & - - 2.0_core_rknd*rrtthl*crt1*sqrt( varnce_rt1*varnce_thl1 )*cthl1 ) & - ) & ! max - ) ! sqrt - stdev_s2 = sqrt( max( zero_threshold, ( varnce_rt2*crt2**2 + varnce_thl2*cthl2**2 & - - 2.0_core_rknd*rrtthl*crt2*sqrt( varnce_rt2*varnce_thl2 )*cthl2 ) & - ) & ! max - ) ! sqrt + ! Standard deviation of eta for each component. + stdev_eta_1 = sqrt( max( crt_1**2 * varnce_rt_1 & + + two * rrtthl * crt_1 * cthl_1 & + * sqrt( varnce_rt_1 * varnce_thl_1 ) & + + cthl_1**2 * varnce_thl_1, & + zero_threshold ) ) -! stdev_s1 = sqrt( (sqrt(varnce_rt1)*crt1 - sqrt(varnce_thl1)*cthl1)**2 & -! + (1.-rrtthl)*2.*crt1*sqrt(varnce_rt1)*cthl1*sqrt(varnce_thl1) ) -! stdev_s2 = sqrt( (sqrt(varnce_rt2)*crt2 - sqrt(varnce_thl2)*cthl2)**2 & -! + (1.-rrtthl)*2.*crt2*sqrt(varnce_rt2)*cthl2*sqrt(varnce_thl2) ) + stdev_eta_2 = sqrt( max( crt_2**2 * varnce_rt_2 & + + two * rrtthl * crt_2 * cthl_2 & + * sqrt( varnce_rt_2 * varnce_thl_2 ) & + + cthl_2**2 * varnce_thl_2, & + zero_threshold ) ) + ! Covariance of chi and eta for each component. + covar_chi_eta_1 = crt_1**2 * varnce_rt_1 - cthl_1**2 * varnce_thl_1 - ! We need to introduce a threshold value for the variance of s + covar_chi_eta_2 = crt_2**2 * varnce_rt_2 - cthl_2**2 * varnce_thl_2 - if ( stdev_s1 > s_mellor_tol ) then - zeta1 = s1/stdev_s1 - cloud_frac1 = 0.5_core_rknd*( 1._core_rknd + erf( zeta1/sqrt_2 ) ) - rc1 = s1*cloud_frac1+stdev_s1*exp( -0.5_core_rknd*zeta1**2 )/( sqrt_2pi ) + ! Correlation of chi and eta for each component. + if ( stdev_chi_1 * stdev_eta_1 > zero ) then + corr_chi_eta_1 = covar_chi_eta_1 / ( stdev_chi_1 * stdev_eta_1 ) else - if ( s1 < 0.0_core_rknd ) then - cloud_frac1 = 0.0_core_rknd - rc1 = 0.0_core_rknd - else - cloud_frac1 = 1.0_core_rknd - rc1 = s1 - end if ! s1 < 0 - end if ! stdev_s1 > s_mellor_tol - - if ( stdev_s2 > s_mellor_tol ) then - zeta2 = s2/stdev_s2 - cloud_frac2 = 0.5_core_rknd*( 1._core_rknd + erf( zeta2/sqrt_2 ) ) - rc2 = s2*cloud_frac2+stdev_s2*exp( -0.5_core_rknd*zeta2**2 )/( sqrt_2pi ) + corr_chi_eta_1 = zero + endif + + if ( stdev_chi_2 * stdev_eta_2 > zero ) then + corr_chi_eta_2 = covar_chi_eta_2 / ( stdev_chi_2 * stdev_eta_2 ) + else + corr_chi_eta_2 = zero + endif + + ! Determine whether to compute ice_supersat_frac. We do not compute + ! ice_supersat_frac for GFDL (unless do_liquid_only_in_clubb is true), + ! because liquid and ice are both fed into rtm, ruining the calculation. +#ifdef GFDL + if (do_liquid_only_in_clubb) then + l_calc_ice_supersat_frac = .true. else - if ( s2 < 0.0_core_rknd ) then - cloud_frac2 = 0.0_core_rknd - rc2 = 0.0_core_rknd + l_calc_ice_supersat_frac = .false. + end if +#else + l_calc_ice_supersat_frac = .true. +#endif + + ! Calculate cloud_frac_1 and rc_1 + call calc_cloud_frac_component(chi_1, stdev_chi_1, chi_at_liq_sat, cloud_frac_1, rc_1) + + ! Calculate cloud_frac_2 and rc_2 + call calc_cloud_frac_component(chi_2, stdev_chi_2, chi_at_liq_sat, cloud_frac_2, rc_2) + + if ( l_calc_ice_supersat_frac ) then + ! We must compute chi_at_ice_sat1 and chi_at_ice_sat2 + if (tl1 <= T_freeze_K) then + rt_at_ice_sat1 = sat_mixrat_ice( p_in_Pa, tl1 ) + chi_at_ice_sat1 = ( rt_at_ice_sat1 - rsatl_1 ) / ( one + beta1 * rsatl_1 ) else - cloud_frac2 = 1.0_core_rknd - rc2 = s2 - end if ! s2 < 0 - end if ! stdev_s2 > s_mellor_tol + ! If the temperature is warmer than freezing (> 0C) then ice_supersat_frac + ! is not defined, so we use chi_at_liq_sat + chi_at_ice_sat1 = chi_at_liq_sat + end if + + if (tl2 <= T_freeze_K) then + rt_at_ice_sat2 = sat_mixrat_ice( p_in_Pa, tl2 ) + chi_at_ice_sat2 = ( rt_at_ice_sat2 - rsatl_2 ) / ( one + beta2 * rsatl_2 ) + else + ! If the temperature is warmer than freezing (> 0C) then ice_supersat_frac + ! is not defined, so we use chi_at_liq_sat + chi_at_ice_sat2 = chi_at_liq_sat + end if + + ! Calculate ice_supersat_frac1 + call calc_cloud_frac_component( chi_1, stdev_chi_1, chi_at_ice_sat1, & + ice_supersat_frac1, rc_1_ice ) + + ! Calculate ice_supersat_frac2 + call calc_cloud_frac_component( chi_2, stdev_chi_2, chi_at_ice_sat2, & + ice_supersat_frac2, rc_2_ice ) + end if ! Compute moments that depend on theta_v ! @@ -751,159 +838,139 @@ subroutine pdf_closure & rc_coef = Lv / (exner*Cp) - ep2 * thv_ds - wp2rcp = mixt_frac * ((w1-wm)**2 + varnce_w1)*rc1 & - + (1._core_rknd-mixt_frac) * ((w2-wm)**2 + varnce_w2)*rc2 & - - wp2 * (mixt_frac*rc1+(1._core_rknd-mixt_frac)*rc2) + wp2rxp = zero + wprxp = zero + thlprxp = zero + rtprxp = zero + if ( l_liq_ice_loading_test ) then + do hm_idx = 1, hydromet_dim, 1 + if ( l_mix_rat_hm(hm_idx) ) then + wp2rxp = wp2rxp + wp2hmp(hm_idx) + wprxp = wprxp + wphydrometp(hm_idx) + thlprxp = thlprxp + thlphmp(hm_idx) + rtprxp = rtprxp + rtphmp(hm_idx) + endif + enddo ! hm_idx = 1, hydromet_dim, 1 + endif ! l_liq_ice_loading_test - wp2thvp = wp2thlp + ep1*thv_ds*wp2rtp + rc_coef*wp2rcp + wp2rcp = mixt_frac * ((w_1-wm)**2 + varnce_w_1)*rc_1 & + + (one-mixt_frac) * ((w_2-wm)**2 + varnce_w_2)*rc_2 & + - wp2 * (mixt_frac*rc_1+(one-mixt_frac)*rc_2) - wprcp = mixt_frac * (w1-wm)*rc1 + (1._core_rknd-mixt_frac) * (w2-wm)*rc2 + wp2thvp = wp2thlp + ep1*thv_ds*wp2rtp + rc_coef*wp2rcp - thv_ds * wp2rxp - wpthvp = wpthlp + ep1*thv_ds*wprtp + rc_coef*wprcp + wprcp = mixt_frac * (w_1-wm)*rc_1 + (one-mixt_frac) * (w_2-wm)*rc_2 + + wpthvp = wpthlp + ep1*thv_ds*wprtp + rc_coef*wprcp - thv_ds * wprxp ! Account for subplume correlation in qt-thl - thlprcp = mixt_frac * ( (thl1-thlm)*rc1 - (cthl1*varnce_thl1)*cloud_frac1 ) & - + (1._core_rknd-mixt_frac) * ( (thl2-thlm)*rc2 - (cthl2*varnce_thl2)*cloud_frac2 ) & - + mixt_frac*rrtthl*crt1*sqrt( varnce_rt1*varnce_thl1 )*cloud_frac1 & - + (1._core_rknd-mixt_frac)*rrtthl*crt2*sqrt( varnce_rt2*varnce_thl2 )*cloud_frac2 - thlpthvp = thlp2 + ep1*thv_ds*rtpthlp + rc_coef*thlprcp + thlprcp = mixt_frac * ( (thl_1-thlm)*rc_1 - (cthl_1*varnce_thl_1)*cloud_frac_1 ) & + + (one-mixt_frac) * ( (thl_2-thlm)*rc_2 - (cthl_2*varnce_thl_2)*cloud_frac_2 ) & + + mixt_frac*rrtthl*crt_1*sqrt( varnce_rt_1*varnce_thl_1 )*cloud_frac_1 & + + (one-mixt_frac)*rrtthl*crt_2*sqrt( varnce_rt_2*varnce_thl_2 )*cloud_frac_2 + thlpthvp = thlp2 + ep1*thv_ds*rtpthlp + rc_coef*thlprcp - thv_ds * thlprxp ! Account for subplume correlation in qt-thl - rtprcp = mixt_frac * ( (rt1-rtm)*rc1 + (crt1*varnce_rt1)*cloud_frac1 ) & - + (1._core_rknd-mixt_frac) * ( (rt2-rtm)*rc2 + (crt2*varnce_rt2)*cloud_frac2 ) & - - mixt_frac*rrtthl*cthl1*sqrt( varnce_rt1*varnce_thl1 )*cloud_frac1 & - - (1._core_rknd-mixt_frac)*rrtthl*cthl2*sqrt( varnce_rt2*varnce_thl2 )*cloud_frac2 + rtprcp = mixt_frac * ( (rt_1-rtm)*rc_1 + (crt_1*varnce_rt_1)*cloud_frac_1 ) & + + (one-mixt_frac) * ( (rt_2-rtm)*rc_2 + (crt_2*varnce_rt_2)*cloud_frac_2 ) & + - mixt_frac*rrtthl*cthl_1*sqrt( varnce_rt_1*varnce_thl_1 )*cloud_frac_1 & + - (one-mixt_frac)*rrtthl*cthl_2*sqrt( varnce_rt_2*varnce_thl_2 )*cloud_frac_2 - rtpthvp = rtpthlp + ep1*thv_ds*rtp2 + rc_coef*rtprcp + rtpthvp = rtpthlp + ep1*thv_ds*rtp2 + rc_coef*rtprcp - thv_ds * rtprxp - ! Account for subplume correlation between scalar, theta_v. + ! Account for subplume correlation of scalar, theta_v. ! See Eqs. A13, A8 from Larson et al. (2002) ``Small-scale...'' ! where the ``scalar'' in this paper is w. if ( l_scalar_calc ) then do i=1, sclr_dim sclrprcp(i) & - = mixt_frac * ( ( sclr1(i)-sclrm(i) ) * rc1 ) & - + (1._core_rknd-mixt_frac) * ( ( sclr2(i)-sclrm(i) ) * rc2 ) & - + mixt_frac*rsclrrt(i) * crt1 & - * sqrt( varnce_sclr1(i) * varnce_rt1 ) * cloud_frac1 & - + (1._core_rknd-mixt_frac) * rsclrrt(i) * crt2 & - * sqrt( varnce_sclr2(i) * varnce_rt2 ) * cloud_frac2 & - - mixt_frac * rsclrthl(i) * cthl1 & - * sqrt( varnce_sclr1(i) * varnce_thl1 ) * cloud_frac1 & - - (1._core_rknd-mixt_frac) * rsclrthl(i) * cthl2 & - * sqrt( varnce_sclr2(i) * varnce_thl2 ) * cloud_frac2 + = mixt_frac * ( ( sclr1(i)-sclrm(i) ) * rc_1 ) & + + (one-mixt_frac) * ( ( sclr2(i)-sclrm(i) ) * rc_2 ) & + + mixt_frac*rsclrrt(i) * crt_1 & + * sqrt( varnce_sclr1(i) * varnce_rt_1 ) * cloud_frac_1 & + + (one-mixt_frac) * rsclrrt(i) * crt_2 & + * sqrt( varnce_sclr2(i) * varnce_rt_2 ) * cloud_frac_2 & + - mixt_frac * rsclrthl(i) * cthl_1 & + * sqrt( varnce_sclr1(i) * varnce_thl_1 ) * cloud_frac_1 & + - (one-mixt_frac) * rsclrthl(i) * cthl_2 & + * sqrt( varnce_sclr2(i) * varnce_thl_2 ) * cloud_frac_2 sclrpthvp(i) = sclrpthlp(i) + ep1*thv_ds*sclrprtp(i) + rc_coef*sclrprcp(i) end do ! i=1, sclr_dim end if ! l_scalar_calc ! Compute mean cloud fraction and cloud water - - cloud_frac = mixt_frac * cloud_frac1 + (1._core_rknd-mixt_frac) * cloud_frac2 - rcm = mixt_frac * rc1 + (1._core_rknd-mixt_frac) * rc2 - - ! Note: Brian added the following lines to ensure that there - ! are never any negative liquid water values (or any negative - ! cloud fraction values, for that matter). According to - ! Vince Larson, the analytic formula should not produce any - ! negative results, but such computer-induced errors such as - ! round-off error may produce such a value. This has been - ! corrected because Brian found a small negative value of - ! rcm in the first timestep of the FIRE case. - - cloud_frac = max( zero_threshold, cloud_frac ) - if ( clubb_at_least_debug_level( 2 ) ) then - if ( cloud_frac > 1.0_core_rknd ) then - write(fstderr,*) "Cloud fraction > 1" + cloud_frac = calc_cloud_frac(cloud_frac_1, cloud_frac_2, mixt_frac) + rcm = mixt_frac * rc_1 + (one-mixt_frac) * rc_2 + + rcm = max( zero_threshold, rcm ) + + if (l_calc_ice_supersat_frac) then + ! Compute ice cloud fraction, ice_supersat_frac + ice_supersat_frac = calc_cloud_frac(ice_supersat_frac1, ice_supersat_frac2, mixt_frac) + else + ! ice_supersat_frac will be garbage if computed as above + ice_supersat_frac = 0.0_core_rknd + if (clubb_at_least_debug_level( 1 )) then + write(fstderr,*) "Warning: ice_supersat_frac has garbage values if & + & do_liquid_only_in_clubb = .false." end if end if - cloud_frac = min( 1.0_core_rknd, cloud_frac ) - - rcm = max( zero_threshold, rcm ) - ! Compute variance of liquid water mixing ratio. ! This is not needed for closure. Statistical Analysis only. -#ifndef CLUBB_CAM ! if CLUBB is used in CAM we want this variable computed no matter what + +#ifndef CLUBB_CAM + ! if CLUBB is used in CAM we want this variable computed no matter what if ( ircp2 > 0 ) then #endif - rcp2 = mixt_frac * ( s1*rc1 + cloud_frac1*stdev_s1**2 ) & - + ( 1._core_rknd-mixt_frac ) * ( s2*rc2 + cloud_frac2*stdev_s2**2 ) - rcm**2 + rcp2 = mixt_frac * ( chi_1*rc_1 + cloud_frac_1*stdev_chi_1**2 ) & + + ( one-mixt_frac ) * ( chi_2*rc_2 + cloud_frac_2*stdev_chi_2**2 ) - rcm**2 rcp2 = max( zero_threshold, rcp2 ) -#ifndef CLUBB_CAM ! if CLUBB is used in CAM we want this variable computed no matter what + +#ifndef CLUBB_CAM + ! if CLUBB is used in CAM we want this variable computed no matter what end if #endif - ! Compute some diagnostics related to the s and t variables - if ( l_corr_calc ) then - if ( icorr_st_mellor1 > 0 .or. isptp_mellor_1 > 0 .or. itp2_mellor_1 > 0 ) then - sptp_mellor_1 = crt1**2 * varnce_rt1 - cthl1**2 * varnce_thl1 - tp2_mellor_1 = crt1**2 * varnce_rt1 + 2.0_core_rknd * crt1 * cthl1 & - * rrtthl * sqrt( varnce_rt1 * varnce_thl1 ) & - + varnce_thl1 * cthl1**2 - - ! We found that in some cases when rrtthl is -1 exactly the tp2_mellor_1 can be - ! negative. Therefore we clip the result here. - stdev_s_times_stdev_t = sqrt( max( tp2_mellor_1, zero_threshold ) ) * stdev_s1 - - if ( stdev_s_times_stdev_t > 0._core_rknd ) then - corr_st_mellor1 = sptp_mellor_1 / stdev_s_times_stdev_t - else - corr_st_mellor1 = 0._core_rknd - end if - - end if - - if ( icorr_st_mellor2 > 0 .or. isptp_mellor_2 > 0 .or. itp2_mellor_2 > 0 ) then - sptp_mellor_2 = crt2**2 * varnce_rt2 - cthl2**2 * varnce_thl2 - tp2_mellor_2 = crt2**2 * varnce_rt2 + 2.0_core_rknd * crt2 * cthl2 & - * rrtthl * sqrt( varnce_rt2 * varnce_thl2 ) & - + varnce_thl2 * cthl2**2 - - ! See comment above about clipping. - stdev_s_times_stdev_t = sqrt( max( tp2_mellor_2, zero_threshold ) ) * stdev_s2 - - if ( stdev_s_times_stdev_t > 0._core_rknd ) then - corr_st_mellor2 = sptp_mellor_2 / stdev_s_times_stdev_t - else - corr_st_mellor2 = 0._core_rknd - end if - - end if - end if ! l_corr_calc - ! Save PDF parameters - pdf_params%w1 = w1 - pdf_params%w2 = w2 - pdf_params%varnce_w1 = varnce_w1 - pdf_params%varnce_w2 = varnce_w2 - pdf_params%rt1 = rt1 - pdf_params%rt2 = rt2 - pdf_params%varnce_rt1 = varnce_rt1 - pdf_params%varnce_rt2 = varnce_rt2 - pdf_params%crt1 = crt1 - pdf_params%crt2 = crt2 - pdf_params%cthl1 = cthl1 - pdf_params%cthl2 = cthl2 - pdf_params%thl1 = thl1 - pdf_params%thl2 = thl2 - pdf_params%varnce_thl1 = varnce_thl1 - pdf_params%varnce_thl2 = varnce_thl2 - pdf_params%mixt_frac = mixt_frac - pdf_params%rc1 = rc1 - pdf_params%rc2 = rc2 - pdf_params%rsl1 = rsl1 - pdf_params%rsl2 = rsl2 - pdf_params%cloud_frac1 = cloud_frac1 - pdf_params%cloud_frac2 = cloud_frac2 - pdf_params%s1 = s1 - pdf_params%s2 = s2 - pdf_params%stdev_s1 = stdev_s1 - pdf_params%stdev_s2 = stdev_s2 - pdf_params%rrtthl = rrtthl - pdf_params%alpha_thl = alpha_thl - pdf_params%alpha_rt = alpha_rt + pdf_params%w_1 = w_1 + pdf_params%w_2 = w_2 + pdf_params%varnce_w_1 = varnce_w_1 + pdf_params%varnce_w_2 = varnce_w_2 + pdf_params%rt_1 = rt_1 + pdf_params%rt_2 = rt_2 + pdf_params%varnce_rt_1 = varnce_rt_1 + pdf_params%varnce_rt_2 = varnce_rt_2 + pdf_params%thl_1 = thl_1 + pdf_params%thl_2 = thl_2 + pdf_params%varnce_thl_1 = varnce_thl_1 + pdf_params%varnce_thl_2 = varnce_thl_2 + pdf_params%rrtthl = rrtthl + pdf_params%alpha_thl = alpha_thl + pdf_params%alpha_rt = alpha_rt + pdf_params%crt_1 = crt_1 + pdf_params%crt_2 = crt_2 + pdf_params%cthl_1 = cthl_1 + pdf_params%cthl_2 = cthl_2 + pdf_params%chi_1 = chi_1 + pdf_params%chi_2 = chi_2 + pdf_params%stdev_chi_1 = stdev_chi_1 + pdf_params%stdev_chi_2 = stdev_chi_2 + pdf_params%stdev_eta_1 = stdev_eta_1 + pdf_params%stdev_eta_2 = stdev_eta_2 + pdf_params%covar_chi_eta_1 = covar_chi_eta_1 + pdf_params%covar_chi_eta_2 = covar_chi_eta_2 + pdf_params%corr_chi_eta_1 = corr_chi_eta_1 + pdf_params%corr_chi_eta_2 = corr_chi_eta_2 + pdf_params%rsatl_1 = rsatl_1 + pdf_params%rsatl_2 = rsatl_2 + pdf_params%rc_1 = rc_1 + pdf_params%rc_2 = rc_2 + pdf_params%cloud_frac_1 = cloud_frac_1 + pdf_params%cloud_frac_2 = cloud_frac_2 + pdf_params%mixt_frac = mixt_frac if ( clubb_at_least_debug_level( 2 ) ) then @@ -913,15 +980,15 @@ subroutine pdf_closure & wp2thlp, cloud_frac, rcm, wpthvp, wp2thvp, & rtpthvp, thlpthvp, wprcp, wp2rcp, & rtprcp, thlprcp, rcp2, wprtpthlp, & - crt1, crt2, cthl1, cthl2, pdf_params, & - err_code, & + crt_1, crt_2, cthl_1, cthl_2, pdf_params, & sclrpthvp, sclrprcp, wpsclrp2, & - wpsclrprtp, wpsclrpthlp, wp2sclrp ) + wpsclrprtp, wpsclrpthlp, wp2sclrp, & + err_code ) ! Error Reporting ! Joshua Fasching February 2008 - if ( err_code == clubb_var_equals_NaN ) then + if ( fatal_error( err_code ) ) then write(fstderr,*) "Error in pdf_closure_new" @@ -959,6 +1026,7 @@ subroutine pdf_closure & write(fstderr,*) "wp2rtp = ", wp2rtp write(fstderr,*) "wpthlp2 = ", wpthlp2 write(fstderr,*) "cloud_frac = ", cloud_frac + write(fstderr,*) "ice_supersat_frac = ", ice_supersat_frac write(fstderr,*) "rcm = ", rcm write(fstderr,*) "wpthvp = ", wpthvp write(fstderr,*) "wp2thvp = ", wp2thvp @@ -970,36 +1038,42 @@ subroutine pdf_closure & write(fstderr,*) "thlprcp = ", thlprcp write(fstderr,*) "rcp2 = ", rcp2 write(fstderr,*) "wprtpthlp = ", wprtpthlp - write(fstderr,*) "crt1 = ", crt1 - write(fstderr,*) "crt2 = ", crt2 - write(fstderr,*) "cthl1 = ", cthl1 - write(fstderr,*) "cthl2 = ", cthl2 - write(fstderr,*) "pdf_params%w1 = ", pdf_params%w1 - write(fstderr,*) "pdf_params%w2 = ", pdf_params%w2 - write(fstderr,*) "pdf_params%varnce_w1 = ", pdf_params%varnce_w1 - write(fstderr,*) "pdf_params%varnce_w2 = ", pdf_params%varnce_w2 - write(fstderr,*) "pdf_params%rt1 = ", pdf_params%rt1 - write(fstderr,*) "pdf_params%rt2 = ", pdf_params%rt2 - write(fstderr,*) "pdf_params%varnce_rt1 = ", pdf_params%varnce_rt1 - write(fstderr,*) "pdf_params%varnce_rt2 = ", pdf_params%varnce_rt2 - write(fstderr,*) "pdf_params%thl1 = ", pdf_params%thl1 - write(fstderr,*) "pdf_params%thl2 = ", pdf_params%thl2 - write(fstderr,*) "pdf_params%varnce_thl1 = ", pdf_params%varnce_thl1 - write(fstderr,*) "pdf_params%varnce_thl2 = ", pdf_params%varnce_thl2 - write(fstderr,*) "pdf_params%mixt_frac = ", pdf_params%mixt_frac + write(fstderr,*) "pdf_params%w_1 = ", pdf_params%w_1 + write(fstderr,*) "pdf_params%w_2 = ", pdf_params%w_2 + write(fstderr,*) "pdf_params%varnce_w_1 = ", pdf_params%varnce_w_1 + write(fstderr,*) "pdf_params%varnce_w_2 = ", pdf_params%varnce_w_2 + write(fstderr,*) "pdf_params%rt_1 = ", pdf_params%rt_1 + write(fstderr,*) "pdf_params%rt_2 = ", pdf_params%rt_2 + write(fstderr,*) "pdf_params%varnce_rt_1 = ", pdf_params%varnce_rt_1 + write(fstderr,*) "pdf_params%varnce_rt_2 = ", pdf_params%varnce_rt_2 + write(fstderr,*) "pdf_params%thl_1 = ", pdf_params%thl_1 + write(fstderr,*) "pdf_params%thl_2 = ", pdf_params%thl_2 + write(fstderr,*) "pdf_params%varnce_thl_1 = ", pdf_params%varnce_thl_1 + write(fstderr,*) "pdf_params%varnce_thl_2 = ", pdf_params%varnce_thl_2 write(fstderr,*) "pdf_params%rrtthl = ", pdf_params%rrtthl - write(fstderr,*) "pdf_params%rc1 = ", pdf_params%rc1 - write(fstderr,*) "pdf_params%rc2 = ", pdf_params%rc2 - write(fstderr,*) "pdf_params%rsl1 = ", pdf_params%rsl1 - write(fstderr,*) "pdf_params%rsl2 = ", pdf_params%rsl2 - write(fstderr,*) "pdf_params%cloud_frac1 = ", pdf_params%cloud_frac1 - write(fstderr,*) "pdf_params%cloud_frac2 = ", pdf_params%cloud_frac2 - write(fstderr,*) "pdf_params%s1 = ", pdf_params%s1 - write(fstderr,*) "pdf_params%s2 = ", pdf_params%s2 - write(fstderr,*) "pdf_params%stdev_s1 = ", pdf_params%stdev_s1 - write(fstderr,*) "pdf_params%stdev_s2 = ", pdf_params%stdev_s2 write(fstderr,*) "pdf_params%alpha_thl = ", pdf_params%alpha_thl write(fstderr,*) "pdf_params%alpha_rt = ", pdf_params%alpha_rt + write(fstderr,*) "pdf_params%crt_1 = ", pdf_params%crt_1 + write(fstderr,*) "pdf_params%crt_2 = ", pdf_params%crt_2 + write(fstderr,*) "pdf_params%cthl_1 = ", pdf_params%cthl_1 + write(fstderr,*) "pdf_params%cthl_2 = ", pdf_params%cthl_2 + write(fstderr,*) "pdf_params%chi_1 = ", pdf_params%chi_1 + write(fstderr,*) "pdf_params%chi_2 = ", pdf_params%chi_2 + write(fstderr,*) "pdf_params%stdev_chi_1 = ", pdf_params%stdev_chi_1 + write(fstderr,*) "pdf_params%stdev_chi_2 = ", pdf_params%stdev_chi_2 + write(fstderr,*) "pdf_params%stdev_eta_1 = ", pdf_params%stdev_eta_1 + write(fstderr,*) "pdf_params%stdev_eta_2 = ", pdf_params%stdev_eta_2 + write(fstderr,*) "pdf_params%covar_chi_eta_1 = ", pdf_params%covar_chi_eta_1 + write(fstderr,*) "pdf_params%covar_chi_eta_2 = ", pdf_params%covar_chi_eta_2 + write(fstderr,*) "pdf_params%corr_chi_eta_1 = ", pdf_params%corr_chi_eta_1 + write(fstderr,*) "pdf_params%corr_chi_eta_2 = ", pdf_params%corr_chi_eta_2 + write(fstderr,*) "pdf_params%rsatl_1 = ", pdf_params%rsatl_1 + write(fstderr,*) "pdf_params%rsatl_2 = ", pdf_params%rsatl_2 + write(fstderr,*) "pdf_params%rc_1 = ", pdf_params%rc_1 + write(fstderr,*) "pdf_params%rc_2 = ", pdf_params%rc_2 + write(fstderr,*) "pdf_params%cloud_frac_1 = ", pdf_params%cloud_frac_1 + write(fstderr,*) "pdf_params%cloud_frac_2 = ", pdf_params%cloud_frac_2 + write(fstderr,*) "pdf_params%mixt_frac = ", pdf_params%mixt_frac if ( sclr_dim > 0 )then write(fstderr,*) "sclrpthvp = ", sclrpthvp @@ -1010,11 +1084,517 @@ subroutine pdf_closure & write(fstderr,*) "wp2sclrp = ", wp2sclrp end if - end if ! err_code == clubb_var_equals_NaN + end if ! Fatal error end if ! clubb_at_least_debug_level return end subroutine pdf_closure + + !============================================================================= + elemental subroutine calc_cloud_frac_component( mean_chi_i, stdev_chi_i, & + chi_at_sat, & + cloud_frac_i, rc_i ) + + ! Description: + ! Calculates the PDF component cloud water mixing ratio, rc_i, and cloud + ! fraction, cloud_frac_i, for the ith PDF component. + ! + ! The equation for cloud water mixing ratio, rc, at any point is: + ! + ! rc = chi * H(chi); + ! + ! and the equation for cloud fraction at a point, fc, is: + ! + ! fc = H(chi); + ! + ! where where extended liquid water mixing ratio, chi, is equal to cloud + ! water mixing ratio, rc, when positive. When the atmosphere is saturated + ! at this point, cloud water is found, and rc = chi, while fc = 1. + ! Otherwise, clear air is found at this point, and rc = fc = 0. + ! + ! The mean of rc and fc is calculated by integrating over the PDF, such + ! that: + ! + ! = INT(-inf:inf) chi * H(chi) * P(chi) dchi; and + ! + ! cloud_frac = = INT(-inf:inf) H(chi) * P(chi) dchi. + ! + ! This can be rewritten as: + ! + ! = INT(0:inf) chi * P(chi) dchi; and + ! + ! cloud_frac = = INT(0:inf) P(chi) dchi; + ! + ! and further rewritten as: + ! + ! = SUM(i=1,N) mixt_frac_i INT(0:inf) chi * P_i(chi) dchi; and + ! + ! cloud_frac = SUM(i=1,N) mixt_frac_i INT(0:inf) P_i(chi) dchi; + ! + ! where N is the number of PDF components. The equation for mean rc in the + ! ith PDF component is: + ! + ! rc_i = INT(0:inf) chi * P_i(chi) dchi; + ! + ! and the equation for cloud fraction in the ith PDF component is: + ! + ! cloud_frac_i = INT(0:inf) P_i(chi) dchi. + ! + ! The component values are related to the overall values by: + ! + ! = SUM(i=1,N) mixt_frac_i * rc_i; and + ! + ! cloud_frac = SUM(i=1,N) mixt_frac_i * cloud_frac_i. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + chi_tol, & ! Tolerance for pdf parameter chi [kg/kg] + sqrt_2pi, & ! sqrt(2*pi) + sqrt_2, & ! sqrt(2) + one, & ! 1 + one_half, & ! 1/2 + zero ! 0 + + use anl_erf, only: & + erf ! Procedure(s) -- The error function + + use clubb_precision, only: & + core_rknd ! Precision + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + mean_chi_i, & ! Mean of chi (old s) (ith PDF component) [kg/kg] + stdev_chi_i, & ! Standard deviation of chi (ith PDF component) [kg/kg] + chi_at_sat ! Value of chi at saturation (0--liquid; neg.--ice) [kg/kg] + + ! Output Variables + real( kind = core_rknd ), intent(out) :: & + cloud_frac_i, & ! Cloud fraction (ith PDF component) [-] + rc_i ! Mean cloud water mixing ratio (ith PDF comp.) [kg/kg] + + ! Local Variables + real( kind = core_rknd) :: zeta_i + + !----- Begin Code ----- + if ( stdev_chi_i > chi_tol ) then + + ! The value of chi varies in the ith PDF component. + + zeta_i = ( mean_chi_i - chi_at_sat ) / stdev_chi_i + + cloud_frac_i = one_half * ( one + erf( zeta_i / sqrt_2 ) ) + + rc_i = ( mean_chi_i - chi_at_sat ) * cloud_frac_i & + + stdev_chi_i * exp( - one_half * zeta_i**2 ) / ( sqrt_2pi ) + + else ! stdev_chi_i <= chi_tol + + ! The value of chi does not vary in the ith PDF component. + if ( ( mean_chi_i - chi_at_sat ) < zero ) then + ! All clear air in the ith PDF component. + cloud_frac_i = zero + rc_i = zero + else ! mean_chi_i >= 0 + ! All cloud in the ith PDF component. + cloud_frac_i = one + rc_i = mean_chi_i - chi_at_sat + endif ! mean_chi_i < 0 + + endif ! stdev_chi_i > chi_tol + + + return + + end subroutine calc_cloud_frac_component + + !============================================================================= + function calc_cloud_frac( cloud_frac_1, cloud_frac_2, mixt_frac ) + + ! Description: + ! Given the the two pdf components of a cloud fraction, and the weight + ! of the first component, this fuction calculates the cloud fraction, + ! cloud_frac + ! + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & ! Constant(s) + one, & ! 1 + fstderr, & ! Standard error output + zero_threshold ! A physical quantity equal to zero + + use clubb_precision, only: & + core_rknd ! Precision + + use error_code, only: & + clubb_at_least_debug_level ! Function to check whether clubb is in + ! at least the specified debug level + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + cloud_frac_1, & ! First PDF component of cloud_frac + cloud_frac_2, & ! Second PDF component of cloud_frac + mixt_frac ! Weight of 1st PDF component (Sk_w dependent) + + ! Output Variables + real( kind = core_rknd) :: & + calc_cloud_frac ! Cloud fraction + + ! Local Variables + real( kind = core_rknd) :: & + cloud_frac ! Cloud fraction (used as a holding variable for + ! output) + + !----------------------------------------------------------------------- + !----- Begin Code ----- + cloud_frac = mixt_frac * cloud_frac_1 + (one-mixt_frac) * cloud_frac_2 + + ! Note: Brian added the following lines to ensure that there + ! are never any negative liquid water values (or any negative + ! cloud fraction values, for that matter). According to + ! Vince Larson, the analytic formula should not produce any + ! negative results, but such computer-induced errors such as + ! round-off error may produce such a value. This has been + ! corrected because Brian found a small negative value of + ! rcm in the first timestep of the FIRE case. + + cloud_frac = max( zero_threshold, cloud_frac ) + if ( clubb_at_least_debug_level( 2 ) ) then + if ( cloud_frac > one ) then + write(fstderr,*) "Cloud fraction > 1" + end if + end if + cloud_frac = min( one, cloud_frac ) + + calc_cloud_frac = cloud_frac + return + + end function calc_cloud_frac + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + subroutine calc_vert_avg_cf_component & + ( nz, k, z_vals, chi, stdev_chi, chi_at_sat, & + cloud_frac_i, rc_i ) + ! Description: + ! This subroutine is similar to calc_cloud_frac_component, but + ! resolves cloud_frac and rc at an arbitrary number of vertical levels + ! in the vicinity of the desired level. This may give a better + ! parameterization of sub-grid atmospheric conditions. + ! + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd + + implicit none + + intrinsic :: sum + + ! Local Constants + integer, parameter :: & + n_points = 9 ! Number of vertical levels to use in averaging + ! (arbitrary, but must be odd) + + ! Input Variables + integer, intent(in) :: & + nz, & ! Number of vertical levels [count] + k ! Level at which cloud_frac is to be computed [count] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + z_vals, & ! Height at each vertical level [m] + chi, & ! Value of chi (old s) [kg/kg] + stdev_chi, & ! Standard deviation of chi [kg/kg] + chi_at_sat ! Value of chi at saturation with respect to ice [kg/kg] + + ! Output Variables + real( kind = core_rknd ), intent(out) :: & + cloud_frac_i, & ! Vertically averaged cloud fraction [-] + rc_i ! Vertically averaged cloud water mixing ratio [kg/kg] + + ! Local Variables + real( kind = core_rknd ), dimension(n_points) :: & + chi_ref, & ! chi (old s) evaluated on refined grid [kg/kg] + stdev_chi_ref, & ! stdev_chi evaluated on refined grid [kg/kg] + cloud_frac_ref, & ! cloud_frac evaluated on refined grid [-] + rc_ref ! r_c evaluated on refined grid [kg/kg] + + !----------------------------------------------------------------------- + + !----- Begin Code ----- + chi_ref = interp_var_array( n_points, nz, k, z_vals, chi ) + stdev_chi_ref = interp_var_array( n_points, nz, k, z_vals, stdev_chi ) + ! We could optionally compute chi_at_sat in an analogous manner. For now, + ! use chi_at_sat(k) as an approximation. + + ! Compute cloud_frac and r_c at each refined grid level + call calc_cloud_frac_component( chi_ref(:), stdev_chi_ref(:), chi_at_sat(k), & ! Intent(in) + cloud_frac_ref(:), rc_ref(:) ) ! Intent(out) + + cloud_frac_i = sum( cloud_frac_ref(:) ) / real( n_points, kind=core_rknd ) + rc_i = sum( rc_ref(:) ) / real( n_points, kind=core_rknd ) + + return + end subroutine calc_vert_avg_cf_component + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + function interp_var_array( n_points, nz, k, z_vals, var ) + + ! Description: + ! Interpolates a variable to an array of values about a given level + + ! References + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Constant + + implicit none + + ! Input Variables + integer, intent(in) :: & + n_points, & ! Number of points to interpolate to (must be odd and >= 3) + nz, & ! Total number of vertical levels + k ! Center of interpolation array + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + z_vals, & ! Height at each vertical level [m] + var ! Variable values on grid [units vary] + + ! Output Variables + real( kind = core_rknd ), dimension(n_points) :: & + interp_var_array ! Interpolated values of variable [units vary] + + ! Local Variables + real( kind = core_rknd ) :: & + dz ! Distance between vertical levels + + real( kind = core_rknd ) :: & + z_val ! Height at some sub-grid level + + integer :: & + i, & ! Loop iterator + + subgrid_lev_count ! Number of refined grid points located between + ! two defined grid levels + + !----------------------------------------------------------------------- + + !----- Begin Code ----- + + ! Place a point at each of k-1, k, and k+1. + interp_var_array(1) = var_value_integer_height( nz, k-1, z_vals, var ) + interp_var_array((n_points+1)/2) = var_value_integer_height( nz, k, z_vals, var ) + interp_var_array(n_points) = var_value_integer_height( nz, k+1, z_vals, var ) + + subgrid_lev_count = (n_points - 3) / 2 + + ! Lower half + if ( k == 1 ) then + dz = (z_vals(2) - z_vals(1)) / real( subgrid_lev_count+1, kind=core_rknd ) + else + dz = (z_vals(k) - z_vals(k-1)) / real( subgrid_lev_count+1, kind=core_rknd ) + end if + do i=1, subgrid_lev_count + z_val = z_vals(k) - real( i, kind=core_rknd ) * dz + interp_var_array(1+i) & + = var_subgrid_interp( nz, k, z_vals, var, z_val, l_below=.true. ) + end do + + ! Upper half + if ( k == nz ) then + dz = ( z_vals(nz) - z_vals(nz-1) ) / real( subgrid_lev_count+1, kind=core_rknd ) + else + dz = ( z_vals(k+1) - z_vals(k) ) / real( subgrid_lev_count+1, kind=core_rknd ) + end if + do i=1, (n_points-3)/2 + z_val = z_vals(k) + real( i, kind=core_rknd ) * dz + interp_var_array((n_points+1)/2+i) & + = var_subgrid_interp( nz, k, z_vals, var, z_val, l_below=.false. ) + end do + + return + end function interp_var_array + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + function var_value_integer_height( nz, k, z_vals, var_grid_value ) result( var_value ) + + ! Description + ! Returns the value of a variable at an integer height between 0 and + ! nz+1 inclusive, using extrapolation when k==0 or k==nz+1 + + ! References + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Constant + + use interpolation, only: & + mono_cubic_interp ! Procedure + + implicit none + + ! Input Variables + integer, intent(in) :: & + nz, & ! Total number of vertical levels + k ! Level to resolve variable value + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + z_vals, & ! Height at each vertical level [m] + var_grid_value ! Value of variable at each grid level [units vary] + + ! Output Variables + real( kind = core_rknd ) :: & + var_value ! Value of variable at height level [units vary] + + ! Local Variables + integer :: km1, k00, kp1, kp2 + !----------------------------------------------------------------------- + + !----- Begin Code ----- + + if ( k >= 1 .and. k <= nz ) then + ! This is the simple case. No extrapolation necessary. + var_value = var_grid_value(k) + else if ( k == 0 ) then + ! Extrapolate below the lower boundary + km1 = nz + k00 = 1 + kp1 = 2 + kp2 = 3 + var_value = mono_cubic_interp( z_vals(1)-(z_vals(2)-z_vals(1)), & + km1, k00, kp1, kp2, & + z_vals(km1), z_vals(k00), z_vals(kp1), z_vals(kp2), & + var_grid_value(km1), var_grid_value(k00), & + var_grid_value(kp1), var_grid_value(kp2) ) + else if ( k == nz+1 ) then + ! Extrapolate above the upper boundary + km1 = nz + k00 = nz-1 + kp1 = nz + kp2 = nz + var_value = mono_cubic_interp( z_vals(nz)+(z_vals(nz)-z_vals(nz-1)), & + km1, k00, kp1, kp2, & + z_vals(km1), z_vals(k00), z_vals(kp1), z_vals(kp2), & + var_grid_value(km1), var_grid_value(k00), & + var_grid_value(kp1), var_grid_value(kp2) ) + else + ! Invalid height requested + var_value = -999._core_rknd + end if ! k > 1 .and. k < nz + return + end function var_value_integer_height + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + function var_subgrid_interp( nz, k, z_vals, var, z_interp, l_below ) result( var_value ) + + ! Description + ! Interpolates (or extrapolates) a variable to a value between grid + ! levels + + ! References + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Constant + + use interpolation, only: & + mono_cubic_interp ! Procedure + + implicit none + + ! Input Variables + integer, intent(in) :: & + nz, & ! Number of vertical levels + k ! Grid level near interpolation target + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + z_vals, & ! Height at each grid level [m] + var ! Variable values at grid levels [units vary] + + real( kind = core_rknd ), intent(in) :: & + z_interp ! Interpolation target height [m] + + logical, intent(in) :: & + l_below ! True if z_interp < z_vals(k), false otherwise + + ! Output Variable + real( kind = core_rknd ) :: & + var_value ! Interpolated value of variable [units vary] + + ! Local Variables + integer :: km1, k00, kp1, kp2 ! Parameters for call to mono_cubic_interp + !---------------------------------------------------------------------- + + !----- Begin Code ----- + if ( l_below ) then + + if ( k == 1 ) then ! Extrapolation + km1 = nz + k00 = 1 + kp1 = 2 + kp2 = 3 + else if ( k == 2 ) then + km1 = 1 + k00 = 1 + kp1 = 2 + kp2 = 3 + else if ( k == nz ) then + km1 = nz-2 + k00 = nz-1 + kp1 = nz + kp2 = nz + else + km1 = k-2 + k00 = k-1 + kp1 = k + kp2 = k+1 + end if ! k == 1 + + else ! .not. l_below + + if ( k == 1 ) then + km1 = 1 + k00 = 1 + kp1 = 2 + kp2 = 3 + else if ( k == nz-1 ) then + km1 = nz-2 + k00 = nz-1 + kp1 = nz + kp2 = nz + else if ( k == nz ) then ! Extrapolation + km1 = nz + k00 = nz-1 + kp1 = nz + kp2 = nz + else + km1 = k-1 + k00 = k + kp1 = k+1 + kp2 = k+2 + end if ! k == 1 + + end if ! l_below + + ! Now perform the interpolation + var_value = mono_cubic_interp( z_interp, km1, k00, kp1, kp2, & + z_vals(km1), z_vals(k00), z_vals(kp1), z_vals(kp2), & + var(km1), var(k00), var(kp1), var(kp2) ) + + return + end function var_subgrid_interp + !----------------------------------------------------------------------- end module pdf_closure_module diff --git a/models/atm/cam/src/physics/clubb/pdf_parameter_module.F90 b/models/atm/cam/src/physics/clubb/pdf_parameter_module.F90 index 3ccaa3e8166d..247ed19a2e2b 100644 --- a/models/atm/cam/src/physics/clubb/pdf_parameter_module.F90 +++ b/models/atm/cam/src/physics/clubb/pdf_parameter_module.F90 @@ -1,4 +1,6 @@ -! $Id: pdf_parameter_module.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +!----------------------------------------------------------------------- +! $Id: pdf_parameter_module.F90 7309 2014-09-20 17:06:28Z betlej@uwm.edu $ +!=============================================================================== module pdf_parameter_module ! Description: ! This module defines the derived type pdf_parameter. @@ -17,36 +19,274 @@ module pdf_parameter_module type pdf_parameter real( kind = core_rknd ) :: & - w1, & ! Mean of w for 1st normal distribution [m/s] - w2, & ! Mean of w for 2nd normal distribution [m/s] - varnce_w1, & ! Variance of w for 1st normal distribution [m^2/s^2] - varnce_w2, & ! Variance of w for 2nd normal distribution [m^2/s^2] - rt1, & ! Mean of r_t for 1st normal distribution [kg/kg] - rt2, & ! Mean of r_t for 2nd normal distribution [kg/kg] - varnce_rt1, & ! Variance of r_t for 1st normal distribution [kg^2/kg^2] - varnce_rt2, & ! Variance of r_t for 2nd normal distribution [kg^2/kg^2] - crt1, & ! Coefficient for s' [-] - crt2, & ! Coefficient for s' [-] - cthl1, & ! Coefficient for s' [1/K] - cthl2, & ! Coefficient for s' [1/K] - thl1, & ! Mean of th_l for 1st normal distribution [K] - thl2, & ! Mean of th_l for 2nd normal distribution [K] - varnce_thl1, & ! Variance of th_l for 1st normal distribution [K^2] - varnce_thl2, & ! Variance of th_l for 2nd normal distribution [K^2] - mixt_frac, & ! Weight of 1st normal distribution (Sk_w dependent) [-] - rc1, & ! Mean of r_c for 1st normal distribution [kg/kg] - rc2, & ! Mean of r_c for 2nd normal distribution [kg/kg] - rsl1, & ! Mean of r_sl for 1st normal distribution [kg/kg] - rsl2, & ! Mean of r_sl for 2nd normal distribution [kg/kg] - cloud_frac1, & ! Cloud fraction for 1st normal distribution [-] - cloud_frac2, & ! Cloud fraction for 2nd normal distribution [-] - s1, & ! Mean of s for 1st normal distribution [kg/kg] - s2, & ! Mean of s for 2nd normal distribution [kg/kg] - stdev_s1, & ! Standard deviation of s for 1st normal distribution [kg/kg] - stdev_s2, & ! Standard deviation of s for 2nd normal distribution [kg/kg] - rrtthl, & ! Within-a-normal correlation of r_t and th_l [-] - alpha_thl, & ! Factor relating to normalized variance for th_l [-] - alpha_rt ! Factor relating to normalized variance for r_t [-] + w_1, & ! Mean of w (1st PDF component) [m/s] + w_2, & ! Mean of w (2nd PDF component) [m/s] + varnce_w_1, & ! Variance of w (1st PDF component) [m^2/s^2] + varnce_w_2, & ! Variance of w (2nd PDF component) [m^2/s^2] + rt_1, & ! Mean of r_t (1st PDF component) [kg/kg] + rt_2, & ! Mean of r_t (2nd PDF component) [kg/kg] + varnce_rt_1, & ! Variance of r_t (1st PDF component) [kg^2/kg^2] + varnce_rt_2, & ! Variance of r_t (2nd PDF component) [kg^2/kg^2] + thl_1, & ! Mean of th_l (1st PDF component) [K] + thl_2, & ! Mean of th_l (2nd PDF component) [K] + varnce_thl_1, & ! Variance of th_l (1st PDF component) [K^2] + varnce_thl_2, & ! Variance of th_l (2nd PDF component) [K^2] + rrtthl, & ! Correlation of r_t and th_l (both components) [-] + alpha_thl, & ! Factor relating to normalized variance for th_l [-] + alpha_rt, & ! Factor relating to normalized variance for r_t [-] + crt_1, & ! r_t coef. in chi/eta eqns. (1st PDF comp.) [-] + crt_2, & ! r_t coef. in chi/eta eqns. (2nd PDF comp.) [-] + cthl_1, & ! th_l coef.: chi/eta eqns. (1st PDF comp.) [(kg/kg)/K] + cthl_2, & ! th_l coef.: chi/eta eqns. (2nd PDF comp.) [(kg/kg)/K] + chi_1, & ! Mean of chi (old s) (1st PDF component) [kg/kg] + chi_2, & ! Mean of chi (old s) (2nd PDF component) [kg/kg] + stdev_chi_1, & ! Standard deviation of chi (1st PDF component) [kg/kg] + stdev_chi_2, & ! Standard deviation of chi (2nd PDF component) [kg/kg] + stdev_eta_1, & ! Standard dev. of eta (old t) (1st PDF comp.) [kg/kg] + stdev_eta_2, & ! Standard dev. of eta (old t) (2nd PDF comp.) [kg/kg] + covar_chi_eta_1, & ! Covariance of chi and eta (1st PDF comp.) [kg^2/kg^2] + covar_chi_eta_2, & ! Covariance of chi and eta (2nd PDF comp.) [kg^2/kg^2] + corr_chi_eta_1, & ! Correlation of chi and eta (1st PDF component) [-] + corr_chi_eta_2, & ! Correlation of chi and eta (2nd PDF component) [-] + rsatl_1, & ! Saturation mixing ratio r_sat(mu_Tl_1,p) [kg/kg] + rsatl_2, & ! Saturation mixing ratio r_sat(mu_Tl_2,p) [kg/kg] + rc_1, & ! Mean of r_c (1st PDF component) [kg/kg] + rc_2, & ! Mean of r_c (2nd PDF component) [kg/kg] + cloud_frac_1, & ! Cloud fraction (1st PDF component) [-] + cloud_frac_2, & ! Cloud fraction (2nd PDF component) [-] + mixt_frac ! Weight of 1st PDF component (Sk_w dependent) [-] end type pdf_parameter +#ifdef CLUBB_CAM /* Code for storing pdf_parameter structs in pbuf as array */ + + public :: pack_pdf_params, unpack_pdf_params + + integer, public, parameter :: num_pdf_params = 36 + + !------- + contains + !------- + + subroutine pack_pdf_params(pdf_params, nz, r_param_array) + implicit none + ! Input a pdf_parameter array with nz instances of pdf_parameter + integer, intent(in) :: nz ! Num Vert Model Levs + type (pdf_parameter), dimension(nz), intent(in) :: pdf_params + + ! Output a two dimensional real array with all values + real (kind = core_rknd), dimension(nz,num_pdf_params), intent(out) :: & + r_param_array + + ! Local Loop vars + integer :: k, p + + do k = 1,nz + do p = 1,num_pdf_params + + r_param_array(k,p) = get_param_at_ind(pdf_params(k), p) + + end do ! p + end do ! k + + end subroutine pack_pdf_params + + subroutine unpack_pdf_params(r_param_array, nz, pdf_params) + implicit none + ! Input a two dimensional real array with pdf values + integer, intent(in) :: nz ! Num Vert Model Levs + real (kind = core_rknd), dimension(nz,num_pdf_params), intent(in) :: & + r_param_array + + ! Output a pdf_parameter array with nz instances of pdf_parameter + type (pdf_parameter), dimension(nz), intent(out) :: pdf_params + + ! Local Loop vars + integer :: k, p + ! temp var + real (kind = core_rknd) :: value + + do k = 1,nz + do p = 1,num_pdf_params + + value = r_param_array(k,p) + call set_param_at_ind(pdf_params(k), p, value) + + end do ! p + end do ! k + + end subroutine unpack_pdf_params + + real( kind = core_rknd ) function get_param_at_ind(pp_struct, ind) + implicit none + type (pdf_parameter), intent(in) :: pp_struct + integer, intent(in) :: ind + + SELECT CASE (ind) + CASE (1) + get_param_at_ind = pp_struct%w_1 + CASE (2) + get_param_at_ind = pp_struct%w_2 + CASE (3) + get_param_at_ind = pp_struct%varnce_w_1 + CASE (4) + get_param_at_ind = pp_struct%varnce_w_2 + CASE (5) + get_param_at_ind = pp_struct%rt_1 + CASE (6) + get_param_at_ind = pp_struct%rt_2 + CASE (7) + get_param_at_ind = pp_struct%varnce_rt_1 + CASE (8) + get_param_at_ind = pp_struct%varnce_rt_2 + CASE (9) + get_param_at_ind = pp_struct%thl_1 + CASE (10) + get_param_at_ind = pp_struct%thl_2 + CASE (11) + get_param_at_ind = pp_struct%varnce_thl_1 + CASE (12) + get_param_at_ind = pp_struct%varnce_thl_2 + CASE (13) + get_param_at_ind = pp_struct%rrtthl + CASE (14) + get_param_at_ind = pp_struct%alpha_thl + CASE (15) + get_param_at_ind = pp_struct%alpha_rt + CASE (16) + get_param_at_ind = pp_struct%crt_1 + CASE (17) + get_param_at_ind = pp_struct%crt_2 + CASE (18) + get_param_at_ind = pp_struct%cthl_1 + CASE (19) + get_param_at_ind = pp_struct%cthl_2 + CASE (20) + get_param_at_ind = pp_struct%chi_1 + CASE (21) + get_param_at_ind = pp_struct%chi_2 + CASE (22) + get_param_at_ind = pp_struct%stdev_chi_1 + CASE (23) + get_param_at_ind = pp_struct%stdev_chi_2 + CASE (24) + get_param_at_ind = pp_struct%stdev_eta_1 + CASE (25) + get_param_at_ind = pp_struct%stdev_eta_2 + CASE (26) + get_param_at_ind = pp_struct%covar_chi_eta_1 + CASE (27) + get_param_at_ind = pp_struct%covar_chi_eta_2 + CASE (28) + get_param_at_ind = pp_struct%corr_chi_eta_1 + CASE (29) + get_param_at_ind = pp_struct%corr_chi_eta_2 + CASE (30) + get_param_at_ind = pp_struct%rsatl_1 + CASE (31) + get_param_at_ind = pp_struct%rsatl_2 + CASE (32) + get_param_at_ind = pp_struct%rc_1 + CASE (33) + get_param_at_ind = pp_struct%rc_2 + CASE (34) + get_param_at_ind = pp_struct%cloud_frac_1 + CASE (35) + get_param_at_ind = pp_struct%cloud_frac_2 + CASE (36) + get_param_at_ind = pp_struct%mixt_frac + CASE DEFAULT +! NAG compiler does not like divide by zero - commented out +! get_param_at_ind = 0.0/0.0 !NaN - watch out! + END SELECT + + RETURN + end function get_param_at_ind + + subroutine set_param_at_ind(pp_struct, ind, val) + implicit none + type (pdf_parameter), intent(inout) :: pp_struct + integer, intent(in) :: ind + real (kind = core_rknd), intent(in) :: val + + SELECT CASE (ind) + CASE (1) + pp_struct%w_1 = val + CASE (2) + pp_struct%w_2 = val + CASE (3) + pp_struct%varnce_w_1 = val + CASE (4) + pp_struct%varnce_w_2 = val + CASE (5) + pp_struct%rt_1 = val + CASE (6) + pp_struct%rt_2 = val + CASE (7) + pp_struct%varnce_rt_1 = val + CASE (8) + pp_struct%varnce_rt_2 = val + CASE (9) + pp_struct%thl_1 = val + CASE (10) + pp_struct%thl_2 = val + CASE (11) + pp_struct%varnce_thl_1 = val + CASE (12) + pp_struct%varnce_thl_2 = val + CASE (13) + pp_struct%rrtthl = val + CASE (14) + pp_struct%alpha_thl = val + CASE (15) + pp_struct%alpha_rt = val + CASE (16) + pp_struct%crt_1 = val + CASE (17) + pp_struct%crt_2 = val + CASE (18) + pp_struct%cthl_1 = val + CASE (19) + pp_struct%cthl_2 = val + CASE (20) + pp_struct%chi_1 = val + CASE (21) + pp_struct%chi_2 = val + CASE (22) + pp_struct%stdev_chi_1 = val + CASE (23) + pp_struct%stdev_chi_2 = val + CASE (24) + pp_struct%stdev_eta_1 = val + CASE (25) + pp_struct%stdev_eta_2 = val + CASE (26) + pp_struct%covar_chi_eta_1 = val + CASE (27) + pp_struct%covar_chi_eta_2 = val + CASE (28) + pp_struct%corr_chi_eta_1 = val + CASE (29) + pp_struct%corr_chi_eta_2 = val + CASE (30) + pp_struct%rsatl_1 = val + CASE (31) + pp_struct%rsatl_2 = val + CASE (32) + pp_struct%rc_1 = val + CASE (33) + pp_struct%rc_2 = val + CASE (34) + pp_struct%cloud_frac_1 = val + CASE (35) + pp_struct%cloud_frac_2 = val + CASE (36) + pp_struct%mixt_frac = val + CASE DEFAULT + ! do nothing ! + END SELECT + + end subroutine set_param_at_ind + +#endif + end module pdf_parameter_module diff --git a/models/atm/cam/src/physics/clubb/pdf_utilities.F90 b/models/atm/cam/src/physics/clubb/pdf_utilities.F90 new file mode 100644 index 000000000000..0f492e317471 --- /dev/null +++ b/models/atm/cam/src/physics/clubb/pdf_utilities.F90 @@ -0,0 +1,892 @@ +!------------------------------------------------------------------------- +! $Id: pdf_utilities.F90 7370 2014-11-07 20:59:58Z bmg2@uwm.edu $ +!=============================================================================== +module pdf_utilities + + implicit none + + private ! Set default scope to private + + public :: mean_L2N, & + mean_L2N_dp, & + stdev_L2N, & + stdev_L2N_dp, & + corr_NL2NN, & + corr_NL2NN_dp, & + corr_LL2NN, & + corr_LL2NN_dp, & + compute_mean_binormal, & + compute_variance_binormal, & + calc_corr_chi_x, & + calc_corr_rt_x, & + calc_corr_thl_x, & + calc_xp2 + + contains + + !============================================================================= + pure function mean_L2N( mu_x, sigma2_on_mu2 ) & + result( mu_x_n ) + + ! Description: + ! For a lognormally-distributed variable x, this function finds the mean of + ! ln x (mu_x_n) for the ith component of the PDF, given the mean of x (mu_x) + ! and the variance of x (sigma_sqd_x) for the ith component of the PDF. The + ! value ln x is distributed normally when x is distributed lognormally. + + ! References: + ! Garvey, P. R., 2000: Probability methods for cost uncertainty analysis. + ! Marcel Dekker, 401 pp. + ! -- App. B. + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one ! Constant(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + mu_x, & ! Mean of x (ith PDF component) [-] + sigma2_on_mu2 ! Ratio: sigma_x^2 / mu_x^2 (ith PDF component) [-] + + ! Return Variable + real( kind = core_rknd ) :: & + mu_x_n ! Mean of ln x (ith PDF component) [-] + + + ! Find the mean of ln x for the ith component of the PDF. + mu_x_n = log( mu_x / sqrt( one + sigma2_on_mu2 ) ) + + + return + + end function mean_L2N + + !============================================================================= + pure function mean_L2N_dp( mu_x, sigma2_on_mu2 ) & + result( mu_x_n ) + + ! Description: + ! For a lognormally-distributed variable x, this function finds the mean of + ! ln x (mu_x_n) for the ith component of the PDF, given the mean of x (mu_x) + ! and the variance of x (sigma_sqd_x) for the ith component of the PDF. The + ! value ln x is distributed normally when x is distributed lognormally. + ! This function uses double precision variables. + + ! References: + ! Garvey, P. R., 2000: Probability methods for cost uncertainty analysis. + ! Marcel Dekker, 401 pp. + ! -- App. B. + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one_dp ! Constant(s) + + use clubb_precision, only: & + dp ! double precision + + implicit none + + ! Input Variables + real( kind = dp ), intent(in) :: & + mu_x, & ! Mean of x (ith PDF component) [-] + sigma2_on_mu2 ! Ratio: sigma_x^2 / mu_x^2 (ith PDF component) [-] + + ! Return Variable + real( kind = dp ) :: & + mu_x_n ! Mean of ln x (ith PDF component) [-] + + + ! Find the mean of ln x for the ith component of the PDF. + mu_x_n = log( mu_x / sqrt( one_dp + sigma2_on_mu2 ) ) + + + return + + end function mean_L2N_dp + + !============================================================================= + pure function stdev_L2N( sigma2_on_mu2 ) & + result( sigma_x_n ) + + ! Description: + ! For a lognormally-distributed variable x, this function finds the standard + ! deviation of ln x (sigma_x_n) for the ith component of the PDF, given the + ! mean of x (mu_x) and the variance of x (sigma_sqd_x) for the ith component + ! of the PDF. The value ln x is distributed normally when x is distributed + ! lognormally. + + ! References: + ! Garvey, P. R., 2000: Probability methods for cost uncertainty analysis. + ! Marcel Dekker, 401 pp. + ! -- App. B. + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one ! Constant(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + sigma2_on_mu2 ! Ratio: sigma_x^2 / mu_x^2 (ith PDF component) [-] + + ! Return Variable + real( kind = core_rknd ) :: & + sigma_x_n ! Standard deviation of ln x (ith PDF component) [-] + + + ! Find the standard deviation of ln x for the ith component of the PDF. + sigma_x_n = sqrt( log( one + sigma2_on_mu2 ) ) + + + return + + end function stdev_L2N + + !============================================================================= + pure function stdev_L2N_dp( sigma2_on_mu2 ) & + result( sigma_x_n ) + + ! Description: + ! For a lognormally-distributed variable x, this function finds the standard + ! deviation of ln x (sigma_x_n) for the ith component of the PDF, given the + ! mean of x (mu_x) and the variance of x (sigma_sqd_x) for the ith component + ! of the PDF. The value ln x is distributed normally when x is distributed + ! lognormally. + ! This function uses double precision variables. + + ! References: + ! Garvey, P. R., 2000: Probability methods for cost uncertainty analysis. + ! Marcel Dekker, 401 pp. + ! -- App. B. + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one_dp ! Constant(s) + + use clubb_precision, only: & + dp ! double precision + + implicit none + + ! Input Variables + real( kind = dp ), intent(in) :: & + sigma2_on_mu2 ! Ratio: sigma_x^2 / mu_x^2 (ith PDF component) [-] + + ! Return Variable + real( kind = dp ) :: & + sigma_x_n ! Standard deviation of ln x (ith PDF component) [-] + + + ! Find the standard deviation of ln x for the ith component of the PDF. + sigma_x_n = sqrt( log( one_dp + sigma2_on_mu2 ) ) + + + return + + end function stdev_L2N_dp + + !============================================================================= + pure function corr_NL2NN( corr_x_y, sigma_y_n, y_sigma2_on_mu2 ) & + result( corr_x_y_n ) + + ! Description: + ! For a normally-distributed variable x and a lognormally-distributed + ! variable y, this function finds the correlation of x and ln y (corr_x_y_n) + ! for the ith component of the PDF, given the correlation of x and y + ! (corr_x_y) and the standard deviation of ln y (sigma_y_n) for the ith + ! component of the PDF. The value ln y is distributed normally when y is + ! distributed lognormally. + + ! References: + ! Garvey, P. R., 2000: Probability methods for cost uncertainty analysis. + ! Marcel Dekker, 401 pp. + ! -- Eq. B-1. + !----------------------------------------------------------------------- + + use constants_clubb, only: & + max_mag_correlation ! Constant(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + corr_x_y, & ! Correlation of x and y (ith PDF component) [-] + sigma_y_n, & ! Standard deviation of ln y (ith PDF component) [-] + y_sigma2_on_mu2 ! Ratio: sigma_y^2 / mu_y^2 (ith PDF component) [-] + + ! Return Variable + real( kind = core_rknd ) :: & + corr_x_y_n ! Correlation of x and ln y (ith PDF component) [-] + + + ! Find the correlation of x and ln y for the ith component of the PDF. + corr_x_y_n = corr_x_y * sqrt( y_sigma2_on_mu2 ) / sigma_y_n + + ! Clip the magnitude of the correlation of x and ln y in the ith PDF + ! component, just in case the correlation (ith PDF component) of x and y and + ! the standard deviation (ith PDF component) of ln y are inconsistent, + ! resulting in an unrealizable value for corr_x_y_n. + if ( corr_x_y_n > max_mag_correlation ) then + corr_x_y_n = max_mag_correlation + elseif ( corr_x_y_n < -max_mag_correlation ) then + corr_x_y_n = -max_mag_correlation + endif + + + return + + end function corr_NL2NN + + !============================================================================= + pure function corr_NL2NN_dp( corr_x_y, sigma_y_n, y_sigma2_on_mu2 ) & + result( corr_x_y_n ) + + ! Description: + ! For a normally-distributed variable x and a lognormally-distributed + ! variable y, this function finds the correlation of x and ln y (corr_x_y_n) + ! for the ith component of the PDF, given the correlation of x and y + ! (corr_x_y) and the standard deviation of ln y (sigma_y_n) for the ith + ! component of the PDF. The value ln y is distributed normally when y is + ! distributed lognormally. + ! This function uses double precision variables. + + ! References: + ! Garvey, P. R., 2000: Probability methods for cost uncertainty analysis. + ! Marcel Dekker, 401 pp. + ! -- Eq. B-1. + !----------------------------------------------------------------------- + + use constants_clubb, only: & + max_mag_correlation ! Constant(s) + + use clubb_precision, only: & + dp ! double precision + + implicit none + + ! Input Variables + real( kind = dp ), intent(in) :: & + corr_x_y, & ! Correlation of x and y (ith PDF component) [-] + sigma_y_n, & ! Standard deviation of ln y (ith PDF component) [-] + y_sigma2_on_mu2 ! Ratio: sigma_y^2 / mu_y^2 (ith PDF component) [-] + + ! Return Variable + real( kind = dp ) :: & + corr_x_y_n ! Correlation of x and ln y (ith PDF component) [-] + + + ! Find the correlation of x and ln y for the ith component of the PDF. + corr_x_y_n = corr_x_y * sqrt( y_sigma2_on_mu2 ) / sigma_y_n + + ! Clip the magnitude of the correlation of x and ln y in the ith PDF + ! component, just in case the correlation (ith PDF component) of x and y and + ! the standard deviation (ith PDF component) of ln y are inconsistent, + ! resulting in an unrealizable value for corr_x_y_n. + if ( corr_x_y_n > real( max_mag_correlation, kind = dp ) ) then + corr_x_y_n = real( max_mag_correlation, kind = dp ) + elseif ( corr_x_y_n < -real( max_mag_correlation, kind = dp ) ) then + corr_x_y_n = -real( max_mag_correlation, kind = dp ) + endif + + + return + + end function corr_NL2NN_dp + + !============================================================================= + pure function corr_LL2NN( corr_x_y, sigma_x_n, sigma_y_n, & + x_sigma2_on_mu2, y_sigma2_on_mu2 ) & + result( corr_x_y_n ) + + ! Description: + ! For lognormally-distributed variables x and y, this function finds the + ! correlation of ln x and ln y (corr_x_y_n) for the ith component of the + ! PDF, given the correlation of x and y (corr_x_y), the standard deviation + ! of ln x (sigma_x_n), and the standard deviation of ln y (sigma_y_n) for + ! the ith component of the PDF. The value of ln x (or ln y) is distributed + ! normally when x (or y) is distributed lognormally. + + ! References: + ! Garvey, P. R., 2000: Probability methods for cost uncertainty analysis. + ! Marcel Dekker, 401 pp. + ! -- Eq. C-3. + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + max_mag_correlation + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + corr_x_y, & ! Correlation of x and y (ith PDF component) [-] + sigma_x_n, & ! Standard deviation of ln x (ith PDF component) [-] + sigma_y_n, & ! Standard deviation of ln y (ith PDF component) [-] + x_sigma2_on_mu2, & ! Ratio: sigma_x^2 / mu_x^2 (ith PDF component) [-] + y_sigma2_on_mu2 ! Ratio: sigma_y^2 / mu_y^2 (ith PDF component) [-] + + ! Return Variable + real( kind = core_rknd ) :: & + corr_x_y_n ! Correlation of ln x and ln y (ith PDF component) [-] + + ! Local Variable + real( kind = core_rknd ) :: & + log_arg ! Input into the ln function [-] + + + log_arg = one + corr_x_y * sqrt( x_sigma2_on_mu2 * y_sigma2_on_mu2 ) + ! Find the correlation of ln x and ln y for the ith component of the + ! PDF. +! corr_x_y_n = log( one + corr_x_y * sqrt( exp( sigma_x_n**2 ) - one ) & +! * sqrt( exp( sigma_y_n**2 ) - one ) ) & +! / ( sigma_x_n * sigma_y_n ) + + corr_x_y_n = log( log_arg ) / ( sigma_x_n * sigma_y_n ) + + ! Clip the magnitude of the correlation of ln x and ln y in the ith PDF + ! component, just in case the correlation (ith PDF component) of x and y, + ! the standard deviation (ith PDF component) of ln x, and the standard + ! deviation (ith PDF component) of ln y are inconsistent, resulting in an + ! unrealizable value for corr_x_y_n. + if ( corr_x_y_n > max_mag_correlation ) then + corr_x_y_n = max_mag_correlation + elseif ( corr_x_y_n < -max_mag_correlation ) then + corr_x_y_n = -max_mag_correlation + endif + + + return + + end function corr_LL2NN + + !============================================================================= + pure function corr_LL2NN_dp( corr_x_y, sigma_x_n, sigma_y_n, & + x_sigma2_on_mu2, y_sigma2_on_mu2 ) & + result( corr_x_y_n ) + + ! Description: + ! For lognormally-distributed variables x and y, this function finds the + ! correlation of ln x and ln y (corr_x_y_n) for the ith component of the + ! PDF, given the correlation of x and y (corr_x_y), the standard deviation + ! of ln x (sigma_x_n), and the standard deviation of ln y (sigma_y_n) for + ! the ith component of the PDF. The value of ln x (or ln y) is distributed + ! normally when x (or y) is distributed lognormally. + ! This function uses double precision variables. + + ! References: + ! Garvey, P. R., 2000: Probability methods for cost uncertainty analysis. + ! Marcel Dekker, 401 pp. + ! -- Eq. C-3. + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one_dp, & ! Constant(s) + max_mag_correlation + + use clubb_precision, only: & + dp ! double precision + + implicit none + + ! Input Variables + real( kind = dp ), intent(in) :: & + corr_x_y, & ! Correlation of x and y (ith PDF component) [-] + sigma_x_n, & ! Standard deviation of ln x (ith PDF component) [-] + sigma_y_n, & ! Standard deviation of ln y (ith PDF component) [-] + x_sigma2_on_mu2, & ! Ratio: sigma_x^2 / mu_x^2 (ith PDF component) [-] + y_sigma2_on_mu2 ! Ratio: sigma_y^2 / mu_y^2 (ith PDF component) [-] + + + ! Return Variable + real( kind = dp ) :: & + corr_x_y_n ! Correlation of ln x and ln y (ith PDF component) [-] + + + ! Find the correlation of ln x and ln y for the ith component of the + ! PDF. + corr_x_y_n & + = log( one_dp + corr_x_y * sqrt( x_sigma2_on_mu2 * y_sigma2_on_mu2 ) ) & + / ( sigma_x_n * sigma_y_n ) + + ! Clip the magnitude of the correlation of ln x and ln y in the ith PDF + ! component, just in case the correlation (ith PDF component) of x and y, + ! the standard deviation (ith PDF component) of ln x, and the standard + ! deviation (ith PDF component) of ln y are inconsistent, resulting in an + ! unrealizable value for corr_x_y_n. + if ( corr_x_y_n > real( max_mag_correlation, kind = dp ) ) then + corr_x_y_n = real( max_mag_correlation, kind = dp ) + elseif ( corr_x_y_n < -real( max_mag_correlation, kind = dp ) ) then + corr_x_y_n = -real( max_mag_correlation, kind = dp ) + endif + + + return + + end function corr_LL2NN_dp + + !============================================================================= + elemental function compute_mean_binormal( mu_x_1, mu_x_2, mixt_frac ) & + result( xm ) + + ! Description: + ! Computes the overall grid-box mean of a binormal distribution from the + ! mean of each component + + ! References: + ! None + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Constant + + use constants_clubb, only: & + one ! Constant + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + mu_x_1, & ! First PDF component mean of 'x' [?] + mu_x_2, & ! Second PDF component mean of 'x' [?] + mixt_frac ! Weight of the first PDF component [-] + + ! Output Variables + real( kind = core_rknd ) :: & + xm ! Mean of 'x' (overall) [?] + + !----------------------------------------------------------------------- + + !----- Begin Code ----- + xm = mixt_frac * mu_x_1 + ( one - mixt_frac ) * mu_x_2 + + + return + + end function compute_mean_binormal + + !============================================================================= + elemental function compute_variance_binormal( xm, mu_x_1, mu_x_2, & + stdev_x_1, stdev_x_2, & + mixt_frac ) & + result( xp2 ) + + ! Description: + ! Computes the overall grid-box variance of a binormal distribution from the + ! variance of each component. + + ! References: + ! None + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Constant + + use constants_clubb, only: & + one ! Constant + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + xm, & ! Overall mean of 'x' [?] + mu_x_1, & ! First PDF component mean of 'x' [?] + mu_x_2, & ! Second PDF component mean of 'x' [?] + stdev_x_1, & ! Standard deviation of 'x' in the first PDF component [?] + stdev_x_2, & ! Standard deviation of 'x' in the second PDF component [?] + mixt_frac ! Weight of the first PDF component [-] + + ! Output Variables + real( kind = core_rknd ) :: & + xp2 ! Variance of 'x' (overall) [?^2] + + !----------------------------------------------------------------------- + + !----- Begin Code ----- + xp2 = mixt_frac * ( ( mu_x_1 - xm )**2 + stdev_x_1**2 ) & + + ( one - mixt_frac ) * ( ( mu_x_2 - xm )**2 + stdev_x_2**2 ) + + + return + + end function compute_variance_binormal + + !============================================================================= + pure function calc_corr_chi_x( crt_i, cthl_i, sigma_rt_i, sigma_thl_i, & + sigma_chi_i, corr_rt_x_i, corr_thl_x_i ) & + result( corr_chi_x_i ) + + ! Description: + ! This function calculates the correlation of extended liquid water mixing + ! ratio, chi (old s), and a generic variable x, within the ith component of + ! the PDF. The variable chi can be split into mean and turbulent + ! components, such that: + ! + ! chi = + chi'; + ! + ! where < > denotes a mean field an ' denotes a turbulent component. + ! + ! The linearized equation for chi' is given in Larson et al. (2001), where + ! within the ith component of the PDF: + ! + ! chi_(i)' = Coef_rt(i) * r_t(i)' - Coef_thl(i) * th_l(i)'. + ! + ! The equation for chi' can be multiplied by x'. The equation becomes: + ! + ! chi'x'_(i) = Coef_rt(i) * r_t'x'_(i) - Coef_thl(i) * th_l'x'_(i). + ! + ! Averaging both sides, the covariance is given by the equation: + ! + ! = Coef_rt(i) * - Coef_thl(i) * . + ! + ! This equation can be rewritten as: + ! + ! sigma_chi(i) * sigma_x(i) * corr_chi_x(i) + ! = Coef_rt(i) * sigma_rt(i) * sigma_x(i) * corr_rt_x(i) + ! - Coef_thl(i) * sigma_thl(i) * sigma_x(i) * corr_thl_x(i). + ! + ! This equation can be solved for corr_chi_x(i): + ! + ! corr_chi_x(i) + ! = Coef_rt(i) * ( sigma_rt(i) / sigma_chi(i) ) * corr_rt_x(i) + ! - Coef_thl(i) * ( sigma_thl(i) / sigma_chi(i) ) * corr_thl_x(i). + ! + ! The correlation of chi and x within the ith component of the PDF is + ! calculated. + + ! References: + ! Larson, V. E., R. Wood, P. R. Field, J.-C. Golaz, T. H. Vonder Haar, + ! W. R. Cotton, 2001: Systematic Biases in the Microphysics and + ! Thermodynamics of Numerical Models That Ignore Subgrid-Scale + ! Variability. J. Atmos. Sci., 58, 1117--1128. + ! -- Eq. 13 and 14. + !----------------------------------------------------------------------- + + use constants_clubb, only: & + zero, & ! Constant(s) + chi_tol, & + max_mag_correlation + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + crt_i, & ! Coefficient of r_t for chi (old s) (ith PDF comp.) [-] + cthl_i, & ! Coefficient of th_l for chi (ith PDF comp.) [(kg/kg)/K] + sigma_rt_i, & ! Standard deviation of r_t (ith PDF component) [kg/kg] + sigma_thl_i, & ! Standard deviation of th_l (ith PDF component) [K] + sigma_chi_i, & ! Standard deviation of chi (ith PDF component) [kg/kg] + corr_rt_x_i, & ! Correlation of r_t and x (ith PDF component) [-] + corr_thl_x_i ! Correlation of th_l and x (ith PDF component) [-] + + ! Return Variable + real( kind = core_rknd ) :: & + corr_chi_x_i ! Correlation of chi and x (ith PDF component) [-] + + + ! Calculate the correlation of chi and x in the ith PDF component. + if ( sigma_chi_i > chi_tol ) then + + corr_chi_x_i = crt_i * ( sigma_rt_i / sigma_chi_i ) * corr_rt_x_i & + - cthl_i * ( sigma_thl_i / sigma_chi_i ) * corr_thl_x_i + + else ! sigma_chi_i = 0 + + ! The standard deviation of chi in the ith PDF component is 0. This + ! means that chi is constant within the ith PDF component, and the ith + ! PDF component covariance of chi and x is also 0. The correlation of + ! chi and x is undefined in the ith PDF component, so a value of 0 will + ! be used. + corr_chi_x_i = zero + + endif + + ! Clip the magnitude of the correlation of chi and x in the ith PDF + ! component, just in case the correlations and standard deviations used in + ! calculating it are inconsistent, resulting in an unrealizable value for + ! corr_chi_x_i. + if ( corr_chi_x_i > max_mag_correlation ) then + corr_chi_x_i = max_mag_correlation + elseif ( corr_chi_x_i < -max_mag_correlation ) then + corr_chi_x_i = -max_mag_correlation + endif + + + return + + end function calc_corr_chi_x + + !============================================================================= + pure function calc_corr_rt_x( crt_i, sigma_rt_i, sigma_chi_i, & + sigma_eta_i, corr_chi_x_i, corr_eta_x_i ) & + result( corr_rt_x_i ) + + ! Description: + ! This function calculates the correlation of rt and x based on the + ! correlation of chi and x and the correlation of eta and x. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + two, & ! Constant(s) + zero, & + rt_tol, & + max_mag_correlation + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + crt_i, & ! Coef. of r_t in chi/eta eqns. (ith PDF component) [-] + sigma_rt_i, & ! Standard deviation of r_t (ith PDF component) [kg/kg] + sigma_chi_i, & ! Standard deviation of chi (ith PDF component) [kg/kg] + sigma_eta_i, & ! Standard deviation of eta (ith PDF component) [kg/kg] + corr_chi_x_i, & ! Correlation of chi and x (ith PDF component) [-] + corr_eta_x_i ! Correlation of eta and x (ith PDF component) [-] + + ! Return Variable + real( kind = core_rknd ) :: & + corr_rt_x_i ! Correlation of rt and x (ith PDF component) [-] + + + ! Calculate the correlation of rt and x in the ith PDF component. + if ( sigma_rt_i > rt_tol ) then + + corr_rt_x_i = ( sigma_eta_i * corr_eta_x_i & + + sigma_chi_i * corr_chi_x_i ) & + / ( two * crt_i * sigma_rt_i ) + + else ! sigma_rt_i = 0 + + ! The standard deviation of rt in the ith PDF component is 0. This means + ! that rt is constant within the ith PDF component, and the ith PDF + ! component covariance of rt and x is also 0. The correlation of rt and + ! x is undefined in the ith PDF component, so a value of 0 will be used. + corr_rt_x_i = zero + + endif + + ! Clip the magnitude of the correlation of rt and x in the ith PDF + ! component, just in case the correlations and standard deviations used in + ! calculating it are inconsistent, resulting in an unrealizable value for + ! corr_rt_x_i. + if ( corr_rt_x_i > max_mag_correlation ) then + corr_rt_x_i = max_mag_correlation + elseif ( corr_rt_x_i < -max_mag_correlation ) then + corr_rt_x_i = -max_mag_correlation + endif + + + return + + end function calc_corr_rt_x + + !============================================================================= + pure function calc_corr_thl_x( cthl_i, sigma_thl_i, sigma_chi_i, & + sigma_eta_i, corr_chi_x_i, corr_eta_x_i ) & + result( corr_thl_x_i ) + + ! Description: + ! This function calculates the correlation of thl and x based on the + ! correlation of chi and x and the correlation of eta and x. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + two, & ! Constant(s) + zero, & + thl_tol, & + max_mag_correlation + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + cthl_i, & ! Coef. of thl: chi/eta eqns. (ith PDF comp.) [(kg/kg)/K] + sigma_thl_i, & ! Standard deviation of thl (ith PDF component) [K] + sigma_chi_i, & ! Standard deviation of chi (ith PDF component) [kg/kg] + sigma_eta_i, & ! Standard deviation of eta (ith PDF component) [kg/kg] + corr_chi_x_i, & ! Correlation of chi and x (ith PDF component) [-] + corr_eta_x_i ! Correlation of eta and x (ith PDF component) [-] + + ! Return Variable + real( kind = core_rknd ) :: & + corr_thl_x_i ! Correlation of thl and x (ith PDF component) [-] + + + ! Calculate the correlation of thl and x in the ith PDF component. + if ( sigma_thl_i > thl_tol ) then + + corr_thl_x_i = ( sigma_eta_i * corr_eta_x_i & + - sigma_chi_i * corr_chi_x_i ) & + / ( two * cthl_i * sigma_thl_i ) + + else ! sigma_thl_i = 0 + + ! The standard deviation of thl in the ith PDF component is 0. This + ! means that thl is constant within the ith PDF component, and the ith + ! PDF component covariance of thl and x is also 0. The correlation of + ! thl and x is undefined in the ith PDF component, so a value of 0 will + ! be used. + corr_thl_x_i = zero + + endif + + ! Clip the magnitude of the correlation of thl and x in the ith PDF + ! component, just in case the correlations and standard deviations used in + ! calculating it are inconsistent, resulting in an unrealizable value for + ! corr_thl_x_i. + if ( corr_thl_x_i > max_mag_correlation ) then + corr_thl_x_i = max_mag_correlation + elseif ( corr_thl_x_i < -max_mag_correlation ) then + corr_thl_x_i = -max_mag_correlation + endif + + + return + + end function calc_corr_thl_x + + !============================================================================= + pure function calc_xp2( mu_x_1, mu_x_2, & + mu_x_1_n, mu_x_2_n, & + sigma_x_1, sigma_x_2, & + sigma_x_1_n, sigma_x_2_n, & + mixt_frac, x_frac_1, x_frac_2, & + x_mean ) & + result( xp2 ) + + ! Description: + ! Calculates the overall variance of x, , where the distribution of x + ! is a combination of a lognormal distribution and/or 0 in each PDF + ! component. The fraction of each component where x is lognormally + ! distributed (amd greater than 0) is x_frac_i (x_frac_1 and x_frac_2 for + ! PDF components 1 and 2, respectively). The fraction of each component + ! where x has a value of 0 is ( 1 - x_frac_i ). This function should be + ! called to calculate the total variance for x when is not provided + ! by a predictive (or other) equation. + ! + ! This function is used to calculate the overall variance for rain water + ! mixing ratio, , and the overall variance for rain drop + ! concentration, . The ratio of variance to mean-value-squared is + ! specified for the in-precip values of r_r and N_r within each PDF + ! component, allowing for the calculation of sigma_rr_i and sigma_Nr_i, + ! as well as sigma_rr_i_n and sigma_Nr_i_n. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + two, & ! Constant(s) + one, & + zero + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + mu_x_1, & ! Mean of x (1st PDF comp.) in x_frac [-] + mu_x_2, & ! Mean of x (2nd PDF comp.) in x_frac [-] + mu_x_1_n, & ! Mean of ln x (1st PDF comp.) in x_frac [-] + mu_x_2_n, & ! Mean of ln x (2nd PDF comp.) in x_frac [-] + sigma_x_1, & ! Standard deviation of x (1st PDF comp.) in x_frac [-] + sigma_x_2, & ! Standard deviation of x (2nd PDF comp.) in x_frac [-] + sigma_x_1_n, & ! Standard deviation of ln x (1st PDF comp.) in x_frac [-] + sigma_x_2_n, & ! Standard deviation of ln x (2nd PDF comp.) in x_frac [-] + mixt_frac, & ! Mixture fraction [-] + x_frac_1, & ! Fraction: x distributed lognormally (1st PDF comp.) [-] + x_frac_2, & ! Fraction: x distributed lognormally (2nd PDF comp.) [-] + x_mean ! Overall mean value of x [-] + + ! Return Variable + real( kind = core_rknd ) :: & + xp2 ! Overall variance of x [-] + + + ! Calculate overall variance of x, . + if ( sigma_x_1 == zero .and. sigma_x_2 == zero ) then + + ! The value of x is constant within both PDF components. + xp2 = ( mixt_frac * x_frac_1 * mu_x_1**2 & + + ( one - mixt_frac ) * x_frac_2 * mu_x_2**2 & + ) & + - x_mean**2 + + + elseif ( sigma_x_1 == zero ) then + + ! The value of x is constant within the 1st PDF component. + xp2 = ( mixt_frac * x_frac_1 * mu_x_1**2 & + + ( one - mixt_frac ) * x_frac_2 & + * exp( two * mu_x_2_n + two * sigma_x_2_n**2 ) & + ) & + - x_mean**2 + + + elseif ( sigma_x_2 == zero ) then + + ! The value of x is constant within the 2nd PDF component. + xp2 = ( mixt_frac * x_frac_1 & + * exp( two * mu_x_1_n + two * sigma_x_1_n**2 ) & + + ( one - mixt_frac ) * x_frac_2 * mu_x_2**2 & + ) & + - x_mean**2 + + + else ! sigma_x_1 and sigma_x_2 > 0 + + ! The value of x varies within both PDF component. + xp2 = ( mixt_frac * x_frac_1 & + * exp( two * mu_x_1_n + two * sigma_x_1_n**2 ) & + + ( one - mixt_frac ) * x_frac_2 & + * exp( two * mu_x_2_n + two * sigma_x_2_n**2 ) & + ) & + - x_mean**2 + + + endif + + + ! As a check, prevent negative values for hydrometeor variances due to + ! numerical loss of precision error. + if ( xp2 < zero ) then + xp2 = zero + endif + + + return + + end function calc_xp2 + +!=============================================================================== + +end module pdf_utilities diff --git a/models/atm/cam/src/physics/clubb/pos_definite_module.F90 b/models/atm/cam/src/physics/clubb/pos_definite_module.F90 index 51ee7e64df5b..e0bffd4bce66 100644 --- a/models/atm/cam/src/physics/clubb/pos_definite_module.F90 +++ b/models/atm/cam/src/physics/clubb/pos_definite_module.F90 @@ -1,4 +1,6 @@ -!$Id: pos_definite_module.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +!------------------------------------------------------------------------- +!$Id: pos_definite_module.F90 7140 2014-07-31 19:14:05Z betlej@uwm.edu $ +!=============================================================================== module pos_definite_module implicit none @@ -53,8 +55,7 @@ subroutine pos_definite_adj & zero_threshold use clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd + core_rknd ! Variable(s) use error_code, only: & clubb_at_least_debug_level @@ -65,7 +66,7 @@ subroutine pos_definite_adj & intrinsic :: eoshift, kind, any, min, max ! Input variables - real(kind=time_precision), intent(in) :: & + real( kind = core_rknd ), intent(in) :: & dt ! Timestep [s] character(len=2), intent(in) :: & @@ -138,10 +139,10 @@ subroutine pos_definite_adj & flux_minus(k) = -min( zero_threshold, flux_np1(k) ) ! defined on flux levels if ( field_grid == "zm" ) then - dz_over_dt(k) = ( 1._core_rknd/gr%invrs_dzm(k) ) / real( dt, kind = core_rknd ) + dz_over_dt(k) = ( 1._core_rknd/gr%invrs_dzm(k) ) / dt else if ( field_grid == "zt" ) then - dz_over_dt(k) = ( 1._core_rknd/gr%invrs_dzt(k) ) / real( dt, kind = core_rknd ) + dz_over_dt(k) = ( 1._core_rknd/gr%invrs_dzt(k) ) / dt end if @@ -192,24 +193,24 @@ subroutine pos_definite_adj & flux_lim(1) = flux_np1(1) flux_lim(gr%nz) = flux_np1(gr%nz) - flux_pd = ( flux_lim - flux_np1 ) / real( dt, kind = core_rknd ) + flux_pd = ( flux_lim - flux_np1 ) / dt field_nonlim = field_np1 ! Apply change to field at n+1 if ( field_grid == "zt" ) then - field_np1 = -real( dt, kind = core_rknd ) * ddzm( flux_lim - flux_np1 ) + field_np1 + field_np1 = -dt * ddzm( flux_lim - flux_np1 ) + field_np1 else if ( field_grid == "zm" ) then - field_np1 = -real( dt, kind = core_rknd ) * ddzt( flux_lim - flux_np1 ) + field_np1 + field_np1 = -dt * ddzt( flux_lim - flux_np1 ) + field_np1 end if ! Determine the total time tendency in field due to this calculation ! (for diagnostic purposes) - field_pd = ( field_np1 - field_nonlim ) / real( dt, kind = core_rknd ) + field_pd = ( field_np1 - field_nonlim ) / dt ! Replace the non-limited flux with the limited flux flux_np1 = flux_lim diff --git a/models/atm/cam/src/physics/clubb/recl.inc b/models/atm/cam/src/physics/clubb/recl.inc index 267b70e4db3b..c5eb02a57c58 100644 --- a/models/atm/cam/src/physics/clubb/recl.inc +++ b/models/atm/cam/src/physics/clubb/recl.inc @@ -1,5 +1,5 @@ !------------------------------------------------------------------------------- -! $Id: recl.inc 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +! $Id: recl.inc 6938 2014-06-09 21:29:40Z bmg2@uwm.edu $ ! Description: ! Preprocessing rules for determining how large an unformatted ! data record is when using Fortran write. This does not affect @@ -17,7 +17,7 @@ !------------------------------------------------------------------------------- #if defined GFDL /* F_RECL should be 4 for the GFDL SCM-CLUBB */ # define F_RECL 4 -#elif defined __INTEL_COMPILER && __INTEL_COMPILER >= 800 /* Versions of Intel fortran > 8.0_core_rknd */ +#elif defined __INTEL_COMPILER && __INTEL_COMPILER >= 800 /* Versions of Intel fortran > 8.0 */ # define F_RECL 1 #elif defined(__alpha) /* Assume 4 byte word on Alpha processors */ # define F_RECL 1 diff --git a/models/atm/cam/src/physics/clubb/saturation.F90 b/models/atm/cam/src/physics/clubb/saturation.F90 index 36ea5c45242d..8410290bafb3 100644 --- a/models/atm/cam/src/physics/clubb/saturation.F90 +++ b/models/atm/cam/src/physics/clubb/saturation.F90 @@ -1,5 +1,6 @@ -!$Id: saturation.F90 5630 2012-01-18 16:20:31Z connork@uwm.edu $ -!----------------------------------------------------------------------- +!------------------------------------------------------------------------- +!$Id: saturation.F90 6849 2014-04-22 21:52:30Z charlass@uwm.edu $ +!=============================================================================== module saturation ! Description: @@ -28,7 +29,6 @@ module saturation ! Lookup table of values for saturation real( kind = core_rknd ), private, dimension(188:343) :: & svp_liq_lookup_table -!$omp threadprivate(svp_liq_lookup_table) data svp_liq_lookup_table(188:343) / & 0.049560547_core_rknd, 0.059753418_core_rknd, 0.070129395_core_rknd, 0.083618164_core_rknd, & @@ -71,6 +71,8 @@ module saturation 22723.592_core_rknd, 23779.273_core_rknd, 24876.709_core_rknd, 26017.258_core_rknd, & 27202.3_core_rknd, 28433.256_core_rknd, 29711.578_core_rknd, 31038.766_core_rknd / +!$omp threadprivate(svp_liq_lookup_table) + contains !------------------------------------------------------------------------- @@ -84,8 +86,7 @@ elemental real( kind = core_rknd ) function sat_mixrat_liq( p_in_Pa, T_in_K ) !------------------------------------------------------------------------- use constants_clubb, only: & - ep, & ! Variable - fstderr + ep ! Variable use clubb_precision, only: & core_rknd ! Variable(s) @@ -115,10 +116,10 @@ elemental real( kind = core_rknd ) function sat_mixrat_liq( p_in_Pa, T_in_K ) ! GFDL uses specific humidity ! Formula for Saturation Specific Humidity - if( I_sat_sphum ) then ! h1g, 2010-06-18 begin mod - sat_mixrat_liq = ep * ( esatv / ( p_in_Pa - (1.0_core_rknd-ep) * esatv ) ) + if ( I_sat_sphum ) then ! h1g, 2010-06-18 begin mod + sat_mixrat_liq = ep * ( esatv / ( p_in_Pa - (1.0_core_rknd-ep) * esatv ) ) else - sat_mixrat_liq = ep * ( esatv / ( p_in_Pa - esatv ) ) + sat_mixrat_liq = ep * ( esatv / ( p_in_Pa - esatv ) ) endif ! h1g, 2010-06-18 end mod #else ! Formula for Saturation Mixing Ratio: @@ -147,8 +148,7 @@ elemental real( kind = core_rknd ) function sat_mixrat_liq_lookup( p_in_Pa, T_in !------------------------------------------------------------------------- use constants_clubb, only: & - ep, & ! Variable - fstderr + ep ! Variable use clubb_precision, only: & core_rknd ! Variable(s) @@ -237,13 +237,14 @@ elemental function sat_vapor_press_liq( T_in_K ) result ( esat ) ! Using the Flatau, et al. polynomial approximation for SVP over vapor esat = sat_vapor_press_liq_flatau( T_in_K ) - ! Add new cases after this ! ---> h1g case ( saturation_gfdl ) ! Using GFDL polynomial approximation for SVP with respect to liquid esat = sat_vapor_press_liq_gfdl( T_in_K ) ! <--- h1g + ! Add new cases after this + end select return @@ -311,6 +312,8 @@ elemental function sat_vapor_press_liq_flatau( T_in_K ) result ( esat ) implicit none + ! Constant parameters + ! Relative error norm expansion (-50 to 50 deg_C) from ! Table 3 of pp. 1510 of Flatau et al. 1992 (Water Vapor) ! (The 100 coefficient converts from mb to Pa) @@ -318,6 +321,7 @@ elemental function sat_vapor_press_liq_flatau( T_in_K ) result ( esat ) ! 100.* (/ 6.11176750, 0.443986062, 0.143053301E-01, & ! 0.265027242E-03, 0.302246994E-05, 0.203886313E-07, & ! 0.638780966E-10 /) + ! Relative error norm expansion (-85 to 70 deg_C) from ! Table 4 of pp. 1511 of Flatau et al. real( kind = core_rknd ), dimension(9), parameter :: a = & @@ -326,6 +330,8 @@ elemental function sat_vapor_press_liq_flatau( T_in_K ) result ( esat ) 0.264224321E-03_core_rknd, 0.299291081E-05_core_rknd, 0.203154182E-07_core_rknd, & 0.702620698E-10_core_rknd, 0.379534310E-13_core_rknd,-0.321582393E-15_core_rknd /) + real( kind = core_rknd ), parameter :: min_T_in_C = -85._core_rknd ! [deg_C] + ! Input Variables real( kind = core_rknd ), intent(in) :: T_in_K ! Temperature [K] @@ -343,7 +349,7 @@ elemental function sat_vapor_press_liq_flatau( T_in_K ) result ( esat ) ! Since this approximation is only good out to -85 degrees Celsius we ! truncate the result here (Flatau, et al. 1992) - T_in_C = max( T_in_C, -85._core_rknd ) ! Known magic number + T_in_C = max( T_in_C, min_T_in_C ) ! Polynomial approx. (Flatau, et al. 1992) @@ -424,7 +430,7 @@ elemental function sat_vapor_press_liq_gfdl( T_in_K ) result ( esat ) ! Output Variables real( kind = core_rknd ) :: esat ! Saturation vapor pressure over water [Pa] -! Goff Gatch equation, uncertain below -70 C + ! Goff Gatch equation, uncertain below -70 C esat = 10._core_rknd**(-7.90298_core_rknd*(373.16_core_rknd/T_in_K-1._core_rknd)+ & 5.02808_core_rknd*log10(373.16_core_rknd/T_in_K)- & @@ -584,6 +590,9 @@ elemental function sat_vapor_press_ice_flatau( T_in_K ) result ( esati ) 0.402737184E-03_core_rknd, 0.565392987E-05_core_rknd, 0.521693933E-07_core_rknd, & 0.307839583E-09_core_rknd, 0.105785160E-11_core_rknd, 0.161444444E-14_core_rknd /) + real( kind = core_rknd ), parameter :: min_T_in_C = -90._core_rknd ! [deg_C] + + ! Input Variables real( kind = core_rknd ), intent(in) :: T_in_K ! Temperature [deg_K] @@ -601,7 +610,7 @@ elemental function sat_vapor_press_ice_flatau( T_in_K ) result ( esati ) ! Since this approximation is only good out to -90 degrees Celsius we ! truncate the result here (Flatau, et al. 1992) - T_in_C = max( T_in_C, -90._core_rknd ) ! Known magic number + T_in_C = max( T_in_C, min_T_in_C ) ! Polynomial approx. (Flatau, et al. 1992) ! esati = a(1) @@ -626,7 +635,6 @@ elemental function sat_vapor_press_ice_bolton( T_in_K ) result ( esati ) ! References: ! Bolton 1980 !------------------------------------------------------------------------ - use constants_clubb, only: T_freeze_K use clubb_precision, only: & core_rknd ! Variable(s) @@ -674,9 +682,9 @@ elemental function sat_vapor_press_ice_gfdl( T_in_K ) result ( esati ) ! Output Variables real( kind = core_rknd ) :: esati ! Saturation vapor pressure over ice [Pa] -! Goff Gatch equation (good down to -100 C) + ! Goff Gatch equation (good down to -100 C) - esati = 10._core_rknd**(-9.09718_core_rknd* & + esati = 10._core_rknd**(-9.09718_core_rknd* & (273.16_core_rknd/T_in_k-1._core_rknd)-3.56654_core_rknd* & log10(273.16_core_rknd/T_in_k)+0.876793_core_rknd* & (1._core_rknd-T_in_k/273.16_core_rknd)+ & @@ -688,7 +696,7 @@ end function sat_vapor_press_ice_gfdl ! <--- h1g, 2010-06-16 !------------------------------------------------------------------------- - FUNCTION rcm_sat_adj( thlm, rtm, p_in_Pa, exner ) result ( rcm ) + function rcm_sat_adj( thlm, rtm, p_in_Pa, exner ) result ( rcm ) ! Description: ! @@ -740,39 +748,42 @@ FUNCTION rcm_sat_adj( thlm, rtm, p_in_Pa, exner ) result ( rcm ) ! Default initialization theta = thlm too_high = 0.0_core_rknd - too_low = 0.0_core_rknd + too_low = 0.0_core_rknd - DO iteration = 1, itermax, 1 + do iteration = 1, itermax, 1 answer = & theta - (Lv/(Cp*exner)) & *(MAX( rtm - sat_mixrat_liq(p_in_Pa,theta*exner), zero_threshold )) - IF ( ABS(answer - thlm) <= tolerance ) THEN - EXIT - ELSEIF ( answer - thlm > tolerance ) THEN + if ( ABS(answer - thlm) <= tolerance ) then + exit + else if ( answer - thlm > tolerance ) then too_high = theta - ELSEIF ( thlm - answer > tolerance ) THEN + else if ( thlm - answer > tolerance ) THEN too_low = theta - ENDIF + end if ! For the first timestep, be sure to set a "too_high" ! that is "way too high." - IF ( iteration == 1 ) THEN + if ( iteration == 1 ) then too_high = theta + 20.0_core_rknd - ENDIF + end if theta = (too_low + too_high)/2.0_core_rknd - END DO ! 1..itermax + end do ! 1..itermax if ( iteration == itermax ) then + ! Magic Eric Raut added to remove compiler warning (clearly this value is not used) + rcm = 0.0_core_rknd + stop "Error in rcm_sat_adj: could not determine rcm" else rcm = MAX( rtm - sat_mixrat_liq( p_in_Pa, theta*exner), zero_threshold ) return end if - END FUNCTION rcm_sat_adj + end function rcm_sat_adj end module saturation diff --git a/models/atm/cam/src/physics/clubb/setup_clubb_pdf_params.F90 b/models/atm/cam/src/physics/clubb/setup_clubb_pdf_params.F90 new file mode 100644 index 000000000000..a94758c2c5d8 --- /dev/null +++ b/models/atm/cam/src/physics/clubb/setup_clubb_pdf_params.F90 @@ -0,0 +1,4627 @@ +!------------------------------------------------------------------------- +! $Id: setup_clubb_pdf_params.F90 7379 2014-11-11 05:32:53Z bmg2@uwm.edu $ +!=============================================================================== +module setup_clubb_pdf_params + + implicit none + + private + + public :: setup_pdf_parameters, & + compute_mean_stdev, & + normalize_mean_stdev, & + compute_corr, & + normalize_corr + + private :: component_means_hydromet_orig, & + component_means_hydromet_corr, & + precip_fraction, & + component_mean_hm_ip, & + component_stdev_hm_ip, & + component_corr_w_x, & + component_corr_chi_eta, & + component_corr_w_hm_ip, & + component_corr_x_hm_ip, & + component_corr_hmx_hmy_ip, & + calc_corr_w_hm, & + pdf_param_hm_stats, & + pdf_param_ln_hm_stats, & + pack_pdf_params + + ! Prescribed parameters are set to in-cloud or outside-cloud (below-cloud) + ! values based on whether or not cloud water mixing ratio has a value of at + ! least rc_tol. However, this does not take into account the amount of + ! cloudiness in a component, just whether or not there is any cloud in the + ! component. The option l_interp_prescribed_params allows for an interpolated + ! value between the in-cloud and below-cloud parameter value based on the + ! component cloud fraction. + logical, parameter, private :: & + l_interp_prescribed_params = .false. + + contains + + !============================================================================= + subroutine setup_pdf_parameters( nz, d_variables, dt, rho, & ! Intent(in) + Nc_in_cloud, rcm, cloud_frac, & ! Intent(in) + ice_supersat_frac, hydromet, wphydrometp, & ! Intent(in) + corr_array_cloud, corr_array_below, & ! Intent(in) + pdf_params, l_stats_samp, & ! Intent(in) + hydrometp2, & ! Intent(inout) + mu_x_1_n, mu_x_2_n, & ! Intent(out) + sigma_x_1_n, sigma_x_2_n, & ! Intent(out) + corr_array_1_n, corr_array_2_n, & ! Intent(out) + corr_cholesky_mtx_1, corr_cholesky_mtx_2, & ! Intent(out) + hydromet_pdf_params ) ! Intent(out) + + ! Description: + + ! References: + !----------------------------------------------------------------------- + + use grid_class, only: & + gr, & ! Variable(s) + zm2zt, & ! Procedure(s) + zt2zm + + use constants_clubb, only: & + one, & ! Constant(s) + zero, & + rc_tol, & + Ncn_tol, & + fstderr, & + zero_threshold + + use pdf_parameter_module, only: & + pdf_parameter ! Variable(s) + + use hydromet_pdf_parameter_module, only: & + hydromet_pdf_parameter, & ! Type + init_hydromet_pdf_params ! Procedure + + use parameters_model, only: & + hydromet_dim ! Variable(s) + + use model_flags, only: & + l_use_precip_frac, & ! Flag(s) + l_calc_w_corr + + use array_index, only: & + hydromet_list, & ! Variable(s) + hydromet_tol + + use model_flags, only: & + l_const_Nc_in_cloud ! Flag(s) + + use Nc_Ncn_eqns, only: & + Nc_in_cloud_to_Ncnm ! Procedure(s) + + use advance_windm_edsclrm_module, only: & + xpwp_fnc + + use variables_diagnostic_module, only: & + Kh_zm + + use parameters_tunable, only: & + c_K_hm + + use pdf_utilities, only: & + calc_xp2, & ! Procedure(s) + compute_mean_binormal, & + compute_variance_binormal + + use clip_explicit, only: & + clip_covar_level, & ! Procedure(s) + clip_wphydrometp ! Variables(s) + + use clubb_precision, only: & + core_rknd, & ! Variable(s) + dp + + use matrix_operations, only: & + Cholesky_factor, & ! Procedure(s) + mirror_lower_triangular_matrix + + use stats_type_utilities, only: & + stat_update_var, & ! Procedure(s) + stat_update_var_pt + + use stats_variables, only: & + ihm1, & ! Variable(s) + ihm2, & + iprecip_frac, & + iprecip_frac_1, & + iprecip_frac_2, & + iNcnm, & + ihmp2_zt, & + irtp2_from_chi, & + stats_zt, & + stats_zm + + use model_flags, only: & + l_diagnose_correlations ! Variable(s) + + use diagnose_correlations_module, only: & + diagnose_correlations, & ! Procedure(s) + calc_cholesky_corr_mtx_approx + + use corr_varnce_module, only: & + assert_corr_symmetric, & ! Procedure(s) + sigma2_on_mu2_ip_array_cloud, & ! Variable(s) + sigma2_on_mu2_ip_array_below, & + iiPDF_Ncn, & + iiPDF_chi, & + iiPDF_eta + + use index_mapping, only: & + hydromet2pdf_idx ! Procedure(s) + + use error_code, only : & + clubb_at_least_debug_level ! Procedure(s) + + implicit none + + ! Input Variables + integer, intent(in) :: & + nz, & ! Number of model vertical grid levels + d_variables ! Number of variables in the correlation array + + real( kind = core_rknd ), intent(in) :: & + dt ! Model timestep [s] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + rho, & ! Density [kg/m^3] + Nc_in_cloud ! Mean (in-cloud) cloud droplet concentration [num/kg] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + rcm, & ! Mean cloud water mixing ratio, < r_c > [kg/kg] + cloud_frac, & ! Cloud fraction [-] + ice_supersat_frac ! Ice supersaturation fraction [-] + + real( kind = core_rknd ), dimension(nz,hydromet_dim), intent(in) :: & + hydromet, & ! Mean of hydrometeor, hm (overall) (t-levs.) [units] + wphydrometp ! Covariance < w'h_m' > (momentum levels) [(m/s)units] + + real( kind = core_rknd ), dimension(d_variables,d_variables), & + intent(in) :: & + corr_array_cloud, & ! Prescribed correlation array in cloud [-] + corr_array_below ! Prescribed correlation array below cloud [-] + + type(pdf_parameter), dimension(nz), intent(in) :: & + pdf_params ! PDF parameters [units vary] + + logical, intent(in) :: & + l_stats_samp ! Flag to sample statistics + + ! Input/Output Variables + real( kind = core_rknd ), dimension(nz,hydromet_dim), intent(inout) :: & + hydrometp2 ! Variance of a hydrometeor (overall) (m-levs.) [units^2] + + ! Output Variables + real( kind = core_rknd ), dimension(d_variables,d_variables,nz), & + intent(out) :: & + corr_array_1_n, & ! Corr. array (normalized) of PDF vars. (comp. 1) [-] + corr_array_2_n ! Corr. array (normalized) of PDF vars. (comp. 2) [-] + + real( kind = core_rknd ), dimension(d_variables, nz), intent(out) :: & + mu_x_1_n, & ! Mean array (normalized) of PDF vars. (comp. 1) [un. vary] + mu_x_2_n, & ! Mean array (normalized) of PDF vars. (comp. 2) [un. vary] + sigma_x_1_n, & ! Std. dev. array (normalized) of PDF vars (comp. 1) [u.v.] + sigma_x_2_n ! Std. dev. array (normalized) of PDF vars (comp. 2) [u.v.] + + type(hydromet_pdf_parameter), dimension(nz), intent(out) :: & + hydromet_pdf_params ! Hydrometeor PDF parameters [units vary] + + real( kind = core_rknd ), dimension(d_variables,d_variables,nz), & + intent(out) :: & + corr_cholesky_mtx_1, & ! Transposed corr. cholesky matrix, 1st comp. [-] + corr_cholesky_mtx_2 ! Transposed corr. cholesky matrix, 2nd comp. [-] + + ! Local Variables + real( kind = dp ), dimension(d_variables,d_variables,nz) :: & + corr_cholesky_mtx_1_dp, & ! Used for call to Cholesky_factor, requires dp + corr_cholesky_mtx_2_dp + + real( kind = core_rknd ), dimension(d_variables,d_variables) :: & + corr_mtx_approx_1, & ! Approximated corr. matrix (C = LL'), 1st comp. [-] + corr_mtx_approx_2 ! Approximated corr. matrix (C = LL'), 2nd comp. [-] + + real( kind = core_rknd ), dimension(nz) :: & + mu_w_1, & ! Mean of w (1st PDF component) [m/s] + mu_w_2, & ! Mean of w (2nd PDF component) [m/s] + mu_chi_1, & ! Mean of chi (old s) (1st PDF component) [kg/kg] + mu_chi_2, & ! Mean of chi (old s) (2nd PDF component) [kg/kg] + sigma_w_1, & ! Standard deviation of w (1st PDF component) [m/s] + sigma_w_2, & ! Standard deviation of w (2nd PDF component) [m/s] + sigma_chi_1, & ! Standard deviation of chi (1st PDF component) [kg/kg] + sigma_chi_2, & ! Standard deviation of chi (2nd PDF component) [kg/kg] + rc_1, & ! Mean of r_c (1st PDF component) [kg/kg] + rc_2, & ! Mean of r_c (2nd PDF component) [kg/kg] + cloud_frac_1, & ! Cloud fraction (1st PDF component) [-] + cloud_frac_2, & ! Cloud fraction (2nd PDF component) [-] + mixt_frac ! Mixture fraction [-] + + real( kind = core_rknd ), dimension(nz) :: & + Ncnm ! Mean cloud nuclei concentration, < N_cn > [num/kg] + + real( kind = core_rknd ), dimension(nz) :: & + wpchip_zm, & ! Covariance of chi and w (momentum levels) [(m/s)(kg/kg)] + wpNcnp_zm, & ! Covariance of N_cn and w (momentum levs.) [(m/s)(num/kg)] + wpchip_zt, & ! Covariance of chi and w on t-levs [(m/s)(kg/kg)] + wpNcnp_zt ! Covariance of N_cn and w on t-levs [(m/s)(num/kg)] + + real( kind = core_rknd ), dimension(nz,hydromet_dim) :: & + hm1, & ! Mean of a precip. hydrometeor (1st PDF component) [units vary] + hm2 ! Mean of a precip. hydrometeor (2nd PDF component) [units vary] + + real( kind = core_rknd ), dimension(nz,hydromet_dim) :: & + hydrometp2_zt, & ! Variance of a hydrometeor (overall); t-lev [units^2] + wphydrometp_zt ! Covariance of w and hm interp. to t-levs. [(m/s)units] + + real( kind = core_rknd ), dimension(nz) :: & + precip_frac, & ! Precipitation fraction (overall) [-] + precip_frac_1, & ! Precipitation fraction (1st PDF component) [-] + precip_frac_2 ! Precipitation fraction (2nd PDF component) [-] + + real( kind = core_rknd ), dimension(d_variables,d_variables) :: & + corr_array_1, & ! Correlation array of PDF vars. (comp. 1) [-] + corr_array_2 ! Correlation array of PDF vars. (comp. 2) [-] + + real( kind = core_rknd ), dimension(d_variables) :: & + mu_x_1, & ! Mean array of PDF vars. (1st PDF component) [units vary] + mu_x_2, & ! Mean array of PDF vars. (2nd PDF component) [units vary] + sigma_x_1, & ! Standard deviation array of PDF vars (comp. 1) [units vary] + sigma_x_2 ! Standard deviation array of PDF vars (comp. 2) [units vary] + + real( kind = dp ), dimension(d_variables) :: & + corr_array_scaling + + real( kind = core_rknd ), dimension(d_variables) :: & + sigma2_on_mu2_ip_1, & ! Prescribed ratio array: sigma_hm_1^2/mu_hm_1^2 [-] + sigma2_on_mu2_ip_2 ! Prescribed ratio array: sigma_hm_2^2/mu_hm_2^2 [-] + + real( kind = core_rknd ) :: & + const_Ncnp2_on_Ncnm2, & ! Prescribed ratio of to ^2 [-] + const_corr_chi_Ncn ! Prescribed correlation of chi (old s) & Ncn [-] + + real( kind = core_rknd ), dimension(nz,hydromet_dim) :: & + wphydrometp_chnge ! Change in wphydrometp_zt: covar. clip. [(m/s)units] + + real( kind = core_rknd ), dimension(nz) :: & + wm_zt, & ! Mean vertical velocity, , on thermo. levels [m/s] + wp2_zt ! Variance of w, (interp. to t-levs.) [m^2/s^2] + + real( kind = core_rknd ), dimension(nz) :: & + rtp2_zt_from_chi + + logical :: l_corr_array_scaling + + ! Flags used for covariance clipping of . + logical, parameter :: & + l_first_clip_ts = .true., & ! First instance of clipping in a timestep. + l_last_clip_ts = .true. ! Last instance of clipping in a timestep. + + character(len=10) :: & + hydromet_name ! Name of a hydrometeor + + integer, parameter :: & + comp_means_hm_type = 1 ! Option used to calculated hm1 and hm2. + + integer :: pdf_idx ! Index of precipitating hydrometeor in PDF array. + + integer :: k, i ! Loop indices + + ! ---- Begin Code ---- + + ! Assertion check + ! Check that all hydrometeors are positive otherwise exit the program + if ( clubb_at_least_debug_level( 2 ) ) then + do i = 1, hydromet_dim + if ( any( hydromet(:,i) < zero_threshold ) ) then + hydromet_name = hydromet_list(i) + do k = 1, nz + if ( hydromet(k,i) < zero_threshold ) then + + ! Write error message + write(fstderr,*) trim( hydromet_name )//" = ", & + hydromet(k,i), " < ", zero_threshold, & + " at beginning of setup_pdf_parameters" & + //" at k = ", k + + ! Exit program + stop "Exiting..." + + endif ! hydromet(k,i) < 0 + enddo ! k = 1, nz + endif ! hydromet(:,i) < 0 + enddo ! i = 1, hydromet_dim + + endif !clubb_at_least_debug_level( 2 ) + + ! Interpolate the variances (overall) of precipitating hydrometeors and the + ! covariances (overall) of w and precipitating hydrometeors to thermodynamic + ! grid levels. + do i = 1, hydromet_dim, 1 + + hydrometp2_zt(:,i) = max( zm2zt( hydrometp2(:,i) ), zero_threshold ) + wphydrometp_zt(:,i) = zm2zt( wphydrometp(:,i) ) + + ! When the mean value of a precipitating hydrometeor is below tolerance + ! value, it is considered to have a value of 0, and the precipitating + ! hydrometeor does not vary over the grid level. The variance of that + ! precipitating hydrometeor and any covariance involving that + ! precipitating hydrometeor also have values of 0 at that grid level. + do k = 1, nz, 1 + if ( hydromet(k,i) <= hydromet_tol(i) ) then + hydrometp2_zt(k,i) = zero + wphydrometp_zt(k,i) = zero + endif + enddo ! k = 1, nz, 1 + + enddo ! i = 1, hydromet_dim, 1 + + ! Setup some of the PDF parameters + mu_w_1 = pdf_params%w_1 + mu_w_2 = pdf_params%w_2 + mu_chi_1 = pdf_params%chi_1 + mu_chi_2 = pdf_params%chi_2 + sigma_w_1 = sqrt( pdf_params%varnce_w_1 ) + sigma_w_2 = sqrt( pdf_params%varnce_w_2 ) + sigma_chi_1 = pdf_params%stdev_chi_1 + sigma_chi_2 = pdf_params%stdev_chi_2 + rc_1 = pdf_params%rc_1 + rc_2 = pdf_params%rc_2 + cloud_frac_1 = pdf_params%cloud_frac_1 + cloud_frac_2 = pdf_params%cloud_frac_2 + mixt_frac = pdf_params%mixt_frac + + ! Recalculate wm_zt and wp2_zt. Mean vertical velocity may not be easy to + ! pass into this subroutine from a host model, and wp2_zt needs to have a + ! value consistent with the value it had when the PDF parameters involving w + ! were originally set in subroutine pdf_closure. The variable wp2 has since + ! been advanced, resulting a new wp2_zt. However, the value of wp2 here + ! needs to be consistent with wp2 at the time the PDF parameters were + ! calculated. + do k = 1, nz, 1 + + ! Calculate the overall mean of vertical velocity, w, on thermodynamic + ! levels. + wm_zt(k) = compute_mean_binormal( mu_w_1(k), mu_w_2(k), mixt_frac(k) ) + + ! Calculate the overall variance of vertical velocity on thermodynamic + ! levels. + wp2_zt(k) = compute_variance_binormal( wm_zt(k), mu_w_1(k), mu_w_2(k), & + sigma_w_1(k), sigma_w_2(k), & + mixt_frac(k) ) + + enddo + + ! Component mean values for r_r and N_r, and precipitation fraction. + if ( l_use_precip_frac ) then + + if ( comp_means_hm_type == 1 ) then + + ! Original formulation to calculate hm1 and hm2 based on + ! liquid water path at or above a given grid level. + call component_means_hydromet_orig( nz, hydromet, rho, rc_1, rc_2, & + mixt_frac, l_stats_samp, & + hm1, hm2 ) + + elseif ( comp_means_hm_type == 2 ) then + + ! New formulations to calculate hm1 and hm2 based on the overall + ! correlation between w and the hydrometeor species. + call component_means_hydromet_corr( nz, hydromet, wphydrometp_zt, & + hydrometp2_zt, wp2_zt, & + mixt_frac, l_stats_samp, & + hm1, hm2 ) + + else + + write(fstderr,*) "Invalid option to calculate hm1 and hm2." + stop + + endif ! comp_means_hm_type + + call precip_fraction( nz, hydromet, hm1, hm2, & + cloud_frac, cloud_frac_1, mixt_frac, & + ice_supersat_frac, & + precip_frac, precip_frac_1, precip_frac_2 ) + + else + + hm1 = hydromet + hm2 = hydromet + + precip_frac = one + precip_frac_1 = one + precip_frac_2 = one + + endif + + ! Calculate from Nc_in_cloud, whether Nc_in_cloud is predicted or + ! based on a prescribed value, and whether the value is constant or varying + ! over the grid level. + if ( .not. l_const_Nc_in_cloud ) then + ! Ncn varies at each vertical level. + const_Ncnp2_on_Ncnm2 = sigma2_on_mu2_ip_array_cloud(iiPDF_Ncn) + else ! l_const_Nc_in_cloud + ! Ncn is constant at each vertical level. + const_Ncnp2_on_Ncnm2 = zero + endif + + const_corr_chi_Ncn = corr_array_cloud(iiPDF_Ncn, iiPDF_chi) + + do k = 2, nz + + Ncnm(k) & + = Nc_in_cloud_to_Ncnm( mu_chi_1(k), mu_chi_2(k), sigma_chi_1(k), & + sigma_chi_2(k), mixt_frac(k), Nc_in_cloud(k), & + cloud_frac_1(k), cloud_frac_2(k), & + const_Ncnp2_on_Ncnm2, const_corr_chi_Ncn ) + + enddo ! k = 2, nz + + ! Boundary Condition. + ! At thermodynamic level k = 1, which is below the model lower boundary, the + ! value of Ncnm does not matter. + Ncnm(1) = Nc_in_cloud(1) + + ! Calculate correlations involving w by first calculating total covariances + ! involving w (, etc.) using the down-gradient approximation. + if ( l_calc_w_corr ) then + + ! Calculate the covariances of w with the hydrometeors + do k = 1, nz + wpchip_zm(k) = pdf_params(k)%mixt_frac & + * ( one - pdf_params(k)%mixt_frac ) & + * ( pdf_params(k)%chi_1 - pdf_params(k)%chi_2 ) & + * ( pdf_params(k)%w_1 - pdf_params(k)%w_2 ) + enddo + + wpNcnp_zm(1:nz-1) = xpwp_fnc( -c_K_hm * Kh_zm(1:nz-1), Ncnm(1:nz-1), & + Ncnm(2:nz), gr%invrs_dzm(1:nz-1) ) + + ! Boundary conditions; We are assuming zero flux at the top. + wpNcnp_zm(nz) = zero + + ! Interpolate the covariances to thermodynamic grid levels. + wpchip_zt = zm2zt( wpchip_zm ) + wpNcnp_zt = zm2zt( wpNcnp_zm ) + + ! When the mean value of Ncn is below tolerance value, it is considered + ! to have a value of 0, and Ncn does not vary over the grid level. Any + ! covariance involving Ncn also has a value of 0 at that grid level. + do k = 1, nz, 1 + if ( Ncnm(k) <= Ncn_tol ) then + wpNcnp_zt(k) = zero + endif + enddo ! k = 1, nz, 1 + + endif ! l_calc_w_corr + + ! Statistics + if ( l_stats_samp ) then + + do i = 1, hydromet_dim, 1 + + if ( ihm1(i) > 0 ) then + ! Mean of the precipitating hydrometeor in PDF component 1. + call stat_update_var( ihm1(i), hm1(:,i), stats_zt ) + endif + + if ( ihm2(i) > 0 ) then + ! Mean of the precipitating hydrometeor in PDF component 2. + call stat_update_var( ihm2(i), hm2(:,i), stats_zt ) + endif + + enddo ! i = 1, hydromet_dim, 1 + + if ( iprecip_frac > 0 ) then + ! Overall precipitation fraction. + call stat_update_var( iprecip_frac, precip_frac, stats_zt ) + endif + + if ( iprecip_frac_1 > 0 ) then + ! Precipitation fraction in PDF component 1. + call stat_update_var( iprecip_frac_1, precip_frac_1, stats_zt ) + endif + + if ( iprecip_frac_2 > 0 ) then + ! Precipitation fraction in PDF component 2. + call stat_update_var( iprecip_frac_2, precip_frac_2, stats_zt ) + endif + + if ( iNcnm > 0 ) then + ! Mean simplified cloud nuclei concentration (overall). + call stat_update_var( iNcnm, Ncnm, stats_zt ) + endif + + endif + + + !!! Setup PDF parameters loop. + ! Loop over all model thermodynamic level above the model lower boundary. + ! Now also including "model lower boundary" -- Eric Raut Aug 2013 + ! Now not including "model lower boundary" -- Eric Raut Aug 2014 + do k = 2, nz, 1 + + if ( rc_1(k) > rc_tol ) then + sigma2_on_mu2_ip_1 = sigma2_on_mu2_ip_array_cloud + else + sigma2_on_mu2_ip_1 = sigma2_on_mu2_ip_array_below + endif + + if ( rc_2(k) > rc_tol ) then + sigma2_on_mu2_ip_2 = sigma2_on_mu2_ip_array_cloud + else + sigma2_on_mu2_ip_2 = sigma2_on_mu2_ip_array_below + endif + + !!! Calculate the means and standard deviations involving PDF variables + !!! -- w, chi, eta, N_cn, and any precipitating hydrometeors (hm in-precip) + !!! -- for each PDF component. + call compute_mean_stdev( Ncnm(k), rc_1(k), rc_2(k), & ! Intent(in) + cloud_frac_1(k), cloud_frac_2(k), & ! Intent(in) + hm1(k,:), hm2(k,:), & ! Intent(in) + precip_frac_1(k), precip_frac_2(k), & ! Intent(in) + sigma2_on_mu2_ip_array_cloud, & ! Intent(in) + sigma2_on_mu2_ip_array_below, & ! Intent(in) + pdf_params(k), d_variables, & ! Intent(in) + mu_x_1, mu_x_2, & ! Intent(out) + sigma_x_1, sigma_x_2 ) ! Intent(out) + + + !!! Calculate the normalized means and normalized standard deviations + !!! involving precipitating hydrometeors (hm in-precip) and N_cn -- + !!! ln hm and ln N_cn -- for each PDF component. + call normalize_mean_stdev( hm1(k,:), hm2(k,:), Ncnm(k), d_variables, & + mu_x_1, mu_x_2, sigma_x_1, sigma_x_2, & + sigma2_on_mu2_ip_1, sigma2_on_mu2_ip_2, & + mu_x_1_n(:,k), mu_x_2_n(:,k), & + sigma_x_1_n(:,k), sigma_x_2_n(:,k) ) + + ! Calculate the overall variance of a precipitating hydrometeor (hm), + ! . + do i = 1, hydromet_dim, 1 + + if ( hydromet(k,i) > hydromet_tol(i) ) then + + ! There is some of the hydrometeor species found at level k. + ! Calculate the variance (overall) of the hydrometeor. + + pdf_idx = hydromet2pdf_idx(i) + + hydrometp2_zt(k,i) & + = calc_xp2( mu_x_1(pdf_idx), mu_x_2(pdf_idx), & + mu_x_1_n(pdf_idx,k), mu_x_2_n(pdf_idx,k), & + sigma_x_1(pdf_idx), sigma_x_2(pdf_idx), & + sigma_x_1_n(pdf_idx,k), sigma_x_2_n(pdf_idx,k), & + mixt_frac(k), precip_frac_1(k), precip_frac_2(k), & + hydromet(k,i) ) + + else ! hydromet(k,i) = 0. + + hydrometp2_zt(k,i) = zero + + endif + + ! Statistics + if ( l_stats_samp ) then + + if ( ihmp2_zt(i) > 0 ) then + ! Variance (overall) of the hydrometeor, . + call stat_update_var_pt( ihmp2_zt(i), k, & + hydrometp2_zt(k,i), stats_zt ) + endif + + endif ! l_stats_samp + + ! Clip the value of covariance on thermodynamic levels. + call clip_covar_level( clip_wphydrometp, k, l_first_clip_ts, & + l_last_clip_ts, dt, wp2_zt(k), & + hydrometp2_zt(k,i), & + wphydrometp_zt(k,i), wphydrometp_chnge(k,i) ) + + enddo ! i = 1, hydromet_dim, 1 + + if ( l_diagnose_correlations ) then + + if ( rcm(k) > rc_tol ) then + + call diagnose_correlations( d_variables, corr_array_cloud, & ! Intent(in) + corr_array_1 ) ! Intent(out) + + call diagnose_correlations( d_variables, corr_array_cloud, & ! Intent(in) + corr_array_2 ) ! Intent(out) + + else + + call diagnose_correlations( d_variables, corr_array_below, & ! Intent(in) + corr_array_1 ) ! Intent(out) + + call diagnose_correlations( d_variables, corr_array_below, & ! Intent(in) + corr_array_2 ) ! Intent(out) + + endif + + else ! if .not. l_diagnose_correlations + + call compute_corr( wm_zt(k), rc_1(k), rc_2(k), cloud_frac_1(k), & + cloud_frac_2(k), wpchip_zt(k), wpNcnp_zt(k), & + sqrt(wp2_zt(k)), mixt_frac(k), precip_frac_1(k), & + precip_frac_2(k), wphydrometp_zt(k,:), & + mu_x_1, mu_x_2, sigma_x_1, sigma_x_2, & + corr_array_cloud, corr_array_below, & + pdf_params(k), d_variables, & + corr_array_1, corr_array_2 ) + + endif ! l_diagnose_correlations + + !!! Statistics for standard PDF parameters involving hydrometeors. + call pdf_param_hm_stats( d_variables, k, mu_x_1, mu_x_2, & + sigma_x_1, sigma_x_2, & + corr_array_1, corr_array_2, & + l_stats_samp ) + + !!! Calculate the correlations involving the natural logarithm of + !!! precipitating hydrometeors, ln hm (for example, ln r_r and ln N_r), + !!! and ln N_cn for each PDF component. + call normalize_corr( d_variables, sigma_x_1_n(:,k), sigma_x_2_n(:,k), & + sigma2_on_mu2_ip_1, sigma2_on_mu2_ip_2, & + corr_array_1, corr_array_2, & + corr_array_1_n(:,:,k), corr_array_2_n(:,:,k) ) + + + !!! Statistics for normalized PDF parameters involving hydrometeors. + call pdf_param_ln_hm_stats( d_variables, k, mu_x_1_n(:,k), & + mu_x_2_n(:,k), sigma_x_1_n(:,k), & + sigma_x_2_n(:,k), corr_array_1_n(:,:,k), & + corr_array_2_n(:,:,k), l_stats_samp ) + + !!! Pack the PDF parameters + call pack_pdf_params( hm1(k,:), hm2(k,:), d_variables, & ! In + mu_x_1, mu_x_2, sigma_x_1, sigma_x_2, & ! In + corr_array_1, corr_array_2, precip_frac(k), & ! In + precip_frac_1(k), precip_frac_2(k), & ! In + hydromet_pdf_params(k) ) ! Out + + if ( l_diagnose_correlations ) then + + call calc_cholesky_corr_mtx_approx & + ( d_variables, corr_array_1_n(:,:,k), & ! intent(in) + corr_cholesky_mtx_1(:,:,k), corr_mtx_approx_1 ) ! intent(out) + + call calc_cholesky_corr_mtx_approx & + ( d_variables, corr_array_2_n(:,:,k), & ! intent(in) + corr_cholesky_mtx_2(:,:,k), corr_mtx_approx_2 ) ! intent(out) + + corr_array_1_n(:,:,k) = corr_mtx_approx_1 + corr_array_2_n(:,:,k) = corr_mtx_approx_2 + + else + + ! Compute choleksy factorization for the correlation matrix (out of + ! cloud) + call Cholesky_factor( d_variables, real(corr_array_1_n(:,:,k), kind = dp), & ! In + corr_array_scaling, corr_cholesky_mtx_1_dp(:,:,k), & ! Out + l_corr_array_scaling ) ! Out + + call Cholesky_factor( d_variables, real(corr_array_2_n(:,:,k), kind = dp), & ! In + corr_array_scaling, corr_cholesky_mtx_2_dp(:,:,k), & ! Out + l_corr_array_scaling ) ! Out + corr_cholesky_mtx_1(:,:,k) = real( corr_cholesky_mtx_1_dp(:,:,k), kind = core_rknd ) + corr_cholesky_mtx_2(:,:,k) = real( corr_cholesky_mtx_2_dp(:,:,k), kind = core_rknd ) + endif + + ! For ease of use later in the code, we make the correlation arrays + ! symmetrical + call mirror_lower_triangular_matrix( d_variables, corr_array_1_n(:,:,k) ) + call mirror_lower_triangular_matrix( d_variables, corr_array_2_n(:,:,k) ) + + enddo ! Setup PDF parameters loop: k = 2, nz, 1 + + ! Boundary condition for the variance (overall) of a hydrometeor, , + ! on thermodynamic grid levels at the lowest thermodynamic grid level, k = 1 + ! (which is below the model lower boundary). + hydrometp2_zt(1,:) = hydrometp2_zt(2,:) + + ! Interpolate the overall variance of a hydrometeor, , to its home on + ! momentum grid levels. + do i = 1, hydromet_dim, 1 + hydrometp2(:,i) = zt2zm( hydrometp2_zt(:,i) ) + hydrometp2(nz,i) = zero + enddo + + if ( l_stats_samp ) then + if ( irtp2_from_chi > 0 ) then + rtp2_zt_from_chi & + = compute_rtp2_from_chi( pdf_params(:), & + corr_array_1_n(iiPDF_chi,iiPDF_eta,:), & + corr_array_2_n(iiPDF_chi,iiPDF_eta,:) ) + call stat_update_var( irtp2_from_chi, zt2zm( rtp2_zt_from_chi ), stats_zm ) + endif + endif + + + ! Boundary conditions for the output variables at k=1. + mu_x_1_n(:,1) = zero + mu_x_2_n(:,1) = zero + sigma_x_1_n(:,1) = zero + sigma_x_2_n(:,1) = zero + corr_array_1_n(:,:,1) = zero + corr_array_2_n(:,:,1) = zero + corr_cholesky_mtx_1(:,:,1) = zero + corr_cholesky_mtx_2(:,:,1) = zero + call init_hydromet_pdf_params( hydromet_pdf_params(1) ) + + if (clubb_at_least_debug_level( 2 )) then + do k = 2, nz + call assert_corr_symmetric( corr_array_1_n(:,:,k), d_variables ) + call assert_corr_symmetric( corr_array_2_n(:,:,k), d_variables ) + enddo + endif + + + return + + end subroutine setup_pdf_parameters + + !============================================================================= + subroutine component_means_hydromet_orig( nz, hydromet, rho, rc_1, rc_2, & + mixt_frac, l_stats_samp, & + hm1, hm2 ) + + ! Description: + ! The values of grid-level mean hydrometeor fields, , (for example, + ! grid-level mean rain water mixing ratio, , and grid-level mean rain + ! drop concentration, ) are solved as part of the predictive equation + ! set, based on the microphysics scheme. However, CLUBB has a two component + ! PDF. The grid-level means of all hydrometeors must be subdivided into + ! component means for each PDF component. The equation relating the overall + ! mean to the component means (for any hydrometeor, hm) is: + ! + ! = a * hm1 + (1-a) * hm2; + ! + ! where "a" is the mixture fraction (weight of the 1st PDF component), hm1 + ! is the mean of the hydrometeor in PDF component 1, and hm2 is the mean of + ! the hydrometeor in PDF component 2. This equation can be rewritten as: + ! + ! = hm1 * ( a + (1-a) * hm2/hm1 ). + ! + ! One way to solve for a component mean is to relate the ratio hm2/hm1 to + ! other factors. For now, this ratio based on other factors will be called + ! hm2_hm1_ratio. This ratio is entered into the above equation, allowing + ! the equation to be solved for hm1: + ! + ! hm1 = / ( a + (1-a) * hm2_hm1_ratio ). + ! + ! Once hm1 has been solved for, hm2 can be solved by: + ! + ! hm2 = ( - a * hm1 ) / (1-a). + ! + ! At a grid level that is at least mostly cloudy, the simplest way to handle + ! the ratio hm2/hm1 is to set it equal to the ratio rc_2/rc_1, where rc_1 is + ! the mean cloud water mixing ratio in PDF component 1 and rc_2 is the mean + ! cloud water mixing ratio in PDF component 2. However, a precipitating + ! hydrometeor sediments, falling from higher altitudes downwards. The + ! values of cloud water mixing ratio at a given grid level are not + ! necessarily indicative of the amount of cloud water at higher levels. A + ! precipitating hydrometeor may have been already produced from cloud water + ! at a higher altitude (vertical level) and fallen downwards to the given + ! grid level. Additionally, using grid-level cloud water mixing ratio + ! especially does not work for a precipitating hydrometeor below cloud base + ! (near the ground). + ! + ! However, an alternative to component cloud water mixing ratio is component + ! liquid water path. Liquid water path accounts for the cloud water mixing + ! ratio at the given grid level and at all grid levels higher in altitude. + ! + ! In a stratocumulus case, the cloud water is spread out over all or almost + ! all of the horizontal domain over a group of vertical levels. At a given + ! vertical level, the component mean cloud water mixing ratios should be + ! almost equal, although usually slightly larger in the component with the + ! larger component mean extended liquid water mixing ratio, s. Likewise, + ! the component liquid water paths should be nearly equal, with one + ! component having a slightly larger liquid water path than the other + ! component. + ! + ! In a case of cumulus rising into stratocumulus, the upper portion of the + ! cloudy domain will be very similar to the stratocumulus case described + ! above, with similar cloud water mixing ratio and liquid water path + ! results. However, below the base of the stratocumulus clouds, where the + ! cumulus clouds are found, the horizontal domain at each vertical level is + ! only partially cloudy. At these levels, any precipitating hydrometeor + ! that was produced in the stratocumulus clouds above and fallen downwards + ! is evaporating in the clear-air portions, while not evaporating in the + ! cloudy portions. Additionally, new amounts of a hydrometeor are being + ! produced in the cloudy portions. The amount of a hydrometeor in the + ! cloudy portions becomes significantly larger than the amount of a + ! hydrometeor in the clear portions. The partially cloudy levels usually + ! have a PDF where one component is significantly more saturated than the + ! other component. By the time the cloud base of the cumulus clouds is + ! reached, the liquid water path for one PDF component should be + ! significantly greater than the liquid water path for the other PDF + ! component. + ! + ! In a cumulus case, the horizontal domain at each level is usually partly + ! cloudy. Throughout the entire vertical domain, at every vertical level, + ! one component usually is much more saturated than the other component. + ! The liquid water path for one component is much greater than the liquid + ! water path in the other component. Likewise, a precipitating hydrometeor + ! that is formed in cloud and falls preferentially through cloud will have + ! large values in a portion of the horizontal domain and very small or 0 + ! values over the rest of the horizontal domain. + ! + ! In order to estimate the amount of a hydrometeor in each PDF component, + ! the ratio hm2/hm1 is going to be set equal to the ratio LWP2/LWP1, where + ! LWP1 is the liquid water path in PDF component 1 and LWP2 is the liquid + ! water path in PDF component 2. LWP1 will be computed by taking the + ! vertical integral of cloud water (see equation below) through the 1st PDF + ! component from the given vertical level all the way to the top of the + ! model. LWP2 will be computed in the same manner. It should be noted + ! that this method makes the poor assumption that PDF component 1 always + ! overlaps PDF component 1 between vertical levels, and likewise for PDF + ! component 2. + ! + ! Total liquid water path, LWP, is given by the following equation: + ! + ! LWP(z) = INT(z:z_top) rho_a dz'; + ! + ! where z is the altitude of the vertical level for which LWP is desired, + ! z_top is the altitude at the top of the model domain, and z' is the + ! dummy variable of integration. Mean cloud water mixing ratio can be + ! written as: + ! + ! = a * rc_1 + (1-a) * rc_2. + ! + ! The equation for liquid water path is rewritten as: + ! + ! LWP(z) = INT(z:z_top) rho_a ( a rc_1 + (1-a) rc_2 ) dz'; or + ! + ! LWP(z) = INT(z:z_top) a rho_a rc_1 dz' + ! + INT(z:z_top) (1-a) rho_a rc_2 dz'. + ! + ! This can be rewritten as: + ! + ! LWP(z) = LWP1(z) + LWP2(z); + ! + ! where: + ! + ! LWP1(z) = INT(z:z_top) a rho_a rc_1 dz'; and + ! LWP2(z) = INT(z:z_top) (1-a) rho_a rc_2 dz'. + ! + ! The trapezoidal rule will be used to numerically integrate for LWP1 + ! and LWP2. + + ! References: + !----------------------------------------------------------------------- + + use grid_class, only: & + gr ! Variable(s) + + use constants_clubb, only: & + one, & ! Constant(s) + one_half, & + zero + + use parameters_model, only: & + hydromet_dim ! Variable(s) + + use array_index, only: & + hydromet_tol ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use stats_type_utilities, only: & + stat_update_var ! Procedure(s) + + use stats_variables, only : & + iLWP1, & ! Variable(s) + iLWP2, & + stats_zt + + implicit none + + ! Input Variables + integer, intent(in) :: & + nz ! Number of model vertical grid levels + + real( kind = core_rknd ), dimension(nz,hydromet_dim), intent(in) :: & + hydromet ! Mean of hydrometeor, hm (overall) [units vary] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + rho, & ! Air density [kg/m^3] + rc_1, & ! Mean cloud water mixing ratio (1st PDF component) [kg/kg] + rc_2, & ! Mean cloud water mixing ratio (2nd PDF component) [kg/kg] + mixt_frac ! Mixture fraction [-] + + logical, intent(in) :: & + l_stats_samp ! Flag to record statistical output. + + ! Output Variables + real( kind = core_rknd ), dimension(nz,hydromet_dim), intent(out) :: & + hm1, & ! Mean of hydrometeor (1st PDF component) [units vary] + hm2 ! Mean of hydrometeor (2nd PDF component) [units vary] + + ! Local Variable + real( kind = core_rknd ), dimension(nz) :: & + LWP1, & ! Liquid water path (1st PDF component) on thermo. levs. [kg/m^2] + LWP2 ! Liquid water path (2nd PDF component) on thermo. levs. [kg/m^2] + + integer :: k, i ! Array index + + real( kind = core_rknd ), parameter :: & + LWP_tol = 5.0e-7_core_rknd ! Tolerance value for component LWP + + + !!! Compute component liquid water paths using trapezoidal rule for + !!! numerical integration. + + ! At the uppermost thermodynamic level (k = nz), use the trapezoidal rule: + ! + ! 0.5 * (integrand_a + integrand_b) * delta_z, + ! + ! where integrand_a is the integrand at thermodynamic level k = nz, + ! integrand_b is the integrand at momentum level k = nz (model upper + ! boundary), and delta_z = zm(nz) - zt(nz). At the upper boundary, r_c is + ! set to 0, and the form of the trapezoidal rule is simply: + ! + ! 0.5 * integrand_a * delta_z. + + ! Liquid water path in PDF component 1. + LWP1(nz) & + = one_half * mixt_frac(nz) * rho(nz) * rc_1(nz) * ( gr%zm(nz) - gr%zt(nz) ) + + ! Liquid water path in PDF component 2. + LWP2(nz) & + = one_half * ( one - mixt_frac(nz) ) * rho(nz) * rc_2(nz) & + * ( gr%zm(nz) - gr%zt(nz) ) + + ! At all other thermodynamic levels, compute liquid water path using the + ! trapezoidal rule: + ! + ! 0.5 * (integrand_a + integrand_b) * delta_z, + ! + ! where integrand_a is the integrand at thermodynamic level k, integrand_b + ! is the integrand at thermodynamic level k+1, and + ! delta_z = zt(k+1) - zt(k), or 1/invrs_dzm(k). The total for the segment + ! is added to the sum total of all higher vertical segments to compute the + ! total vertical integral. + do k = nz-1, 1, -1 + + ! Liquid water path in PDF component 1. + LWP1(k) & + = LWP1(k+1) & + + one_half * ( mixt_frac(k+1) * rho(k+1) * rc_1(k+1) & + + mixt_frac(k) * rho(k) * rc_1(k) ) / gr%invrs_dzm(k) + + ! Liquid water path in PDF component 2. + LWP2(k) & + = LWP2(k+1) & + + one_half * ( ( one - mixt_frac(k+1) ) * rho(k+1) * rc_2(k+1) & + + ( one - mixt_frac(k) ) * rho(k) * rc_2(k) ) & + / gr%invrs_dzm(k) + + enddo ! k = nz-1, 1, -1 + + + !!! Find hm1 and hm2 based on the ratio of LWP2/LWP1, such that: + !!! hm2/hm1 ( = rr2/rr1 = Nr2/Nr1, etc. ) = LWP2/LWP1. + do i = 1, hydromet_dim, 1 + + do k = 1, nz, 1 + + !!! Calculate the component means for the hydrometeor. + if ( hydromet(k,i) > hydromet_tol(i) ) then + + if ( LWP1(k) <= LWP_tol .and. LWP2(k) <= LWP_tol ) then + + ! Both LWP1 and LWP2 are 0 (or an insignificant amount). + ! + ! The hydrometeor is found at this level, yet there is no cloud + ! at or above the current level. This is usually due to a + ! numerical artifact. For example, the hydrometeor is diffused + ! above cloud top. Simply set each component mean equal to the + ! overall mean. + hm1(k,i) = hydromet(k,i) + hm2(k,i) = hydromet(k,i) + + elseif ( LWP1(k) > LWP_tol .and. LWP2(k) <= LWP_tol ) then + + ! LWP1 is (significantly) greater than 0, while LWP2 is 0 (or an + ! insignificant amount). + ! + ! The hydrometeor is found at this level, and all cloud water at + ! or above this level is found in the 1st PDF component. All of + ! the hydrometeor is found in the 1st PDF component. + hm1(k,i) = hydromet(k,i) / mixt_frac(k) + hm2(k,i) = zero + + elseif ( LWP2(k) > LWP_tol .and. LWP1(k) <= LWP_tol ) then + + ! LWP2 is (significantly) greater than 0, while LWP1 is 0 (or an + ! insignificant amount). + ! + ! The hydrometeor is found at this level, and all cloud water at + ! or above this level is found in the 2nd PDF component. All of + ! the hydrometeor is found in the 2nd PDF component. + hm1(k,i) = zero + hm2(k,i) = hydromet(k,i) / ( one - mixt_frac(k) ) + + else ! LWP1(k) > LWP_tol and LWP2(k) > LWP_tol + + ! Both LWP1 and LWP2 are (significantly) greater than 0. + ! + ! The hydrometeor is found at this level, and there is + ! sufficient cloud water at or above this level in both PDF + ! components to find the hydrometeor in both PDF components. + ! Delegate the hydrometeor between the 1st and 2nd PDF + ! components according to the above equations. + hm1(k,i) & + = hydromet(k,i) & + / ( mixt_frac(k) + ( one - mixt_frac(k) ) * LWP2(k)/LWP1(k) ) + + hm2(k,i) & + = ( hydromet(k,i) - mixt_frac(k) * hm1(k,i) ) & + / ( one - mixt_frac(k) ) + + if ( hm1(k,i) <= hydromet_tol(i) ) then + + ! The mean value of the hydrometeor within the 1st PDF + ! component is below the tolerance value for the hydrometeor. + ! It is considered to have a value of 0. All the the + ! hydrometeor is found within the 2nd PDF component. + hm1(k,i) = zero + hm2(k,i) = hydromet(k,i) / ( one - mixt_frac(k) ) + + elseif ( hm2(k,i) <= hydromet_tol(i) ) then + + ! The mean value of the hydrometeor within the 2nd PDF + ! component is below the tolerance value for the hydrometeor. + ! It is considered to have a value of 0. All the the + ! hydrometeor is found within the 1st PDF component. + hm1(k,i) = hydromet(k,i) / mixt_frac(k) + hm2(k,i) = zero + + endif + + endif + + + else ! hydromet(k,i) <= hydromet_tol(i) + + ! The overall hydrometeor is either 0 or below tolerance value (any + ! postive value is considered to be a numerical artifact). Simply + ! set each pdf component mean equal to 0. + hm1(k,i) = zero + hm2(k,i) = zero + + endif + + enddo ! k = 1, nz, 1 + + enddo ! i = 1, hydromet_dim, 1 + + + ! Statistics + if ( l_stats_samp ) then + + if ( iLWP1 > 0 ) then + ! Liquid water path in PDF component 1. + call stat_update_var( iLWP1, LWP1, stats_zt ) + endif + + if ( iLWP2 > 0 ) then + ! Liquid water path in PDF component 2. + call stat_update_var( iLWP2, LWP2, stats_zt ) + endif + + endif + + + return + + end subroutine component_means_hydromet_orig + + !============================================================================= + subroutine component_means_hydromet_corr( nz, hydromet, wphydrometp_zt, & + hydrometp2_zt, wp2_zt, & + mixt_frac, l_stats_samp, & + hm_1, hm_2 ) + + ! Description: + ! The values of grid-level mean hydrometeor fields, , (for example, + ! grid-level mean rain water mixing ratio, , and grid-level mean rain + ! drop concentration, ) are solved as part of the predictive equation + ! set, based on the microphysics scheme. However, CLUBB has a two component + ! PDF. The grid-level means of all hydrometeors must be subdivided into + ! component means for each PDF component. The equation relating the overall + ! mean to the component means (for any hydrometeor, hm) is: + ! + ! = a * hm_1 + (1-a) * hm_2; + ! + ! where "a" is the mixture fraction (weight of the 1st PDF component), hm_1 + ! is the mean of the hydrometeor in PDF component 1, and hm_2 is the mean of + ! the hydrometeor in PDF component 2. Both of these component means include + ! any precipitationless regions in each PDF component (when component + ! precipitation fraction < 1). + ! + ! The challenge is to divide into hm_1 and hm_2. One way to do this is + ! to base this on the overall correlation of vertical velocity, w, and the + ! hydrometeor, hm. When the overall correlation of w and hm is positive, + ! hm_1 > hm_2. Likewise, when the overall correlation of w and hm is + ! negative, hm_1 < hm_2. When the overall correlation of w and hm is 0, + ! hm_1 = hm_2. This method has the following advantages. + ! + ! 1) The main advantage is that this method aids the realizability of the + ! multivariate PDF in each PDF component, when the PDF is considered in + ! conjunction with the value of produced by the microphysics. + ! The ith PDF component, within-precip. correlation of w and hm + ! (corr_w_hm_i) can be calculated based on the overall covariance of w + ! and hm () and the other PDF parameters involving w and hm. The + ! value of is produced when is advanced one model timestep + ! in CLUBB's microphysics. In the past, the calculated value of + ! corr_w_hm_i has been unrealizable at some grid levels. This was + ! primarily due to the following issue. The code that calculated hm_1 + ! and hm_2 based on integrated rc in each component always placed a great + ! majority or all of the hydrometeor in PDF component 1 in cumulus cases, + ! regardless of grid level. Even in stratocumulus cases, hm_1 > hm_2. + ! In CLUBB, the 1st PDF component mean of w (w_1) is defined around the + ! updraft, while the 2nd PDF component mean of w (w_2) is defined around + ! the downdraft, which means that w_1 is always greater than or equal to + ! w_2. Since hm_1 > hm_2 and w_1 > w_2, the means of the components are + ! naturally associated with a positive value of covariance . In + ! the scenario where is negative at a grid level, the + ! within-component correlation corr_w_hm_i needed to be so negative to + ! produce , because of the hm_1/hm_2 and w1/w2 values, that it had + ! to be less than -1, which produces an unrealizable PDF. + ! + ! In this method, when microphysics produces a positive value of , + ! hm_1 > hm_2, and when microphysics produces a negtive value of , + ! hm_1 < hm_2. When microphysics produces a of 0, hm_1 = hm_2. + ! This will help keep the calculated values of corr_w_hm_i at realizable + ! values. + ! + ! 2) I have proposed a method to determine hm_1 amd hm_2 based on wind shear + ! (the change in speed and/or direction of horizontal winds with + ! altitude), which causes separation of updrafts and downdrafts in + ! nature. I am convinced that the profiles of hm_1 and hm_2 produced by + ! this overall-correlation-based method would be roughly similar to those + ! produced by a wind-shear-based method. + ! + ! 3) This method involves minimal calculations and is conceptually simple. + ! Any shear-based method would be conceptually complicated, and most + ! likely involve more calculation. This method is also a bit less + ! numerically expensive than the integrated rc method, which involved + ! extra vertical looping. + ! + ! The value of hm_1 and hm_2 will be calculated by the following method. + ! + ! When the overall correlation of w and hm (based on provided by the + ! microphysics) is exactly 1, all the hydrometeor will be found in the 1st + ! PDF component. In this scenario, hm_1 = /a and hm_2 = 0. Likewise, + ! when the overall correlation of w and hm is exactly -1, all the + ! hydrometeor will be found in the 2nd PDF component. In this scenario, + ! hm_1 = 0 and hm_2 = /(1-a). When the overall correlation of w and hm + ! is exactly 0, hm_1 = hm_2 = . + ! + ! What happens when the overall correlation of w and hm is at some + ! intermediate value? A function, based on the value of corr_w_hm_overall, + ! is used to connect the three points listed above. The function, when + ! written to calculate hm_1, must be MONOTONICALLY INCREASING over the + ! domain -1 <= corr_w_hm_overall <= 1. A quadratic polynomial used to + ! connect the three points for hm_1 (those points are (-1,0), (0,), and + ! (1,/a)) is only monotonically increasing over the domain when + ! 0.25 <= a <= 0.75. Since "a" is often outside that range in highly skewed + ! cases, a quadratic polynomial cannot be used. Other options include a + ! power-law fit and a piecewise linear fit. I have opted for the power-law + ! fit. + ! + ! A power law is given by the equation: + ! + ! hm_1 = A * x^kappa. + ! + ! Since hm_1 is based on corr_w_hm_overall, and hm_1 must be positive and + ! monotonically increasing over the domain -1 <= corr_w_hm_overall <= 1, + ! the coefficient A, the value of x, and the exponent kappa must be + ! positive. The equation for hm_1 is given by: + ! + ! hm_1 = A * ( 1 + corr_w_hm_overall )^kappa. + ! + ! The three points listed above result in: + ! + ! /a = A * ( 1 + 1 )^kappa; + ! = A * ( 1 + 0 )^kappa; + ! 0 = A * ( 1 + -1 )^kappa; + ! + ! and since 1^kappa = 1: + ! + ! /a = A * 2^kappa; + ! = A; + ! 0 = A * 0^kappa; + ! + ! which further simplifies to (since A = ): + ! + ! /a = * 2^kappa; + ! 0 = * 0^kappa. + ! + ! As long as kappa > 0, the equation will work out for 0 = * 0^kappa. + ! This leaves solving for kappa to /a = * 2^kappa. Dividing both + ! sides by , the equation reduces to: + ! + ! 1/a = 2^kappa; + ! ln( 1/a ) = ln( 2^kappa ); + ! ln( 1/a ) = kappa * ln( 2 ); and + ! kappa = ln( 1/a ) / ln( 2 ). + ! + ! The equation for hm_1 becomes: + ! + ! hm_1 = * ( 1 + corr_w_hm_overall )^( ln( 1/a ) / ln( 2 ) ). + ! + ! Since 1/a > 1, ln( 1/a ) > 0, and the exponent is always positive. + ! + ! However, there have been issues in the past (in both the accuracy of the + ! PDF shape and in problems resulting from extreme SILHS sample points) when + ! all the hydrometeor is found in one PDF component. In this method, that + ! will occur when w and hm are perfectly correlated or perfectly + ! anti-correlated. In order to allow for a limit to be placed on the hm_1 + ! and hm_2 distribution, a new tunable parameter is introduced. The method + ! becomes the following. + ! + ! First, calculate the overall correlation of w and hm: + ! + ! corr_w_hm_overall = / ( sqrt( ) * sqrt( ) ). + ! + ! Then, find the adjusted overall correlation of w and hm: + ! + ! corr_w_hm_overall_adj = coef_hm_1_hm_2_corr_adj * corr_w_hm_overall; + ! + ! where 0 <= coef_hm_1_hm_2_corr_adj <= 1. Here, coef_hm_1_hm_2_corr_adj + ! is a tunable parameter. When it is equal to 1, the adjusted overall + ! correlation is equal to the overall correlation. When it is equal to 0, + ! the adjusted correlation is always 0, resulting in hm_1 = hm_2. + ! + ! Next, calculated hm_1 based on the adjusted overall correlation: + ! + ! hm_1 = * ( 1 + corr_w_hm_overall_adj )^( ln( 1/a ) / ln( 2 ) ). + ! + ! Once hm_1 has been solved for, hm_2 can be solved by: + ! + ! hm_2 = ( - a * hm_1 ) / (1-a). + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + two, & ! Constant(s) + one, & + zero, & + w_tol + + use parameters_model, only: & + hydromet_dim ! Variable(s) + + use array_index, only: & + hydromet_tol ! Variable(s) + + use parameters_tunable, only: & + coef_hm_1_hm_2_corr_adj ! Variable(s) + + use stats_type_utilities, only: & + stat_update_var_pt ! Procedure(s) + + use stats_variables, only: & + icorr_w_hm_ov_adj, & ! Variable(s) + stats_zt + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + integer, intent(in) :: & + nz ! Number of model vertical grid levels + + real( kind = core_rknd ), dimension(nz,hydromet_dim), intent(in) :: & + hydromet, & ! Mean of hydrometeor, hm (overall) (t-levs.) [units] + wphydrometp_zt, & ! Covariance of w and hm interp. to t-levs. [(m/s)units] + hydrometp2_zt ! Variance of hm (overall) interp. to t-levs. [units^2] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + wp2_zt, & ! Variance of w, (interp. to t-levs.) [m^2/s^2] + mixt_frac ! Mixture fraction [-] + + logical, intent(in) :: & + l_stats_samp ! Flag to record statistical output. + + ! Output Variables + real( kind = core_rknd ), dimension(nz,hydromet_dim), intent(out) :: & + hm_1, & ! Mean of hydrometeor (1st PDF component) [units vary] + hm_2 ! Mean of hydrometeor (2nd PDF component) [units vary] + + ! Local Variables + real( kind = core_rknd ) :: & + corr_w_hm_overall, & ! Overall correlation of w and hm [-] + kappa_exp ! Exponent kappa = ln( 1/mixt_frac ) / ln( 2 ) [-] + + real( kind = core_rknd ), dimension(nz,hydromet_dim) :: & + corr_w_hm_overall_adj ! Adjusted overall correlation of w and hm [-] + + real( kind = core_rknd ) :: & + ln_2 ! Natural logarithm of 2 [-] + + integer :: k, i ! Loop indices + + + ! Initialize the adjusted overall correlation of w and the hydrometeor to 0. + corr_w_hm_overall_adj = zero + + ! Calculate the Natural logarithm of 2. + ln_2 = log( two ) + + !!! Find hm_1 and hm_2 based on the overall correlation of w and the + !!! hydrometeor, corr_w_hm_overall. + do k = 1, nz, 1 + + ! Calculate the value of the exponent kappa, where + ! kappa = ln( 1/mixt_frac ) / ln( 2 ). + ! This exponent is the same regardless of the hydrometeor type. + kappa_exp = log( one / mixt_frac(k) ) / ln_2 + + do i = 1, hydromet_dim, 1 + + !!! Calculate the component means for the hydrometeor. + if ( hydromet(k,i) > hydromet_tol(i) ) then + + ! Calculate the overall calculation of w and hm. + if ( sqrt( wp2_zt(k) ) > w_tol .and. & + sqrt( hydrometp2_zt(k,i) ) > hydromet_tol(i) ) then + + ! Both w and the hydrometeor vary at this grid level. The + ! overall correlation between them is defined. + ! Calculate the overall correlation of w and hm. + corr_w_hm_overall & + = wphydrometp_zt(k,i) & + / ( sqrt( wp2_zt(k) ) * sqrt( hydrometp2_zt(k,i) ) ) + + ! Keep values realizable. + if ( corr_w_hm_overall > one ) then + corr_w_hm_overall = one + elseif ( corr_w_hm_overall < -one ) then + corr_w_hm_overall = -one + endif + + else ! sqrt(wp2_zt) <= w_tol or sqrt(hydrometp2_zt) <= hydromet_tol + + ! Either w or the hydrometeor is constant at this grid level. + ! This means that must also have a value of 0, making + ! the correlation undefined. In the scenario that = 0, + ! the hydrometeor is constant at this grid level, which means + ! that hm_1 = hm_2 = . This is also the result when the + ! correlation has a value of 0. So, set the correlation to 0 in + ! order to achieve the result hm_1 = hm_2 = . In the + ! scenario that = 0, w is constant at is grid level. + ! To simplify matters, the undefined correlation will be set to + ! 0 in order to produce hm_1 = hm_2 = . + corr_w_hm_overall = zero + + endif ! sqrt(wp2_zt) > w_tol and sqrt(hydrometp2_zt) > hydromet_tol + + ! Calculate the adjusted overall correlation of w and hm. + corr_w_hm_overall_adj(k,i) & + = coef_hm_1_hm_2_corr_adj * corr_w_hm_overall + + ! Calculate the mean of the hydrometeor in the 1st PDF component. + hm_1(k,i) & + = hydromet(k,i) * ( one + corr_w_hm_overall_adj(k,i) )**kappa_exp + + ! Calculate the mean of the hydrometeor in the 2nd PDF component. + hm_2(k,i) & + = ( hydromet(k,i) - mixt_frac(k) * hm_1(k,i) ) & + / ( one - mixt_frac(k) ) + + if ( hm_1(k,i) < zero ) then + + ! The mean value of the hydrometeor within the 1st PDF component + ! is below 0 due to numerical roundoff error. Reset its value + ! to 0. All the the hydrometeor is found within the 2nd PDF + ! component. + hm_1(k,i) = zero + hm_2(k,i) = hydromet(k,i) / ( one - mixt_frac(k) ) + + elseif ( hm_2(k,i) < zero ) then + + ! The mean value of the hydrometeor within the 2nd PDF component + ! is below 0 due to numerical roundoff error. Reset its value + ! to 0. All the the hydrometeor is found within the 1st PDF + ! component. + hm_1(k,i) = hydromet(k,i) / mixt_frac(k) + hm_2(k,i) = zero + + endif + + + else ! hydromet(k,i) <= hydromet_tol(i) + + ! The overall hydrometeor is either 0 or below tolerance value (any + ! postive value is considered to be a numerical artifact). Simply + ! set each PDF component mean equal to 0. These values will not + ! play into any further calculations. + hm_1(k,i) = zero + hm_2(k,i) = zero + + endif ! hydromet(k,i) > hydromet_tol(i) + + ! Statistics + if ( l_stats_samp ) then + + if ( icorr_w_hm_ov_adj(i) > 0 ) then + ! Adjusted overall correlation of w and hm. + call stat_update_var_pt( icorr_w_hm_ov_adj(i), k, & + corr_w_hm_overall_adj(k,i), stats_zt ) + endif + + endif ! l_stats_samp + + enddo ! i = 1, hydromet_dim, 1 + + enddo ! k = 1, nz, 1 + + + return + + end subroutine component_means_hydromet_corr + + !============================================================================= + subroutine precip_fraction( nz, hydromet, hm1, hm2, & + cloud_frac, cloud_frac_1, mixt_frac, & + ice_supersat_frac, & + precip_frac, precip_frac_1, precip_frac_2 ) + + ! Description: + ! Determines (overall) precipitation fraction over the horizontal domain, as + ! well as the precipitation fraction within each PDF component, at every + ! vertical grid level. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + zero, & + cloud_frac_min, & + fstderr + + use parameters_model, only: & + hydromet_dim ! Variable(s) + + use array_index, only: & + l_mix_rat_hm, & ! Variable(s) + hydromet_tol ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + integer, intent(in) :: & + nz ! Number of model vertical grid levels + + real( kind = core_rknd ), dimension(nz,hydromet_dim), intent(in) :: & + hydromet, & ! Mean of hydrometeor, hm (overall) [units vary] + hm1, & ! Mean of hydrometeor (1st PDF component) [units vary] + hm2 ! Mean of hydrometeor (2nd PDF component) [units vary] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + cloud_frac, & ! Cloud fraction (overall) [-] + cloud_frac_1, & ! Cloud fraction (1st PDF component) [-] + mixt_frac, & ! Mixture fraction [-] + ice_supersat_frac ! Ice cloud fraction [-] + + ! Output Variables + real( kind = core_rknd ), dimension(nz), intent(out) :: & + precip_frac, & ! Precipitation fraction (overall) [-] + precip_frac_1, & ! Precipitation fraction (1st PDF component) [-] + precip_frac_2 ! Precipitation fraction (2nd PDF component) [-] + + ! Local Variables + real( kind = core_rknd ), dimension(nz) :: & + weighted_pfrac1 ! Product of mixt_frac and precip_frac_1 [-] + + real( kind = core_rknd ) :: & + r_tot_hm_1, & ! Mean total hydromet mixing ratio (1st PDF comp.) [kg/kg] + r_tot_hm_2, & ! Mean total hydromet mixing ratio (2nd PDF comp.) [kg/kg] + N_tot_hm_1, & ! Mean total hydromet concentration (1st PDF comp.) [num/kg] + N_tot_hm_2 ! Mean total hydromet concentration (2nd PDF comp.) [num/kg] + + real( kind = core_rknd ), parameter :: & + precip_frac_tol = cloud_frac_min ! Minimum precip. frac. [-] + + ! "Maximum allowable" hydrometeor mixing ratio in-precip component mean. + real( kind = core_rknd ), parameter :: & + max_hm_ip_comp_mean = 0.0025_core_rknd ! [kg/kg] + + integer, parameter :: & + precip_frac_calc_type = 2 ! Option used to calc. component precip_frac + + integer :: & + k, i ! Loop indices + + + ! Initialize the precipitation fraction variables (precip_frac, + ! precip_frac_1, and precip_frac_2) to 0. + precip_frac = zero + precip_frac_1 = zero + precip_frac_2 = zero + + !!! Find overall precipitation fraction. + do k = nz, 1, -1 + + ! The precipitation fraction is the greatest cloud fraction at or above a + ! vertical level. + if ( k < nz ) then + precip_frac(k) = max( precip_frac(k+1), cloud_frac(k) ) + else ! k = nz + precip_frac(k) = cloud_frac(k) + endif + + if ( any( hydromet(k,:) > hydromet_tol(:) ) & + .and. precip_frac(k) < precip_frac_tol ) then + + ! In a scenario where we find any hydrometeor at this grid level, but + ! no cloud at or above this grid level, set precipitation fraction to + ! a minimum threshold value. + precip_frac(k) = precip_frac_tol + + elseif ( all( hydromet(k,:) <= hydromet_tol(:) ) & + .and. precip_frac(k) < precip_frac_tol ) then + + ! The means (overall) of every precipitating hydrometeor are all less + ! than their respective tolerance amounts. They are all considered to + ! have values of 0. There are not any hydrometeor species found at + ! this grid level. There is also no cloud at or above this grid + ! level, so set precipitation fraction to 0. + precip_frac(k) = zero + + endif + + enddo ! Overall precipitation fraction loop: k = nz, 1, -1. + + !!! Account for ice cloud fraction + do k = nz, 1, -1 + precip_frac(k) = max( precip_frac(k), ice_supersat_frac(k) ) + enddo + + + !!! Find precipitation fraction within each PDF component. + ! + ! The overall precipitation fraction, f_p, is given by the equation: + ! + ! f_p = a * f_p(1) + ( 1 - a ) * f_p(2); + ! + ! where a is the mixture fraction (weight of PDF component 1), f_p(1) is + ! the precipitation fraction within PDF component 1, and f_p(2) is the + ! precipitation fraction within PDF component 2. Overall precipitation + ! fraction is found according the method above, and mixture fraction is + ! already determined, leaving f_p(1) and f_p(2) to be solved for. The + ! values for f_p(1) and f_p(2) must satisfy the above equation. + if ( precip_frac_calc_type == 1 ) then + + ! This method needs some improvements -- Brian; 11/10/2014. + + !!! Find precipitation fraction within PDF component 1. + ! The method used to find overall precipitation fraction will also be to + ! find precipitation fraction within PDF component 1. In order to do so, + ! it is assumed (poorly) that PDF component 1 overlaps PDF component 1 at + ! every vertical level in the vertical profile. + do k = nz, 1, -1 + + ! The weighted precipitation fraction (PDF component 1) is the + ! greatest value of the product of mixture fraction and cloud fraction + ! (PDF component 1) at or above a vertical level. + if ( k < nz ) then + weighted_pfrac1(k) = max( weighted_pfrac1(k+1), & + mixt_frac(k) * cloud_frac_1(k) ) + else ! k = nz + weighted_pfrac1(k) = mixt_frac(k) * cloud_frac_1(k) + endif + + precip_frac_1(k) = weighted_pfrac1(k) / mixt_frac(k) + + ! Special cases for precip_frac_1. + if ( precip_frac_1(k) > one ) then + + ! Using the above method, it is possible for precip_frac_1 to be + ! greater than 1. For example, the mixture fraction at level k+1 + ! is 0.10 and the cloud_frac_1 at level k+1 is 1, resulting in a + ! weighted_pfrac1 of 0.10. This product is greater than the + ! product of mixt_frac and cloud_frac_1 at level k. The mixture + ! fraction at level k is 0.05, resulting in a precip_frac_1 of 2. + ! The value of precip_frac_1 is limited at 1. The leftover + ! precipitation fraction (a result of the decreasing weight of PDF + ! component 1 between the levels) is applied to PDF component 2. + precip_frac_1(k) = one + + elseif ( any( hm1(k,:) > hydromet_tol(:) ) & + .and. precip_frac_1(k) <= precip_frac_tol ) then + + ! In a scenario where we find any hydrometeor in the 1st PDF + ! component at this grid level, but no cloud in the 1st PDF + ! component at or above this grid level, set precipitation fraction + ! (in the 1st PDF component) to a minimum threshold value. + precip_frac_1(k) = precip_frac_tol + + elseif ( all( hm1(k,:) <= hydromet_tol(:) ) & + .and. precip_frac_1(k) <= precip_frac_tol ) then + + ! The means of every precipitating hydrometeor in the 1st PDF + ! component are all less than their respective tolerance amounts. + ! They are all considered to have values of 0. There are not any + ! hydrometeor species found in the 1st PDF component at this grid + ! level. There is also no cloud at or above this grid level, so + ! set precipitation fraction (in the 1st PDF component) to 0. + precip_frac_1(k) = zero + + endif + + enddo ! Precipitation fraction (1st PDF component) loop: k = nz, 1, -1. + + + !!! Find precipitation fraction within PDF component 2. + ! The equation for precipitation fraction within PDF component 2 is: + ! + ! f_p(2) = ( f_p - a * f_p(1) ) / ( 1 - a ); + ! + ! given the overall precipitation fraction, f_p (calculated above), the + ! precipitation fraction within PDF component 1, f_p(1) (calculated + ! above), and mixture fraction, a. Any leftover precipitation fraction + ! from precip_frac_1 will be included in this calculation of + ! precip_frac_2. + do k = 1, nz, 1 + + precip_frac_2(k) & + = ( precip_frac(k) - mixt_frac(k) * precip_frac_1(k) ) & + / ( one - mixt_frac(k) ) + + ! Special cases for precip_frac_2. + if ( precip_frac_2(k) > one ) then + + ! Again, it is possible for precip_frac_2 to be greater than 1. + ! For example, the mixture fraction at level k+1 is 0.10 and the + ! cloud_frac_1 at level k+1 is 1, resulting in a weighted_pfrac1 of + ! 0.10. This product is greater than the product of mixt_frac and + ! cloud_frac_1 at level k. Additionally, precip_frac (overall) is 1 + ! for level k. The mixture fraction at level k is 0.5, resulting + ! in a precip_frac_1 of 0.2. Using the above equation, + ! precip_frac_2 is calculated to be 1.8. The value of + ! precip_frac_2 is limited at 1. The leftover precipitation + ! fraction (as a result of the increasing weight of component 1 + ! between the levels) is applied to PDF component 1. + precip_frac_2(k) = one + + ! Recalculate the precipitation fraction in PDF component 1. + precip_frac_1(k) & + = ( precip_frac(k) - ( one - mixt_frac(k) ) * precip_frac_2(k) ) & + / mixt_frac(k) + + ! Double check for errors in PDF component 1. + if ( precip_frac_1(k) > one ) then + precip_frac_1(k) = one + elseif ( any( hm1(k,:) > hydromet_tol(:) ) & + .and. precip_frac_1(k) <= precip_frac_tol ) then + precip_frac_1(k) = precip_frac_tol + elseif ( all( hm1(k,:) <= hydromet_tol(:) ) & + .and. precip_frac_1(k) <= precip_frac_tol ) then + precip_frac_1(k) = zero + endif + + elseif ( any( hm2(k,:) > hydromet_tol(:) ) & + .and. precip_frac_2(k) <= precip_frac_tol ) then + + ! In a scenario where we find any hydrometeor in the 2nd PDF + ! component at this grid level, but no cloud in the 2nd PDF + ! component at or above this grid level, set precipitation fraction + ! (in the 2nd PDF component) to a minimum threshold value. + precip_frac_2(k) = precip_frac_tol + + elseif ( all( hm2(k,:) <= hydromet_tol(:) ) & + .and. precip_frac_2(k) <= precip_frac_tol ) then + + ! The means of every precipitating hydrometeor in the 2nd PDF + ! component are all less than their respective tolerance amounts. + ! They are all considered to have values of 0. There are not any + ! hydrometeor species found in the 2nd PDF component at this grid + ! level. There is also no cloud at or above this grid level, so + ! set precipitation fraction (in the 2nd PDF component) to 0. + precip_frac_2(k) = zero + + endif + + enddo ! Precipitation fraction (2nd PDF component) loop: k = 1, nz, 1. + + + elseif ( precip_frac_calc_type == 2 ) then + + ! This method needs to be eliminated. I will keep it in the code as a + ! temporary stopgap, since it is currently enabled by default. + ! Brian; 11/10/2014. + + ! Precipitation fraction in each PDF component is based on the mean total + ! hydrometeor mixing ratio in each PDF component, where total hydrometeor + ! mixing ratio, r_Thm, is the sum of all precipitating hydrometeor + ! species mixing ratios (which doesn't include cloud water), such that: + ! + ! r_Thm = r_r + r_i + r_s + r_g; + ! + ! where r_r is rain water mixing ratio, r_i is ice mixing ratio, r_s is + ! snow mixing ratio, and r_g is graupel mixing ratio. + ! + ! Precipitation fraction in each PDF component is based on the ratio: + ! + ! r_Thm_1/f_p(1) = r_Thm_2/f_p(2); + ! + ! where r_Thm_1 is mean total hydrometeor mixing ratio is the 1st PDF + ! component and r_Thm_2 is mean total hydrometeor mixing ratio in the 2nd + ! PDF component. The equation can be rewritten as: + ! + ! f_p(2)/f_p(1) = r_Thm_2/r_Thm_1. + ! + ! Since overall precipitation fraction is given by the equation: + ! + ! f_p = a f_p(1) + (1-a) f_p(2); + ! + ! it can be rewritten as: + ! + ! f_p = f_p(1) ( a + (1-a) f_p(2)/f_p(1) ). + ! + ! Substituting the ratio r_Thm_2/r_Thm_1 for the ratio f_p(2)/f_p(1), the + ! above equation can be solved for f_p(1): + ! + ! f_p(1) = f_p / ( a + (1-a) r_Thm_2/r_Thm_1 ). + ! + ! Then, f_p(2) can be solved for according to the equation: + ! + ! f_p(2) = ( f_p - a f_p(1) ) / (1-a). + ! + ! In the event where hydrometeor concentrations are found at a given + ! vertical level, but not hydrometeor mixing ratios (due to numerical + ! artifacts), the mean total hydrometeor concentrations in each PDF + ! component will be used in place of mean total hydrometeor mixing ratios + ! in the above equations to solve for component precipitation fractions. + do k = 1, nz, 1 + + if ( all( hm1(k,:) <= hydromet_tol(:) ) & + .and. all( hm2(k,:) <= hydromet_tol(:) ) ) then + + ! There are no hydrometeors found in each PDF component. + ! Precipitation fraction within each component is set to 0. + precip_frac_1(k) = zero + precip_frac_2(k) = zero + + elseif ( any( hm1(k,:) > hydromet_tol(:) ) & + .and. all( hm2(k,:) <= hydromet_tol(:) ) ) then + + ! All the hydrometeors are found within the 1st PDF component. + precip_frac_1(k) = precip_frac(k) / mixt_frac(k) + precip_frac_2(k) = zero + + ! Using the above method, it is possible for precip_frac_1 to be + ! greater than 1. The value of precip_frac_1 is limited at 1. + if ( precip_frac_1(k) > one ) then + precip_frac_1(k) = one + precip_frac(k) = mixt_frac(k) + endif + + elseif ( any( hm2(k,:) > hydromet_tol(:) ) & + .and. all( hm1(k,:) <= hydromet_tol(:) ) ) then + + ! All the hydrometeors are found within the 2nd PDF component. + precip_frac_1(k) = zero + precip_frac_2(k) = precip_frac(k) / ( one - mixt_frac(k) ) + + ! Using the above method, it is possible for precip_frac_2 to be + ! greater than 1. The value of precip_frac_2 is limited at 1. + if ( precip_frac_2(k) > one ) then + precip_frac_2(k) = one + precip_frac(k) = one - mixt_frac(k) + endif + + else + + ! any( hm1(k,:) > hydromet_tol(:) ) + ! AND any( hm2(k,:) > hydromet_tol(:) ) + + ! Hydrometeors are found within both PDF components. + r_tot_hm_1 = zero + r_tot_hm_2 = zero + N_tot_hm_1 = zero + N_tot_hm_2 = zero + do i = 1, hydromet_dim, 1 + + if ( l_mix_rat_hm(i) ) then + + ! The hydrometeor is a mixing ratio. + ! Find total hydrometeor mixing ratio in each PDF component. + if ( hm1(k,i) > hydromet_tol(i) ) then + r_tot_hm_1 = r_tot_hm_1 + hm1(k,i) + endif + if ( hm2(k,i) > hydromet_tol(i) ) then + r_tot_hm_2 = r_tot_hm_2 + hm2(k,i) + endif + + else ! l_mix_rat_hm(i) is false + + ! The hydrometeor is a concentration. + ! Find total hydrometeor concentration in each PDF component. + if ( hm1(k,i) > hydromet_tol(i) ) then + N_tot_hm_1 = N_tot_hm_1 + hm1(k,i) + endif + if ( hm2(k,i) > hydromet_tol(i) ) then + N_tot_hm_2 = N_tot_hm_2 + hm2(k,i) + endif + + endif ! l_mix_rat_hm(i) + + enddo ! i = 1, hydromet_dim, 1 + + !!! Find precipitation fraction within PDF component 1. + if ( r_tot_hm_1 > zero ) then + precip_frac_1(k) & + = precip_frac(k) & + / ( mixt_frac(k) & + + ( one - mixt_frac(k) ) * r_tot_hm_2/r_tot_hm_1 ) + else ! N_tot_hm_1 > zero + precip_frac_1(k) & + = precip_frac(k) & + / ( mixt_frac(k) & + + ( one - mixt_frac(k) ) * N_tot_hm_2/N_tot_hm_1 ) + endif + + ! Using the above method, it is possible for precip_frac_1 to be + ! greater than 1. The value of precip_frac_1 is limited at 1. + if ( precip_frac_1(k) > one ) then + precip_frac_1(k) = one + endif + + !!! Find precipitation fraction within PDF component 2. + precip_frac_2(k) & + = ( precip_frac(k) - mixt_frac(k) * precip_frac_1(k) ) & + / ( one - mixt_frac(k) ) + + ! Using the above method, it is possible for precip_frac_2 to be + ! greater than 1. The value of precip_frac_2 is limited at 1. + if ( precip_frac_2(k) > one ) then + + precip_frac_2(k) = one + + ! Recalculate the precipitation fraction in PDF component 1. + precip_frac_1(k) & + = ( precip_frac(k) & + - ( one - mixt_frac(k) ) * precip_frac_2(k) ) & + / mixt_frac(k) + + endif + + endif + + + ! Special cases for PDF component 1. + if ( any( hm1(k,:) > hydromet_tol(:) ) & + .and. precip_frac_1(k) <= precip_frac_tol ) then + + ! In a scenario where we find any hydrometeor in the 1st PDF + ! component at this grid level, but no cloud in the 1st PDF + ! component at or above this grid level, set precipitation fraction + ! (in the 1st PDF component) to a minimum threshold value. + precip_frac_1(k) = precip_frac_tol + + elseif ( all( hm1(k,:) <= hydromet_tol(:) ) & + .and. precip_frac_1(k) <= precip_frac_tol ) then + + ! The means of every precipitating hydrometeor in the 1st PDF + ! component are all less than their respective tolerance amounts. + ! They are all considered to have values of 0. There is not any + ! hydrometeor species found in the 1st PDF component at this grid + ! level. There is also no cloud at or above this grid level, so + ! set precipitation fraction (in the 1st PDF component) to 0. + precip_frac_1(k) = zero + + endif + + + ! Special cases for PDF component 2. + if ( any( hm2(k,:) > hydromet_tol(:) ) & + .and. precip_frac_2(k) <= precip_frac_tol ) then + + ! In a scenario where we find any hydrometeor in the 2nd PDF + ! component at this grid level, but no cloud in the 2nd PDF + ! component at or above this grid level, set precipitation fraction + ! (in the 2nd PDF component) to a minimum threshold value. + precip_frac_2(k) = precip_frac_tol + + elseif ( all( hm2(k,:) <= hydromet_tol(:) ) & + .and. precip_frac_2(k) <= precip_frac_tol ) then + + ! The means of every precipitating hydrometeor in the 2nd PDF + ! component are all less than their respective tolerance amounts. + ! They are all considered to have values of 0. There is not any + ! hydrometeor species found in the 2nd PDF component at this grid + ! level. There is also no cloud at or above this grid level, so + ! set precipitation fraction (in the 2nd PDF component) to 0. + precip_frac_2(k) = zero + + endif + + + enddo ! Component precipitation fraction loop: k = 1, nz, 1. + + + elseif ( precip_frac_calc_type == 3 ) then + + ! Temporary third option to test setting precip_frac_1 = precip_frac_2 + ! ( = precip_frac ). Brian; 11/10/2014. + precip_frac_1 = precip_frac + precip_frac_2 = precip_frac + + + else ! Invalid option selected. + + write(fstderr,*) "Invalid option to calculate precip_frac_1 " & + // "and precip_frac_2." + stop + + + endif ! precip_frac_calc_type + + + ! Increase Precipiation Fraction under special conditions. + ! + ! There are scenarios that sometimes occur that require precipitation + ! fraction to be boosted. Precipitation fraction is calculated from cloud + ! fraction and ice supersaturation fraction. For numerical reasons, CLUBB's + ! PDF may become entirely subsaturated with respect to liquid and ice, + ! resulting in both a cloud fraction of 0 and an ice supersaturation + ! fraction of 0. When this happens, precipitation fraction drops to 0 when + ! there aren't any hydrometeors present at that grid level, or to + ! precip_frac_tol when there is at least one hydrometeor present at that + ! grid level. However, sometimes there are large values of hydrometeors + ! found at that grid level. When this occurs, the PDF component in-precip + ! mean of a hydrometeor can become ridiculously large. This is because the + ! ith PDF component in-precip mean of a hydrometeor, mu_hm_i, is given by + ! the equation: + ! + ! mu_hm_i = hmi / precip_frac_i; + ! + ! where hmi is the overall ith PDF component mean of the hydrometeor, and + ! precip_frac_i is the ith PDF component precipitation fraction. When + ! precip_frac_i has a value of precip_frac_tol and hmi is large, mu_hm_i can + ! be huge. This can cause enormous microphysical process rates and result + ! in numerical instability. It is also very inaccurate. + ! + ! In order to limit this problem, the ith PDF component precipitation + ! fraction is increased in order to decrease mu_hm_i. First, an "upper + ! limit" is set for mu_hm_i when the hydrometeor is a mixing ratio. This is + ! called max_hm_ip_comp_mean. At every vertical level and for every + ! hydrometeor mixing ratio, a check is made to try to prevent mu_hm_i from + ! exceeding the "upper limit". The check is: + ! hmi / precip_frac_i ( which = mu_hm_i ) > max_hm_ip_comp_mean, which can + ! be rewritten: hmi > precip_frac_i * max_hm_ip_comp_mean. When this + ! occurs, precip_frac_i is increased to hmi/max_hm_ip_comp_mean. Of course, + ! precip_frac_i is not allowed to exceed 1, so when hmi is already greater + ! than max_hm_ip_comp_mean, mu_hm_i will also have to be greater than + ! max_hm_ip_comp_mean. However, the value of mu_hm_i is still reduced when + ! compared to what it would have been using precip_frac_tol. In the event + ! that multiple hydrometeor mixing ratios violate the check, the code is set + ! up so that precip_frac_i is increased based on the highest hmi. + do k = 1, nz, 1 + + do i = 1, hydromet_dim, 1 + + if ( l_mix_rat_hm(i) ) then + + ! The hydrometeor is a mixing ratio. + + if ( hm1(k,i) > precip_frac_1(k) * max_hm_ip_comp_mean ) then + + ! Increase precipitation fraction in the 1st PDF component. + precip_frac_1(k) = min( hm1(k,i)/max_hm_ip_comp_mean, one ) + + ! Recalculate overall precipitation fraction. + precip_frac(k) = mixt_frac(k) * precip_frac_1(k) & + + ( one - mixt_frac(k) ) * precip_frac_2(k) + + endif ! mu_hm_1 = hm1/precip_frac_1 > max_hm_ip_comp_mean + + if ( hm2(k,i) > precip_frac_2(k) * max_hm_ip_comp_mean ) then + + ! Increase precipitation fraction in the 2nd PDF component. + precip_frac_2(k) = min( hm2(k,i)/max_hm_ip_comp_mean, one ) + + ! Recalculate overall precipitation fraction. + precip_frac(k) = mixt_frac(k) * precip_frac_1(k) & + + ( one - mixt_frac(k) ) * precip_frac_2(k) + + endif ! mu_hm_2 = hm2/precip_frac_2 > max_hm_ip_comp_mean + + endif ! l_mix_rat_hm(i) + + enddo ! i = 1, hydromet_dim, 1 + + enddo ! k = 1, nz, 1 + + + return + + end subroutine precip_fraction + + !============================================================================= + subroutine compute_mean_stdev( Ncnm, rc_1, rc_2, & ! Intent(in) + cloud_frac_1, cloud_frac_2, & ! Intent(in) + hm1, hm2, & ! Intent(in) + precip_frac_1, precip_frac_2, & ! Intent(in) + sigma2_on_mu2_ip_array_cloud, & ! Intent(in) + sigma2_on_mu2_ip_array_below, & ! Intent(in) + pdf_params, d_variables, & ! Intent(in) + mu_x_1, mu_x_2, sigma_x_1, sigma_x_2 ) ! Intent(out) + + ! Description: + ! Calculates the means and standard deviations (for each PDF component) of + ! chi, eta, w, Ncn, and the precipitating hydrometeors. For the precipitating + ! hydrometeors, the component means and standard deviations are in-precip. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + zero + + use array_index, only: & + hydromet_tol + + use model_flags, only: & + l_const_Nc_in_cloud ! Variable(s) + + use index_mapping, only: & + pdf2hydromet_idx ! Procedure(s) + + use pdf_parameter_module, only: & + pdf_parameter ! Variable(s) type + + use corr_varnce_module, only: & + iiPDF_chi, & ! Variable(s) + iiPDF_eta, & + iiPDF_w, & + iiPDF_Ncn + + use parameters_model, only: & + hydromet_dim ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + integer, intent(in) :: d_variables ! Number of PDF variables + + real( kind = core_rknd ), intent(in) :: & + Ncnm, & ! Mean cloud nuclei concentration [num/kg] + rc_1, & ! Mean of r_c (1st PDF component) [kg/kg] + rc_2, & ! Mean of r_c (2nd PDF component) [kg/kg] + cloud_frac_1, & ! Cloud fraction (1st PDF component) [-] + cloud_frac_2, & ! Cloud fraction (2nd PDF component) [-] + precip_frac_1, & ! Precipitation fraction (1st PDF component) [-] + precip_frac_2 ! Precipitation fraction (2nd PDF component) [-] + + real( kind = core_rknd ), dimension(d_variables), intent(in) :: & + sigma2_on_mu2_ip_array_cloud, & ! Prescribed ratio array: cloudy levs. [-] + sigma2_on_mu2_ip_array_below ! Prescribed ratio array: clear levs. [-] + + real( kind = core_rknd ), dimension(hydromet_dim), intent(in) :: & + hm1, & ! Mean of a precip. hydrometeor (1st PDF component) [units vary] + hm2 ! Mean of a precip. hydrometeor (2nd PDF component) [units vary] + + type(pdf_parameter), intent(in) :: & + pdf_params ! PDF parameters [units vary] + + ! Output Variables + ! Note: This code assumes to be these arrays in the same order as the + ! correlation arrays, etc., which is determined by the iiPDF indices. + ! The order should be as follows: chi, eta, w, Ncn, + ! (indices increasing from left to right). + real( kind = core_rknd ), dimension(d_variables), intent(out) :: & + mu_x_1, & ! Mean array of PDF vars. (1st PDF component) [units vary] + mu_x_2, & ! Mean array of PDF vars. (2nd PDF component) [units vary] + sigma_x_1, & ! Standard deviation array of PDF vars (comp. 1) [units vary] + sigma_x_2 ! Standard deviation array of PDF vars (comp. 2) [units vary] + + ! Local Variables + integer :: ivar ! Loop iterator + + + !!! Enter the PDF parameters. + + !!! Means. + + ! Mean of vertical velocity, w, in PDF component 1. + mu_x_1(iiPDF_w) = pdf_params%w_1 + + ! Mean of vertical velocity, w, in PDF component 2. + mu_x_2(iiPDF_w) = pdf_params%w_2 + + ! Mean of extended liquid water mixing ratio, chi (old s), + ! in PDF component 1. + mu_x_1(iiPDF_chi) = pdf_params%chi_1 + + ! Mean of extended liquid water mixing ratio, chi (old s), + ! in PDF component 2. + mu_x_2(iiPDF_chi) = pdf_params%chi_2 + + ! Mean of eta (old t) in PDF component 1. + ! Set the component mean values of eta to 0. + ! The component mean values of eta are not important. They can be set to + ! anything. They cancel out in the model code. However, the best thing to + ! do is to set them to 0 and avoid any kind of numerical error. + mu_x_1(iiPDF_eta) = zero + + ! Mean of eta (old t) in PDF component 2. + ! Set the component mean values of eta to 0. + ! The component mean values of eta are not important. They can be set to + ! anything. They cancel out in the model code. However, the best thing to + ! do is to set them to 0 and avoid any kind of numerical error. + mu_x_2(iiPDF_eta) = zero + + ! Mean of simplified cloud nuclei concentration, Ncn, in PDF component 1. + mu_x_1(iiPDF_Ncn) = Ncnm + + ! Mean of simplified cloud nuclei concentration, Ncn, in PDF component 2. + mu_x_2(iiPDF_Ncn) = Ncnm + + ! Mean of the hydrometeor species + do ivar = iiPDF_Ncn+1, d_variables + + ! Mean of hydrometeor, hm, in PDF component 1. + mu_x_1(ivar) & + = component_mean_hm_ip( hm1(pdf2hydromet_idx(ivar)), precip_frac_1, & + hydromet_tol(pdf2hydromet_idx(ivar)) ) + + ! Mean of hydrometeor, hm, in PDF component 2. + mu_x_2(ivar) & + = component_mean_hm_ip( hm2(pdf2hydromet_idx(ivar)), precip_frac_2, & + hydromet_tol(pdf2hydromet_idx(ivar)) ) + + enddo + + + !!! Standard deviations. + + ! Standard deviation of vertical velocity, w, in PDF component 1. + sigma_x_1(iiPDF_w) = sqrt( pdf_params%varnce_w_1 ) + + ! Standard deviation of vertical velocity, w, in PDF component 2. + sigma_x_2(iiPDF_w) = sqrt( pdf_params%varnce_w_2 ) + + ! Standard deviation of extended liquid water mixing ratio, chi (old s), + ! in PDF component 1. + sigma_x_1(iiPDF_chi) = pdf_params%stdev_chi_1 + + ! Standard deviation of extended liquid water mixing ratio, chi (old s), + ! in PDF component 2. + sigma_x_2(iiPDF_chi) = pdf_params%stdev_chi_2 + + ! Standard deviation of eta (old t) in PDF component 1. + sigma_x_1(iiPDF_eta) = pdf_params%stdev_eta_1 + + ! Standard deviation of eta (old t) in PDF component 2. + sigma_x_2(iiPDF_eta) = pdf_params%stdev_eta_2 + + ! Standard deviation of simplified cloud nuclei concentration, Ncn, + ! in PDF component 1. + if ( .not. l_const_Nc_in_cloud ) then + + ! Ncn varies in both PDF components. + sigma_x_1(iiPDF_Ncn) & + = component_stdev_hm_ip( mu_x_1(iiPDF_Ncn), rc_1, one, & + sigma2_on_mu2_ip_array_cloud(iiPDF_Ncn), & + sigma2_on_mu2_ip_array_below(iiPDF_Ncn) ) + + else ! l_const_Nc_in_cloud + + ! Ncn is constant in both PDF components. + sigma_x_1(iiPDF_Ncn) = zero + + endif ! .not. l_const_Nc_in_cloud + + ! Standard deviation of simplified cloud nuclei concentration, Ncn, + ! in PDF component 2. + if ( .not. l_const_Nc_in_cloud ) then + + ! Ncn varies in both PDF components. + sigma_x_2(iiPDF_Ncn) & + = component_stdev_hm_ip( mu_x_2(iiPDF_Ncn), rc_2, one, & + sigma2_on_mu2_ip_array_cloud(iiPDF_Ncn), & + sigma2_on_mu2_ip_array_cloud(iiPDF_Ncn) ) + + else ! l_const_Nc_in_cloud + + ! Ncn is constant in both PDF components. + sigma_x_2(iiPDF_Ncn) = zero + + endif ! .not. l_const_Nc_in_cloud + + ! Set up the values of the statistical correlations and variances. Since we + ! currently do not have enough variables to compute the correlations and + ! variances directly, we have obtained these values by analyzing LES runs of + ! certain cases. We have divided those results into an inside-cloud average + ! and an outside-cloud (or below-cloud) average. This coding leaves the + ! software architecture in place in case we ever have the variables in place + ! to compute these values directly. It also allows us to use separate + ! inside-cloud and outside-cloud parameter values. + ! Brian Griffin; February 3, 2007. + + do ivar = iiPDF_Ncn+1, d_variables + + ! Standard deviation of hydrometeor, hm, in PDF component 1. + sigma_x_1(ivar) & + = component_stdev_hm_ip( mu_x_1(ivar), & + rc_1, cloud_frac_1, & + sigma2_on_mu2_ip_array_cloud(ivar), & + sigma2_on_mu2_ip_array_below(ivar) ) + + ! Standard deviation of hydrometeor, hm, in PDF component 2. + sigma_x_2(ivar) & + = component_stdev_hm_ip( mu_x_2(ivar), & + rc_2, cloud_frac_2, & + sigma2_on_mu2_ip_array_cloud(ivar), & + sigma2_on_mu2_ip_array_below(ivar) ) + + enddo + + + return + + end subroutine compute_mean_stdev + + !============================================================================= + subroutine compute_corr( wm_zt, rc_1, rc_2, cloud_frac_1, & + cloud_frac_2, wpchip, wpNcnp, & + stdev_w, mixt_frac, precip_frac_1, & + precip_frac_2, wphydrometp_zt, & + mu_x_1, mu_x_2, sigma_x_1, sigma_x_2, & + corr_array_cloud, corr_array_below, & + pdf_params, d_variables, & + corr_array_1, corr_array_2 ) + + ! Description: + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + Ncn_tol, & + w_tol, & ! [m/s] + chi_tol, & ! [kg/kg] + one, & + zero + + use model_flags, only: & + l_calc_w_corr + + use diagnose_correlations_module, only: & + calc_mean, & ! Procedure(s) + calc_w_corr + + use index_mapping, only: & + pdf2hydromet_idx ! Procedure(s) + + use parameters_model, only: & + hydromet_dim ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use pdf_parameter_module, only: & + pdf_parameter ! Variable(s) type + + use corr_varnce_module, only: & + iiPDF_chi, & ! Variable(s) + iiPDF_eta, & + iiPDF_w, & + iiPDF_Ncn + + use array_index, only: & + hydromet_tol + + implicit none + + ! Input Variables + integer, intent(in) :: d_variables ! Number of variables in the corr/mean/stdev arrays + + real( kind = core_rknd ), intent(in) :: & + wm_zt, & ! Mean vertical velocity, , on thermo. levels [m/s] + rc_1, & ! Mean of r_c (1st PDF component) [kg/kg] + rc_2, & ! Mean of r_c (2nd PDF component) [kg/kg] + cloud_frac_1, & ! Cloud fraction (1st PDF component) [-] + cloud_frac_2, & ! Cloud fraction (2nd PDF component) [-] + wpchip, & ! Covariance of w and chi (old s) [(m/s)kg/kg] + wpNcnp, & ! Covariance of w and N_cn (overall) [(m/s) num/kg] + stdev_w, & ! Standard deviation of w [m/s] + mixt_frac, & ! Mixture fraction [-] + precip_frac_1, & ! Precipitation fraction (1st PDF component) [-] + precip_frac_2 ! Precipitation fraction (2nd PDF component) [-] + + real( kind = core_rknd ), dimension(hydromet_dim), intent(in) :: & + wphydrometp_zt ! Covariance of w and hm interp. to t-levs. [(m/s)u.v.] + + real( kind = core_rknd ), dimension(d_variables), intent(in) :: & + mu_x_1, & ! Mean of x array (1st PDF component) [units vary] + mu_x_2, & ! Mean of x array (2nd PDF component) [units vary] + sigma_x_1, & ! Standard deviation of x array (1st PDF comp.) [units vary] + sigma_x_2 ! Standard deviation of x array (2nd PDF comp.) [units vary] + + real( kind = core_rknd ), dimension(d_variables, d_variables), & + intent(in) :: & + corr_array_cloud, & ! Prescribed correlation array in cloud [-] + corr_array_below ! Prescribed correlation array below cloud [-] + + type(pdf_parameter), intent(in) :: & + pdf_params ! PDF parameters [units vary] + + ! Output Variables + real( kind = core_rknd ), dimension(d_variables, d_variables), & + intent(out) :: & + corr_array_1, & ! Correlation array (1st PDF component) [-] + corr_array_2 ! Correlation array (2nd PDF component) [-] + + ! Local Variables + real( kind = core_rknd ) :: & + sigma_Ncn_1 + + real( kind = core_rknd ), dimension(d_variables) :: & + corr_w_hm_1, & ! Correlation of w and hm (1st PDF component) ip [-] + corr_w_hm_2 ! Correlation of w and hm (2nd PDF component) ip [-] + + real( kind = core_rknd ) :: & + chi_m, & ! Mean of chi (s_mellor) [kg/kg] + stdev_chi, & ! Standard deviation of chi (s_mellor) [kg/kg] + corr_w_chi, & ! Correlation of w and chi (overall) [-] + corr_w_Ncn ! Correlation of w and Ncn (overall) [-] + + logical :: & + l_limit_corr_chi_eta ! Flag to limit the correlation of chi and eta [-] + + integer :: ivar, jvar ! Loop iterators + + ! ---- Begin Code ---- + + !!! Enter the PDF parameters. + sigma_Ncn_1 = sigma_x_1(iiPDF_Ncn) + + !!! Correlations + + ! Initialize corr_w_hm_1 and corr_w_hm_2 arrays to 0. + corr_w_hm_1 = zero + corr_w_hm_2 = zero + + ! Calculate correlations involving w by first calculating total covariances + ! involving w (, etc.) using the down-gradient approximation. + if ( l_calc_w_corr ) then + + chi_m & + = calc_mean( pdf_params%mixt_frac, pdf_params%chi_1, pdf_params%chi_2 ) + + stdev_chi & + = sqrt( pdf_params%mixt_frac & + * ( ( pdf_params%chi_1 - chi_m )**2 & + + pdf_params%stdev_chi_1**2 ) & + + ( one - pdf_params%mixt_frac ) & + * ( ( pdf_params%chi_2 - chi_m )**2 & + + pdf_params%stdev_chi_2**2 ) & + ) + + corr_w_chi & + = calc_w_corr( wpchip, stdev_w, stdev_chi, w_tol, chi_tol ) + + corr_w_Ncn = calc_w_corr( wpNcnp, stdev_w, sigma_Ncn_1, w_tol, Ncn_tol ) + + do jvar = iiPDF_Ncn+1, d_variables + + call calc_corr_w_hm( wm_zt, wphydrometp_zt(pdf2hydromet_idx(jvar)), & + mu_x_1(iiPDF_w), mu_x_2(iiPDF_w), & + mu_x_1(jvar), mu_x_2(jvar), & + sigma_x_1(iiPDF_w), sigma_x_2(iiPDF_w), & + sigma_x_1(jvar), sigma_x_2(jvar), & + mixt_frac, precip_frac_1, precip_frac_2, & + corr_w_hm_1(jvar), corr_w_hm_2(jvar), & + hydromet_tol(pdf2hydromet_idx(jvar)) ) + + enddo ! jvar = iiPDF_Ncn+1, d_variables + + + endif + + ! In order to decompose the correlation matrix, + ! we must not have a perfect correlation of chi and + ! eta. Thus, we impose a limitation. + l_limit_corr_chi_eta = .true. + + + ! Initialize the correlation arrays + corr_array_1 = zero + corr_array_2 = zero + + !!! The corr_arrays are assumed to be lower triangular matrices + ! Set diagonal elements to 1 + do ivar=1, d_variables + corr_array_1(ivar, ivar) = one + corr_array_2(ivar, ivar) = one + end do + + + !!! This code assumes the following order in the prescribed correlation + !!! arrays (iiPDF indices): + !!! chi, eta, w, Ncn, (indices increasing from left to right) + + ! Correlation of chi (old s) and eta (old t) + corr_array_1(iiPDF_eta, iiPDF_chi) & + = component_corr_chi_eta( pdf_params%corr_chi_eta_1, rc_1, cloud_frac_1, & + corr_array_cloud(iiPDF_eta, iiPDF_chi), & + corr_array_below(iiPDF_eta, iiPDF_chi), & + l_limit_corr_chi_eta ) + + corr_array_2(iiPDF_eta, iiPDF_chi) & + = component_corr_chi_eta( pdf_params%corr_chi_eta_2, rc_2, cloud_frac_2, & + corr_array_cloud(iiPDF_eta, iiPDF_chi), & + corr_array_below(iiPDF_eta, iiPDF_chi), & + l_limit_corr_chi_eta ) + + ! Correlation of chi (old s) and w + corr_array_1(iiPDF_w, iiPDF_chi) & + = component_corr_w_x( corr_w_chi, rc_1, cloud_frac_1, & + corr_array_cloud(iiPDF_w, iiPDF_chi), & + corr_array_below(iiPDF_w, iiPDF_chi) ) + + corr_array_2(iiPDF_w, iiPDF_chi) & + = component_corr_w_x( corr_w_chi, rc_2, cloud_frac_2, & + corr_array_cloud(iiPDF_w, iiPDF_chi), & + corr_array_below(iiPDF_w, iiPDF_chi) ) + + + ! Correlation of chi (old s) and Ncn + corr_array_1(iiPDF_Ncn, iiPDF_chi) & + = component_corr_x_hm_ip( rc_1, one, & + corr_array_cloud(iiPDF_Ncn, iiPDF_chi), & + corr_array_cloud(iiPDF_Ncn, iiPDF_chi) ) + + corr_array_2(iiPDF_Ncn, iiPDF_chi) & + = component_corr_x_hm_ip( rc_2, one, & + corr_array_cloud(iiPDF_Ncn, iiPDF_chi), & + corr_array_cloud(iiPDF_Ncn, iiPDF_chi) ) + + ! Correlation of chi (old s) and the hydrometeors + ivar = iiPDF_chi + do jvar = iiPDF_Ncn+1, d_variables + corr_array_1(jvar, ivar) & + = component_corr_x_hm_ip( rc_1, cloud_frac_1,& + corr_array_cloud(jvar, ivar), & + corr_array_below(jvar, ivar) ) + + corr_array_2(jvar, ivar) & + = component_corr_x_hm_ip( rc_2, cloud_frac_2,& + corr_array_cloud(jvar, ivar), & + corr_array_below(jvar, ivar) ) + enddo + + ! Correlation of eta (old t) and w + corr_array_1(iiPDF_w, iiPDF_eta) = zero + corr_array_2(iiPDF_w, iiPDF_eta) = zero + + ! Correlation of eta (old t) and Ncn + corr_array_1(iiPDF_Ncn, iiPDF_eta) & + = component_corr_x_hm_ip( rc_1, one, & + corr_array_cloud(iiPDF_Ncn, iiPDF_eta), & + corr_array_cloud(iiPDF_Ncn, iiPDF_eta) ) + + corr_array_2(iiPDF_Ncn, iiPDF_eta) & + = component_corr_x_hm_ip( rc_2, one, & + corr_array_cloud(iiPDF_Ncn, iiPDF_eta), & + corr_array_cloud(iiPDF_Ncn, iiPDF_eta) ) + + ! Correlation of eta (old t) and the hydrometeors + ivar = iiPDF_eta + do jvar = iiPDF_Ncn+1, d_variables + corr_array_1(jvar, ivar) & + = component_corr_eta_hm_ip( corr_array_1( iiPDF_eta, iiPDF_chi), & + corr_array_1( jvar, iiPDF_chi) ) + + corr_array_2(jvar, ivar) & + = component_corr_eta_hm_ip( corr_array_2( iiPDF_eta, iiPDF_chi), & + corr_array_2( jvar, iiPDF_chi) ) + enddo + + + ! Correlation of w and Ncn + corr_array_1(iiPDF_Ncn, iiPDF_w) & + = component_corr_w_hm_ip( corr_w_Ncn, rc_1, one, & + corr_array_cloud(iiPDF_Ncn, iiPDF_w), & + corr_array_below(iiPDF_Ncn, iiPDF_w) ) + + corr_array_2(iiPDF_Ncn, iiPDF_w) & + = component_corr_w_hm_ip( corr_w_Ncn, rc_2, one, & + corr_array_cloud(iiPDF_Ncn, iiPDF_w), & + corr_array_below(iiPDF_Ncn, iiPDF_w) ) + + ! Correlation of w and the hydrometeors + ivar = iiPDF_w + do jvar = iiPDF_Ncn+1, d_variables + + corr_array_1(jvar, ivar) & + = component_corr_w_hm_ip( corr_w_hm_1(jvar), rc_1, cloud_frac_1, & + corr_array_cloud(jvar, ivar), & + corr_array_below(jvar, ivar) ) + + corr_array_2(jvar, ivar) & + = component_corr_w_hm_ip( corr_w_hm_2(jvar), rc_2, cloud_frac_2, & + corr_array_cloud(jvar, ivar), & + corr_array_below(jvar, ivar) ) + + enddo + + ! Correlation of Ncn and the hydrometeors + ivar = iiPDF_Ncn + do jvar = iiPDF_Ncn+1, d_variables + corr_array_1(jvar, ivar) & + = component_corr_hmx_hmy_ip( rc_1, cloud_frac_1, & + corr_array_cloud(jvar, ivar), & + corr_array_below(jvar, ivar) ) + + corr_array_2(jvar, ivar) & + = component_corr_hmx_hmy_ip( rc_2, cloud_frac_2, & + corr_array_cloud(jvar, ivar), & + corr_array_below(jvar, ivar) ) + enddo + + ! Correlation of two hydrometeors + do ivar = iiPDF_Ncn+1, d_variables-1 + do jvar = ivar+1, d_variables + + corr_array_1(jvar, ivar) & + = component_corr_hmx_hmy_ip( rc_1, cloud_frac_1, & + corr_array_cloud(jvar, ivar), & + corr_array_below(jvar, ivar) ) + + corr_array_2(jvar, ivar) & + = component_corr_hmx_hmy_ip( rc_2, cloud_frac_2, & + corr_array_cloud(jvar, ivar), & + corr_array_below(jvar, ivar) ) + + enddo ! jvar + enddo ! ivar + + + return + + end subroutine compute_corr + + !============================================================================= + function component_mean_hm_ip( hmi, precip_frac_i, hydromet_tol ) & + result( mu_hm_i ) + + ! Description: + ! Calculates the in-precip mean of a hydrometeor species within the ith + ! PDF component. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + zero ! Constant(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + hmi, & ! Mean of hydrometeor, hm (ith PDF component) [hm units] + precip_frac_i, & ! Precipitation fraction (ith PDF component) [-] + hydromet_tol ! Tolerance value for the hydrometeor [hm units] + + ! Return Variable + real( kind = core_rknd ) :: & + mu_hm_i ! Mean of hm (ith PDF component) in-precip (ip) [hm units] + + + ! Mean of the hydrometeor (in-precip) in the ith PDF component. + if ( hmi > hydromet_tol ) then + mu_hm_i = hmi / precip_frac_i + else + ! The mean of the hydrometeor in the ith PDF component is less than the + ! tolerance amount for the particular hydrometeor. It is considered to + ! have a value of 0. There is not any of this hydrometeor species in the + ! ith PDF component at this grid level. + mu_hm_i = zero + endif + + + return + + end function component_mean_hm_ip + + !============================================================================= + function component_stdev_hm_ip( mu_hm_i, rci, cloud_fraci, & + hm_sigma2_on_mu2_cloud, & + hm_sigma2_on_mu2_below ) & + result( sigma_hm_i ) + + ! Description: + ! Calculates the in-precip standard deviation of a hydrometeor species + ! within the ith PDF component. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + rc_tol + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + mu_hm_i, & ! Mean of hm (ith PDF component) in-precip (ip) [hm units] + rci, & ! Mean cloud water mixing ratio (ith PDF comp.) [kg/kg] + cloud_fraci ! Cloud fraction (ith PDF component) [-] + + real( kind = core_rknd ), intent(in) :: & + hm_sigma2_on_mu2_cloud, & ! Ratio sigma_hm_1^2/mu_hm_1^2; cloudy levs. [-] + hm_sigma2_on_mu2_below ! Ratio sigma_hm_2^2/mu_hm_2^2; clear levs. [-] + + ! Return Variable + real( kind = core_rknd ) :: & + sigma_hm_i ! Standard deviation of hm (ith PDF component) ip [hm units] + + + ! Standard deviation of the hydrometeor (in-precip) in the + ! ith PDF component. + if ( l_interp_prescribed_params ) then + sigma_hm_i = sqrt( cloud_fraci * hm_sigma2_on_mu2_cloud & + + ( one - cloud_fraci ) * hm_sigma2_on_mu2_below ) & + * mu_hm_i + else + if ( rci > rc_tol ) then + sigma_hm_i = sqrt( hm_sigma2_on_mu2_cloud ) * mu_hm_i + else + sigma_hm_i = sqrt( hm_sigma2_on_mu2_below ) * mu_hm_i + endif + endif + + return + + end function component_stdev_hm_ip + + !============================================================================= + function component_corr_w_x( corr_w_x, rc_i, cloud_frac_i, & + corr_w_x_NN_cloud, corr_w_x_NN_below ) & + result( corr_w_x_i ) + + ! Description: + ! Calculates the correlation of w and x within the ith PDF component. + ! Here, x is a variable with a normally distributed individual marginal PDF, + ! such as chi or eta. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + zero, & + rc_tol + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use model_flags, only: & + l_calc_w_corr + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + corr_w_x, & ! Correlation of w and x (overall) [-] + rc_i, & ! Mean cloud water mixing ratio (ith PDF comp.) [kg/kg] + cloud_frac_i ! Cloud fraction (ith PDF component) [-] + + real( kind = core_rknd ), intent(in) :: & + corr_w_x_NN_cloud, & ! Corr. of w and x (ith PDF comp.); cloudy levs [-] + corr_w_x_NN_below ! Corr. of w and x (ith PDF comp.); clear levs [-] + + ! Return Variable + real( kind = core_rknd ) :: & + corr_w_x_i ! Correlation of w and x (ith PDF component) [-] + + ! Local Variables + + ! The component correlations of w and r_t and the component correlations of + ! w and theta_l are both set to be 0 within the CLUBB model code. In other + ! words, w and r_t (theta_l) have overall covariance w'r_t' (w'theta_l'), + ! but the single component covariance and correlation are defined to be 0. + ! Since the component covariances (or correlations) of w and chi (old s) and + ! of w and eta (old t) are based on the covariances (or correlations) of w + ! and r_t and of w and theta_l, the single component correlation and + ! covariance of w and chi, as well of as w and eta, are defined to be 0. + logical, parameter :: & + l_follow_CLUBB_PDF_standards = .true. + + + ! Correlation of w and x in the ith PDF component. + if ( l_follow_CLUBB_PDF_standards ) then + + ! The component correlations of w and r_t and the component correlations + ! of w and theta_l are both set to be 0 within the CLUBB model code. In + ! other words, w and r_t (theta_l) have overall covariance w'r_t' + ! (w'theta_l'), but the single component covariance and correlation are + ! defined to be 0. Since the component covariances (or correlations) + ! of w and chi (old s) and of w and eta (old t) are based on the + ! covariances (or correlations) of w and r_t and of w and theta_l, the + ! single component correlation and covariance of w and chi, as well as of + ! w and eta, are defined to be 0. + corr_w_x_i = zero + + else ! not following CLUBB PDF standards + + ! WARNING: the standards used in the generation of the two-component + ! CLUBB PDF are not being obeyed. The use of this code is + ! inconsistent with the rest of CLUBB's PDF. + if ( l_calc_w_corr ) then + corr_w_x_i = corr_w_x + else ! use prescribed parameter values + if ( l_interp_prescribed_params ) then + corr_w_x_i = cloud_frac_i * corr_w_x_NN_cloud & + + ( one - cloud_frac_i ) * corr_w_x_NN_below + else + if ( rc_i > rc_tol ) then + corr_w_x_i = corr_w_x_NN_cloud + else + corr_w_x_i = corr_w_x_NN_below + endif + endif ! l_interp_prescribed_params + endif ! l_calc_w_corr + + endif ! l_follow_CLUBB_PDF_standards + + + return + + end function component_corr_w_x + + !============================================================================= + function component_corr_chi_eta( pdf_corr_chi_eta_i, rc_i, cloud_frac_i, & + corr_chi_eta_NN_cloud, & + corr_chi_eta_NN_below, & + l_limit_corr_chi_eta ) & + result( corr_chi_eta_i ) + + ! Description: + ! Calculates the correlation of chi (old s) and eta (old t) within the + ! ith PDF component. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + rc_tol, & + max_mag_correlation + + use model_flags, only: & + l_fix_chi_eta_correlations ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Constant + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + pdf_corr_chi_eta_i, & ! Correlation of chi and eta (ith PDF component) [-] + rc_i, & ! Mean cloud water mix. rat. (ith PDF comp.) [kg/kg] + cloud_frac_i ! Cloud fraction (ith PDF component) [-] + + real( kind = core_rknd ), intent(in) :: & + corr_chi_eta_NN_cloud, & ! Corr. of chi & eta (ith PDF comp.); cloudy [-] + corr_chi_eta_NN_below ! Corr. of chi & eta (ith PDF comp.); clear [-] + + logical, intent(in) :: & + l_limit_corr_chi_eta ! We must limit the correlation of chi and eta if + ! we are to take the Cholesky decomposition of the + ! resulting correlation matrix. This is because a + ! perfect correlation of chi and eta was found to + ! be unrealizable. + + ! Return Variable + real( kind = core_rknd ) :: & + corr_chi_eta_i ! Correlation of chi and eta (ith PDF component) [-] + + + ! Correlation of chi (old s) and eta (old t) in the ith PDF component. + + ! The PDF variables chi and eta result from a transformation of the PDF + ! involving r_t and theta_l. The correlation of chi and eta depends on the + ! correlation of r_t and theta_l, as well as the variances of r_t and + ! theta_l, and other factors. The correlation of chi and eta is subject to + ! change at every vertical level and model time step, and is calculated as + ! part of the CLUBB PDF parameters. + if ( .not. l_fix_chi_eta_correlations ) then + + ! Preferred, more accurate version. + corr_chi_eta_i = pdf_corr_chi_eta_i + + else ! fix the correlation of chi (old s) and eta (old t). + + ! WARNING: this code is inconsistent with the rest of CLUBB's PDF. This + ! code is necessary because SILHS is lazy and wussy, and only + ! wants to declare correlation arrays at the start of the model + ! run, rather than updating them throughout the model run. + if ( l_interp_prescribed_params ) then + corr_chi_eta_i = cloud_frac_i * corr_chi_eta_NN_cloud & + + ( one - cloud_frac_i ) * corr_chi_eta_NN_below + else + if ( rc_i > rc_tol ) then + corr_chi_eta_i = corr_chi_eta_NN_cloud + else + corr_chi_eta_i = corr_chi_eta_NN_below + endif + endif + + endif + + ! We cannot have a perfect correlation of chi (old s) and eta (old t) if we + ! plan to decompose this matrix and we don't want the Cholesky_factor code + ! to throw a fit. + if ( l_limit_corr_chi_eta ) then + + corr_chi_eta_i = max( min( corr_chi_eta_i, max_mag_correlation ), & + -max_mag_correlation ) + + endif + + + return + + end function component_corr_chi_eta + + !============================================================================= + function component_corr_w_hm_ip( corr_w_hm_i_in, rc_i, cloud_frac_i, & + corr_w_hm_NL_cloud, corr_w_hm_NL_below ) & + result( corr_w_hm_i ) + + ! Description: + ! Calculates the in-precip correlation of w and a hydrometeor species + ! within the ith PDF component. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + rc_tol + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use model_flags, only: & + l_calc_w_corr + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + corr_w_hm_i_in, & ! Correlation of w and hm (ith PDF comp.) ip [-] + rc_i, & ! Mean cloud water mixing ratio (ith PDF comp.) [kg/kg] + cloud_frac_i ! Cloud fraction (ith PDF component) [-] + + real( kind = core_rknd ), intent(in) :: & + corr_w_hm_NL_cloud, & ! Corr. of w and hm (ith PDF comp.) ip; cloudy [-] + corr_w_hm_NL_below ! Corr. of w and hm (ith PDF comp.) ip; clear [-] + + ! Return Variable + real( kind = core_rknd ) :: & + corr_w_hm_i ! Correlation of w and hm (ith PDF component) ip [-] + + + ! Correlation (in-precip) of w and the hydrometeor in the ith PDF component. + if ( l_calc_w_corr ) then + corr_w_hm_i = corr_w_hm_i_in + else ! use prescribed parameter values + if ( l_interp_prescribed_params ) then + corr_w_hm_i = cloud_frac_i * corr_w_hm_NL_cloud & + + ( one - cloud_frac_i ) * corr_w_hm_NL_below + else + if ( rc_i > rc_tol ) then + corr_w_hm_i = corr_w_hm_NL_cloud + else + corr_w_hm_i = corr_w_hm_NL_below + endif + endif ! l_interp_prescribed_params + endif ! l_calc_w_corr + + return + + end function component_corr_w_hm_ip + + !============================================================================= + function component_corr_x_hm_ip( rc_i, cloud_frac_i, & + corr_x_hm_NL_cloud, corr_x_hm_NL_below ) & + result( corr_x_hm_i ) + + ! Description: + ! Calculates the in-precip correlation of x and a hydrometeor species + ! within the ith PDF component. Here, x is a variable with a normally + ! distributed individual marginal PDF, such as chi or eta. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + rc_tol + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + rc_i, & ! Mean cloud water mixing ratio (ith PDF comp.) [kg/kg] + cloud_frac_i ! Cloud fraction (ith PDF component) [-] + + real( kind = core_rknd ), intent(in) :: & + corr_x_hm_NL_cloud, & ! Corr. of x and hm (ith PDF comp.) ip; cloudy [-] + corr_x_hm_NL_below ! Corr. of x and hm (ith PDF comp.) ip; clear [-] + + ! Return Variable + real( kind = core_rknd ) :: & + corr_x_hm_i ! Correlation of x and hm (ith PDF component) ip [-] + + + ! Correlation (in-precip) of x and the hydrometeor in the ith PDF component. + if ( l_interp_prescribed_params ) then + corr_x_hm_i = cloud_frac_i * corr_x_hm_NL_cloud & + + ( one - cloud_frac_i ) * corr_x_hm_NL_below + else + if ( rc_i > rc_tol ) then + corr_x_hm_i = corr_x_hm_NL_cloud + else + corr_x_hm_i = corr_x_hm_NL_below + endif + endif + + return + + end function component_corr_x_hm_ip + + !============================================================================= + function component_corr_hmx_hmy_ip( rc_i, cloud_frac_i, & + corr_hmx_hmy_LL_cloud, & + corr_hmx_hmy_LL_below ) & + result( corr_hmx_hmy_i ) + + ! Description: + ! Calculates the in-precip correlation of hydrometeor x and + ! hydrometeor y within the ith PDF component. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + rc_tol + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + rc_i, & ! Mean cloud water mixing ratio (ith PDF comp.) [kg/kg] + cloud_frac_i ! Cloud fraction (ith PDF component) [-] + + real( kind = core_rknd ), intent(in) :: & + corr_hmx_hmy_LL_cloud, & ! Corr.: hmx & hmy (ith PDF comp.) ip; cloudy [-] + corr_hmx_hmy_LL_below ! Corr.: hmx & hmy (ith PDF comp.) ip; clear [-] + + ! Return Variable + real( kind = core_rknd ) :: & + corr_hmx_hmy_i ! Correlation of hmx & hmy (ith PDF component) ip [-] + + + ! Correlation (in-precip) of hydrometeor x and hydrometeor y in the + ! ith PDF component. + if ( l_interp_prescribed_params ) then + corr_hmx_hmy_i = cloud_frac_i * corr_hmx_hmy_LL_cloud & + + ( one - cloud_frac_i ) * corr_hmx_hmy_LL_below + else + if ( rc_i > rc_tol ) then + corr_hmx_hmy_i = corr_hmx_hmy_LL_cloud + else + corr_hmx_hmy_i = corr_hmx_hmy_LL_below + endif + endif + + return + + end function component_corr_hmx_hmy_ip + + !============================================================================= + pure function component_corr_eta_hm_ip( corr_chi_eta_i, corr_chi_hm_i ) & + result( corr_eta_hm_i ) + + ! Description: + ! Estimates the correlation of eta and a hydrometeor species using the + ! correlation of chi and eta and the correlation of chi and the hydrometeor. + ! This facilities the Cholesky decomposability of the correlation array that + ! will inevitably be decomposed for SILHS purposes. Without this estimation, + ! we have found that the resulting correlation matrix cannot be decomposed. + + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Constant + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + corr_chi_eta_i, & ! Component correlation of chi and eta [-] + corr_chi_hm_i ! Component correlation of chi and the hydrometeor [-] + + ! Output Variables + real( kind = core_rknd ) :: & + corr_eta_hm_i ! Component correlation of eta and the hydrometeor [-] + + + corr_eta_hm_i = corr_chi_eta_i * corr_chi_hm_i + + + return + + end function component_corr_eta_hm_ip + + !============================================================================= + subroutine normalize_mean_stdev( hm1, hm2, Ncnm, d_variables, & + mu_x_1, mu_x_2, sigma_x_1, sigma_x_2, & + sigma2_on_mu2_ip_1, sigma2_on_mu2_ip_2, & + mu_x_1_n, mu_x_2_n, & + sigma_x_1_n, sigma_x_2_n ) + + ! Description: + ! Calculates the normalized means and the normalized standard deviations + ! of PDF variables that have assumed lognormal distributions -- which are + ! precipitating hydrometeors (in precipitation) and N_cn. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + Ncn_tol, & ! Constant(s) + zero + + use pdf_utilities, only: & + mean_L2N, & ! Procedure(s) + stdev_L2N + + use index_mapping, only: & + pdf2hydromet_idx ! Procedure(s) + + use corr_varnce_module, only: & + iiPDF_Ncn ! Variable(s) + + use array_index, only: & + hydromet_tol ! Variable(s) + + use parameters_model, only: & + hydromet_dim ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use model_flags, only: & + l_const_Nc_in_cloud ! Variable + + implicit none + + ! Input Variables + real( kind = core_rknd ), dimension(hydromet_dim), intent(in) :: & + hm1, & ! Mean of a precip. hydrometeor (1st PDF component) [units vary] + hm2 ! Mean of a precip. hydrometeor (2nd PDF component) [units vary] + + real( kind = core_rknd ), intent(in) :: & + Ncnm ! Mean cloud nuclei concentration, < N_cn > [num/kg] + + integer, intent(in) :: & + d_variables ! Number of variables in CLUBB's PDF + + real( kind = core_rknd ), dimension(d_variables), intent(in) :: & + mu_x_1, & ! Mean array of PDF vars. (1st PDF component) [units vary] + mu_x_2, & ! Mean array of PDF vars. (2nd PDF component) [units vary] + sigma_x_1, & ! Standard deviation array of PDF vars (comp. 1) [units vary] + sigma_x_2 ! Standard deviation array of PDF vars (comp. 2) [units vary] + + real( kind = core_rknd ), dimension(d_variables), intent(in) :: & + sigma2_on_mu2_ip_1, & ! Prescribed ratio array: sigma_hm_1^2/mu_hm_1^2 [-] + sigma2_on_mu2_ip_2 ! Prescribed ratio array: sigma_hm_2^2/mu_hm_2^2 [-] + + ! Output Variables + real( kind = core_rknd ), dimension(d_variables), intent(out) :: & + mu_x_1_n, & ! Mean array (normalized) of PDF vars. (comp. 1) [un. vary] + mu_x_2_n, & ! Mean array (normalized) of PDF vars. (comp. 2) [un. vary] + sigma_x_1_n, & ! Std. dev. array (normalized) of PDF vars (comp. 1) [u.v.] + sigma_x_2_n ! Std. dev. array (normalized) of PDF vars (comp. 2) [u.v.] + + ! Local Variable + integer :: ivar ! Loop index + + + ! The means and standard deviations in each PDF component of w, chi (old s), + ! and eta (old t) do not need to be normalized, since w, chi, and eta + ! already follow assumed normal distributions in each PDF component. The + ! normalized means and standard deviations are the same as the actual means + ! and standard deviations. + mu_x_1_n = mu_x_1 + mu_x_2_n = mu_x_2 + sigma_x_1_n = sigma_x_1 + sigma_x_2_n = sigma_x_2 + + !!! Calculate the normalized mean and standard deviation in each PDF + !!! component for variables that have an assumed lognormal distribution, + !!! given the mean and standard deviation in each PDF component for those + !!! variables. A precipitating hydrometeor has an assumed lognormal + !!! distribution in precipitation in each PDF component. Simplified cloud + !!! nuclei concentration, N_cn, has an assumed lognormal distribution in + !!! each PDF component, and furthermore, mu_Ncn_1 = mu_Ncn_2 and + !!! sigma_Ncn_1 = sigma_Ncn_2, so N_cn has an assumed single lognormal + !!! distribution over the entire domain. + + ! Normalized mean of simplified cloud nuclei concentration, N_cn, + ! in PDF component 1. + if ( Ncnm > Ncn_tol ) then + + mu_x_1_n(iiPDF_Ncn) = mean_L2N( mu_x_1(iiPDF_Ncn), & + sigma2_on_mu2_ip_1(iiPDF_Ncn) ) + + else + + ! Mean simplified cloud nuclei concentration in PDF component 1 is less + ! than the tolerance amount. It is considered to have a value of 0. + ! There are not any cloud nuclei or cloud at this grid level. The value + ! of mu_Ncn_1_n should be -inf. It will be set to -huge for purposes of + ! assigning it a value. + mu_x_1_n(iiPDF_Ncn) = -huge( mu_x_1(iiPDF_Ncn) ) + + endif + + ! Normalized mean of simplified cloud nuclei concentration, N_cn, + ! in PDF component 2. + if ( Ncnm > Ncn_tol ) then + + mu_x_2_n(iiPDF_Ncn) = mean_L2N( mu_x_2(iiPDF_Ncn), sigma2_on_mu2_ip_1(iiPDF_Ncn) ) + + else + + ! Mean simplified cloud nuclei concentration in PDF component 1 is less + ! than the tolerance amount. It is considered to have a value of 0. + ! There are not any cloud nuclei or cloud at this grid level. The value + ! of mu_Ncn_1_n should be -inf. It will be set to -huge for purposes of + ! assigning it a value. + mu_x_2_n(iiPDF_Ncn) = -huge( mu_x_2(iiPDF_Ncn) ) + + endif + + ! Normalized standard deviation of simplified cloud nuclei concentration, + ! N_cn, in PDF components 1 and 2. + if ( l_const_Nc_in_cloud ) then + ! Ncn does not vary in the grid box. + sigma_x_1_n(iiPDF_Ncn) = zero + sigma_x_2_n(iiPDF_Ncn) = zero + else + ! Ncn (perhaps) varies in the grid box. + sigma_x_1_n(iiPDF_Ncn) = stdev_L2N( sigma2_on_mu2_ip_1(iiPDF_Ncn) ) + sigma_x_2_n(iiPDF_Ncn) = stdev_L2N( sigma2_on_mu2_ip_2(iiPDF_Ncn) ) + end if + + ! Normalize precipitating hydrometeor means and standard deviations. + do ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Normalized mean of a precipitating hydrometeor, hm, in PDF component 1. + if ( hm1(pdf2hydromet_idx(ivar)) & + > hydromet_tol(pdf2hydromet_idx(ivar)) ) then + + mu_x_1_n(ivar) = mean_L2N( mu_x_1(ivar), sigma2_on_mu2_ip_1(ivar) ) + + else + + ! The mean of a precipitating hydrometeor in PDF component 1 is less + ! than its tolerance amount. It is considered to have a value of 0. + ! There is not any of this precipitating hydrometeor in the 1st PDF + ! component at this grid level. The in-precip mean of this + ! precipitating hydrometeor (1st PDF component) is also 0. The value + ! of mu_hm_1_n should be -inf. It will be set to -huge for purposes + ! of assigning it a value. + mu_x_1_n(ivar) = -huge( mu_x_1(ivar) ) + + endif + + ! Normalized standard deviation of a precipitating hydrometeor, hm, in + ! PDF component 1. + sigma_x_1_n(ivar) = stdev_L2N( sigma2_on_mu2_ip_1(ivar) ) + + ! Normalized mean of a precipitating hydrometeor, hm, in PDF component 2. + if ( hm2(pdf2hydromet_idx(ivar)) & + > hydromet_tol(pdf2hydromet_idx(ivar)) ) then + + mu_x_2_n(ivar) = mean_L2N( mu_x_2(ivar), sigma2_on_mu2_ip_2(ivar) ) + + else + + ! The mean of a precipitating hydrometeor in PDF component 2 is less + ! than its tolerance amount. It is considered to have a value of 0. + ! There is not any of this precipitating hydrometeor in the 2nd PDF + ! component at this grid level. The in-precip mean of this + ! precipitating hydrometeor (2nd PDF component) is also 0. The value + ! of mu_hm_2_n should be -inf. It will be set to -huge for purposes + ! of assigning it a value. + mu_x_2_n(ivar) = -huge( mu_x_2(ivar) ) + + endif + + ! Normalized standard deviation of a precipitating hydrometeor, hm, in + ! PDF component 2. + sigma_x_2_n(ivar) = stdev_L2N( sigma2_on_mu2_ip_2(ivar) ) + + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + + return + + end subroutine normalize_mean_stdev + + !============================================================================= + subroutine normalize_corr( d_variables, sigma_x_1_n, sigma_x_2_n, & + sigma2_on_mu2_ip_1, sigma2_on_mu2_ip_2, & + corr_array_1, corr_array_2, & + corr_array_1_n, corr_array_2_n ) + + ! Description: + ! Calculates the normalized correlations between PDF variables, where at + ! least one of the variables that is part of a correlation has an assumed + ! lognormal distribution -- which are the precipitating hydrometeors (in + ! precipitation) and N_cn. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + zero ! Constant + + use pdf_utilities, only: & + corr_NL2NN, & ! Procedure(s) + corr_LL2NN + + use corr_varnce_module, only: & + iiPDF_chi, & ! Variable(s) + iiPDF_eta, & + iiPDF_w, & + iiPDF_Ncn + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use model_flags, only: & + l_const_Nc_in_cloud ! Variable!! + + implicit none + + ! Input Variables + integer, intent(in) :: & + d_variables ! Number of PDF variables + + real( kind = core_rknd ), dimension(d_variables), intent(in) :: & + sigma_x_1_n, & ! Std. dev. array (normalized) of PDF vars (comp. 1) [u.v.] + sigma_x_2_n ! Std. dev. array (normalized) of PDF vars (comp. 2) [u.v.] + + real ( kind = core_rknd ), dimension(d_variables), intent(in) :: & + sigma2_on_mu2_ip_1, & ! Prescribed ratio array: sigma_hm_1^2/mu_hm_1^2 [-] + sigma2_on_mu2_ip_2 ! Prescribed ratio array: sigma_hm_2^2/mu_hm_2^2 [-] + + real( kind = core_rknd ), dimension(d_variables, d_variables), & + intent(in) :: & + corr_array_1, & ! Correlation array of PDF vars. (comp. 1) [-] + corr_array_2 ! Correlation array of PDF vars. (comp. 2) [-] + + ! Output Variables + real( kind = core_rknd ), dimension(d_variables, d_variables), & + intent(out) :: & + corr_array_1_n, & ! Corr. array (normalized) of PDF vars. (comp. 1) [-] + corr_array_2_n ! Corr. array (normalized) of PDF vars. (comp. 2) [-] + + ! Local Variables + integer :: ivar, jvar ! Loop indices + + + ! The correlations in each PDF component between two of w, chi (old s), and + ! eta (old t) do not need to be normalized, since w, chi, and eta already + ! follow assumed normal distributions in each PDF component. The normalized + ! correlations between any two of these variables are the same as the actual + ! correlations. + corr_array_1_n = corr_array_1 + corr_array_2_n = corr_array_2 + + !!! Calculate the normalized correlation of variables that have + !!! an assumed normal distribution and variables that have an assumed + !!! lognormal distribution for the ith PDF component, given their + !!! correlation and the normalized standard deviation of the variable with + !!! the assumed lognormal distribution. + + if ( l_const_Nc_in_cloud ) then + + ! Ncn does not vary in the grid box. Consequently, the correlation between + ! Ncn and any other variate is not defined. Here, we set the correlations + ! between Ncn and chi/eta/w to zero. + corr_array_1_n(iiPDF_Ncn, iiPDF_w) = zero + corr_array_2_n(iiPDF_Ncn, iiPDF_w) = zero + corr_array_1_n(iiPDF_Ncn, iiPDF_chi) = zero + corr_array_2_n(iiPDF_Ncn, iiPDF_chi) = zero + corr_array_1_n(iiPDF_Ncn, iiPDF_eta) = zero + corr_array_2_n(iiPDF_Ncn, iiPDF_eta) = zero + + else ! .not. l_const_Nc_in_cloud + + ! Normalize the correlations between chi/eta/w and N_cn. + + ! Normalize the correlation of w and N_cn in PDF component 1. + corr_array_1_n(iiPDF_Ncn, iiPDF_w) & + = corr_NL2NN( corr_array_1(iiPDF_Ncn, iiPDF_w), sigma_x_1_n(iiPDF_Ncn), & + sigma2_on_mu2_ip_1(iiPDF_Ncn) ) + + ! Normalize the correlation of w and N_cn in PDF component 2. + corr_array_2_n(iiPDF_Ncn, iiPDF_w) & + = corr_NL2NN( corr_array_2(iiPDF_Ncn, iiPDF_w), sigma_x_2_n(iiPDF_Ncn), & + sigma2_on_mu2_ip_1(iiPDF_Ncn) ) + + ! Normalize the correlation of chi (old s) and N_cn in PDF component 1. + corr_array_1_n(iiPDF_Ncn, iiPDF_chi) & + = corr_NL2NN( corr_array_1(iiPDF_Ncn, iiPDF_chi), & + sigma_x_1_n(iiPDF_Ncn), sigma2_on_mu2_ip_1(iiPDF_Ncn) ) + + ! Normalize the correlation of chi (old s) and N_cn in PDF component 2. + corr_array_2_n(iiPDF_Ncn, iiPDF_chi) & + = corr_NL2NN( corr_array_2(iiPDF_Ncn, iiPDF_chi), & + sigma_x_2_n(iiPDF_Ncn), sigma2_on_mu2_ip_1(iiPDF_Ncn) ) + + ! Normalize the correlation of eta (old t) and N_cn in PDF component 1. + corr_array_1_n(iiPDF_Ncn, iiPDF_eta) & + = corr_NL2NN( corr_array_1(iiPDF_Ncn, iiPDF_eta), & + sigma_x_1_n(iiPDF_Ncn), sigma2_on_mu2_ip_1(iiPDF_Ncn) ) + + ! Normalize the correlation of eta (old t) and N_cn in PDF component 2. + corr_array_2_n(iiPDF_Ncn, iiPDF_eta) & + = corr_NL2NN( corr_array_2(iiPDF_Ncn, iiPDF_eta), & + sigma_x_2_n(iiPDF_Ncn), sigma2_on_mu2_ip_1(iiPDF_Ncn) ) + + end if ! l_const_Nc_in_cloud + + ! Normalize the correlations (in-precip) between chi/eta/w and the + ! precipitating hydrometeors. + do ivar = iiPDF_chi, iiPDF_w + do jvar = iiPDF_Ncn+1, d_variables + + ! Normalize the correlation (in-precip) between w, chi, or eta and a + ! precipitating hydrometeor, hm, in PDF component 1. + corr_array_1_n(jvar, ivar) & + = corr_NL2NN( corr_array_1(jvar, ivar), sigma_x_1_n(jvar), & + sigma2_on_mu2_ip_1(jvar) ) + + ! Normalize the correlation (in-precip) between w, chi, or eta and a + ! precipitating hydrometeor, hm, in PDF component 2. + corr_array_2_n(jvar, ivar) & + = corr_NL2NN( corr_array_2(jvar, ivar), sigma_x_2_n(jvar), & + sigma2_on_mu2_ip_2(jvar) ) + + enddo ! jvar = iiPDF_Ncn+1, d_variables + enddo ! ivar = iiPDF_chi, iiPDF_w + + + !!! Calculate the normalized correlation of two variables that both + !!! have an assumed lognormal distribution for the ith PDF component, given + !!! their correlation and both of their normalized standard deviations. + + ! Normalize the correlations (in-precip) between N_cn and the precipitating + ! hydrometeors. + ivar = iiPDF_Ncn + do jvar = ivar+1, d_variables + + if ( l_const_Nc_in_cloud ) then + + ! Ncn does not vary, so these correlations are undefined. Set them to + ! zero. + corr_array_1_n(jvar,ivar) = zero + corr_array_2_n(jvar,ivar) = zero + + else ! .not. l_const_Nc_in_cloud + + ! Normalize the correlation (in-precip) between N_cn and a precipitating + ! hydrometeor, hm, in PDF component 1. + corr_array_1_n(jvar, ivar) & + = corr_LL2NN( corr_array_1(jvar, ivar), & + sigma_x_1_n(ivar), sigma_x_1_n(jvar), & + sigma2_on_mu2_ip_1(iiPDF_Ncn), sigma2_on_mu2_ip_1(jvar) ) + + ! Normalize the correlation (in-precip) between N_cn and a precipitating + ! hydrometeor, hm, in PDF component 2. + corr_array_2_n(jvar, ivar) & + = corr_LL2NN( corr_array_2(jvar, ivar), & + sigma_x_2_n(ivar), sigma_x_2_n(jvar), & + sigma2_on_mu2_ip_1(iiPDF_Ncn), sigma2_on_mu2_ip_2(jvar) ) + + end if ! l_const_Nc_in_cloud + + enddo ! jvar = ivar+1, d_variables + + ! Normalize the correlations (in-precip) between two precipitating + ! hydrometeors. + do ivar = iiPDF_Ncn+1, d_variables-1 + do jvar = ivar+1, d_variables + + ! Normalize the correlation (in-precip) between two precipitating + ! hydrometeors (for example, r_r and N_r) in PDF component 1. + corr_array_1_n(jvar, ivar) & + = corr_LL2NN( corr_array_1(jvar, ivar), & + sigma_x_1_n(ivar), sigma_x_1_n(jvar), & + sigma2_on_mu2_ip_1(ivar), sigma2_on_mu2_ip_1(jvar) ) + + ! Normalize the correlation (in-precip) between two precipitating + ! hydrometeors (for example, r_r and N_r) in PDF component 2. + corr_array_2_n(jvar, ivar) & + = corr_LL2NN( corr_array_2(jvar, ivar), & + sigma_x_2_n(ivar), sigma_x_2_n(jvar), & + sigma2_on_mu2_ip_2(ivar), sigma2_on_mu2_ip_2(jvar) ) + + enddo ! jvar = ivar+1, d_variables + enddo ! ivar = iiPDF_Ncn+1, d_variables-1 + + + return + + end subroutine normalize_corr + + !============================================================================= + subroutine calc_corr_w_hm( wm, wphydrometp, & + mu_w_1, mu_w_2, & + mu_hm_1, mu_hm_2, & + sigma_w_1, sigma_w_2, & + sigma_hm_1, sigma_hm_2, & + mixt_frac, precip_frac_1, precip_frac_2, & + corr_w_hm_1, corr_w_hm_2, & + hm_tol ) + + ! Description: + ! Calculates the PDF component correlation (in-precip) between vertical + ! velocity, w, and a hydrometeor, hm. The overall covariance of w and hm, + ! can be written in terms of the PDF parameters. When both w and hm + ! vary in both PDF components, the equation is written as: + ! + ! = mixt_frac * precip_frac_1 + ! * ( ( mu_w_1 - ) * mu_hm_1 + ! + corr_w_rr_1 * sigma_w_1 * sigma_rr_1 ) + ! + ( 1 - mixt_frac ) * precip_frac_2 + ! * ( ( mu_w_2 - ) * mu_hm_2 + ! + corr_w_rr_2 * sigma_w_2 * sigma_rr_2 ). + ! + ! The overall covariance is provided, so the component correlation is solved + ! by setting corr_w_rr_1 = corr_w_rr_2 ( = corr_w_rr ). The equation is: + ! + ! corr_w_rr + ! = ( + ! - mixt_frac * precip_frac_1 * ( mu_w_1 - ) * mu_hm_1 + ! - ( 1 - mixt_frac ) * precip_frac_2 * ( mu_w_2 - ) * mu_hm_2 ) + ! / ( mixt_frac * precip_frac_1 * sigma_w_1 * sigma_hm_1 + ! + ( 1 - mixt_frac ) * precip_frac_2 * sigma_w_2 * sigma_hm_2 ); + ! + ! again, where corr_w_rr_1 = corr_w_rr_2 = corr_w_rr. When either w or hm + ! isbconstant in one PDF component, but both w and hm vary in the other PDF + ! component, the equation for is written as: + ! + ! = mixt_frac * precip_frac_1 + ! * ( ( mu_w_1 - ) * mu_hm_1 + ! + corr_w_rr_1 * sigma_w_1 * sigma_rr_1 ) + ! + ( 1 - mixt_frac ) * precip_frac_2 + ! * ( mu_w_2 - ) * mu_hm_2. + ! + ! In the above equation, either w or hm (or both) is (are) constant in PDF + ! component 2, but both w and hm vary in PDF component 1. When both w and + ! hm vary in PDF component 2, but at least one of w or hm is constant in PDF + ! component 1, the equation is similar. The above equation can be rewritten + ! to solve for corr_w_rr_1, such that: + ! + ! corr_w_rr_1 + ! = ( + ! - mixt_frac * precip_frac_1 * ( mu_w_1 - ) * mu_hm_1 + ! - ( 1 - mixt_frac ) * precip_frac_2 * ( mu_w_2 - ) * mu_hm_2 ) + ! / ( mixt_frac * precip_frac_1 * sigma_w_1 * sigma_hm_1 ). + ! + ! Since either w or hm is constant in PDF component 2, corr_w_rr_2 is + ! undefined. When both w and hm vary in PDF component 2, but at least one + ! of w or hm is constant in PDF component 1, the equation is similar, but + ! is in terms of corr_w_rr_2, while corr_w_rr_1 is undefined. When either w + ! or hm is constant in both PDF components, the equation for is: + ! + ! = mixt_frac * precip_frac_1 + ! * ( mu_w_1 - ) * mu_hm_1 + ! + ( 1 - mixt_frac ) * precip_frac_2 + ! * ( mu_w_2 - ) * mu_hm_2. + ! + ! When this is the case, both corr_w_rr_1 and corr_w_rr_2 are undefined. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + zero, & + max_mag_correlation, & + w_tol + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + wm, & ! Mean vertical velocity (overall), [m/s] + wphydrometp, & ! Covariance of w and hm (overall), [m/s(hm un)] + mu_w_1, & ! Mean of w (1st PDF component) [m/s] + mu_w_2, & ! Mean of w (2nd PDF component) [m/s] + mu_hm_1, & ! Mean of hm (1st PDF component) in-precip (ip) [hm un] + mu_hm_2, & ! Mean of hm (2nd PDF component) ip [hm un] + sigma_w_1, & ! Standard deviation of w (1st PDF component) [m/s] + sigma_w_2, & ! Standard deviation of w (2nd PDF component) [m/s] + sigma_hm_1, & ! Standard deviation of hm (1st PDF component) ip [hm un] + sigma_hm_2, & ! Standard deviation of hm (2nd PDF component) ip [hm un] + mixt_frac, & ! Mixture fraction [-] + precip_frac_1, & ! Precipitation fraction (1st PDF component) [-] + precip_frac_2, & ! Precipitation fraction (2nd PDF component) [-] + hm_tol ! Hydrometeor tolerance value [hm un] + + ! Output Variables + real( kind = core_rknd ), intent(out) :: & + corr_w_hm_1, & ! Correlation of w and hm (1st PDF component) ip [-] + corr_w_hm_2 ! Correlation of w and hm (2nd PDF component) ip [-] + + ! Local Variables + real( kind = core_rknd ) :: & + corr_w_hm ! Correlation of w and hm (both PDF components) ip [-] + + + ! Calculate the PDF component correlation of vertical velocity, w, and + ! a hydrometeor, hm, in precipitation. + if ( sigma_w_1 > w_tol .and. sigma_hm_1 > hm_tol .and. & + sigma_w_2 > w_tol .and. sigma_hm_2 > hm_tol ) then + + ! Both w and hm vary in both PDF components. + ! Calculate corr_w_hm (where corr_w_hm_1 = corr_w_hm_2 = corr_w_hm). + corr_w_hm & + = ( wphydrometp & + - mixt_frac * precip_frac_1 * ( mu_w_1 - wm ) * mu_hm_1 & + - ( one - mixt_frac ) * precip_frac_2 * ( mu_w_2 - wm ) * mu_hm_2 ) & + / ( mixt_frac * precip_frac_1 * sigma_w_1 * sigma_hm_1 & + + ( one - mixt_frac ) * precip_frac_2 * sigma_w_2 * sigma_hm_2 ) + + ! Check that the PDF component correlations have reasonable values. + if ( corr_w_hm > max_mag_correlation ) then + corr_w_hm = max_mag_correlation + elseif ( corr_w_hm < -max_mag_correlation ) then + corr_w_hm = -max_mag_correlation + endif + + ! The PDF component correlations between w and hm (in-precip) are equal. + corr_w_hm_1 = corr_w_hm + corr_w_hm_2 = corr_w_hm + + + elseif ( sigma_w_1 > w_tol .and. sigma_hm_1 > hm_tol ) then + + ! Both w and hm vary in PDF component 1, but at least one of w and hm is + ! constant in PDF component 2. + ! Calculate the PDF component 1 correlation of w and hm (in-precip). + corr_w_hm_1 & + = ( wphydrometp & + - mixt_frac * precip_frac_1 * ( mu_w_1 - wm ) * mu_hm_1 & + - ( one - mixt_frac ) * precip_frac_2 * ( mu_w_2 - wm ) * mu_hm_2 ) & + / ( mixt_frac * precip_frac_1 * sigma_w_1 * sigma_hm_1 ) + + ! Check that the PDF component 1 correlation has a reasonable value. + if ( corr_w_hm_1 > max_mag_correlation ) then + corr_w_hm_1 = max_mag_correlation + elseif ( corr_w_hm_1 < -max_mag_correlation ) then + corr_w_hm_1 = -max_mag_correlation + endif + + ! The PDF component 2 correlation is undefined. + corr_w_hm_2 = zero + + + elseif ( sigma_w_2 > w_tol .and. sigma_hm_2 > hm_tol ) then + + ! Both w and hm vary in PDF component 2, but at least one of w and hm is + ! constant in PDF component 1. + ! Calculate the PDF component 2 correlation of w and hm (in-precip). + corr_w_hm_2 & + = ( wphydrometp & + - mixt_frac * precip_frac_1 * ( mu_w_1 - wm ) * mu_hm_1 & + - ( one - mixt_frac ) * precip_frac_2 * ( mu_w_2 - wm ) * mu_hm_2 ) & + / ( ( one - mixt_frac ) * precip_frac_2 * sigma_w_2 * sigma_hm_2 ) + + ! Check that the PDF component 2 correlation has a reasonable value. + if ( corr_w_hm_2 > max_mag_correlation ) then + corr_w_hm_2 = max_mag_correlation + elseif ( corr_w_hm_2 < -max_mag_correlation ) then + corr_w_hm_2 = -max_mag_correlation + endif + + ! The PDF component 1 correlation is undefined. + corr_w_hm_1 = zero + + + else ! sigma_w_1 * sigma_hm_1 = 0 .and. sigma_w_2 * sigma_hm_2 = 0. + + ! At least one of w and hm is constant in both PDF components. + + ! The PDF component 1 and component 2 correlations are both undefined. + corr_w_hm_1 = zero + corr_w_hm_2 = zero + + + endif + + + return + + end subroutine calc_corr_w_hm + + !============================================================================= + subroutine pdf_param_hm_stats( d_variables, level, mu_x_1, mu_x_2, & + sigma_x_1, sigma_x_2, & + corr_array_1, corr_array_2, & + l_stats_samp ) + + ! Description: + ! Record statistics for standard PDF parameters involving hydrometeors. + + ! References: + !----------------------------------------------------------------------- + + use index_mapping, only: & + pdf2hydromet_idx ! Procedure(s) + + use corr_varnce_module, only: & + iiPDF_w, & ! Variable(s) + iiPDF_chi, & + iiPDF_eta, & + iiPDF_Ncn + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use stats_type_utilities, only: & + stat_update_var_pt ! Procedure(s) + + use stats_variables, only : & + imu_hm_1, & ! Variable(s) + imu_hm_2, & + imu_Ncn_1, & + imu_Ncn_2, & + isigma_hm_1, & + isigma_hm_2, & + isigma_Ncn_1, & + isigma_Ncn_2 + + use stats_variables, only : & + icorr_w_chi_1, & ! Variable(s) + icorr_w_chi_2, & + icorr_w_eta_1, & + icorr_w_eta_2, & + icorr_w_hm_1, & + icorr_w_hm_2, & + icorr_w_Ncn_1, & + icorr_w_Ncn_2, & + icorr_chi_eta_1_ca, & + icorr_chi_eta_2_ca, & + icorr_chi_hm_1, & + icorr_chi_hm_2, & + icorr_chi_Ncn_1, & + icorr_chi_Ncn_2, & + icorr_eta_hm_1, & + icorr_eta_hm_2, & + icorr_eta_Ncn_1, & + icorr_eta_Ncn_2, & + icorr_Ncn_hm_1, & + icorr_Ncn_hm_2, & + icorr_hmx_hmy_1, & + icorr_hmx_hmy_2, & + stats_zt + + implicit none + + ! Input Variables + integer, intent(in) :: & + d_variables, & ! Number of variables in the correlation array + level ! Vertical level index + + real( kind = core_rknd ), dimension(d_variables), intent(in) :: & + mu_x_1, & ! Mean array of PDF vars. (1st PDF component) [units vary] + mu_x_2, & ! Mean array of PDF vars. (2nd PDF component) [units vary] + sigma_x_1, & ! Standard deviation array of PDF vars (comp. 1) [units vary] + sigma_x_2 ! Standard deviation array of PDF vars (comp. 2) [units vary] + + real( kind = core_rknd ), dimension(d_variables, d_variables), & + intent(in) :: & + corr_array_1, & ! Correlation array of PDF vars. (comp. 1) [-] + corr_array_2 ! Correlation array of PDF vars. (comp. 2) [-] + + logical, intent(in) :: & + l_stats_samp ! Flag to record statistical output. + + ! Local Variable + integer :: ivar, jvar ! Loop indices + + + !!! Output the statistics for hydrometeor PDF parameters. + + ! Statistics + if ( l_stats_samp ) then + + do ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Mean of the precipitating hydrometeor (in-precip) + ! in PDF component 1. + if ( imu_hm_1(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( imu_hm_1(pdf2hydromet_idx(ivar)), & + level, mu_x_1(ivar), stats_zt ) + endif + + ! Mean of the precipitating hydrometeor (in-precip) + ! in PDF component 2. + if ( imu_hm_2(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( imu_hm_2(pdf2hydromet_idx(ivar)), & + level, mu_x_2(ivar), stats_zt ) + endif + + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Mean of cloud nuclei concentration in PDF component 1. + if ( imu_Ncn_1 > 0 ) then + call stat_update_var_pt( imu_Ncn_1, level, mu_x_1(iiPDF_Ncn), stats_zt ) + endif + + ! Mean of cloud nuclei concentration in PDF component 2. + if ( imu_Ncn_2 > 0 ) then + call stat_update_var_pt( imu_Ncn_2, level, mu_x_2(iiPDF_Ncn), stats_zt ) + endif + + do ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Standard deviation of the precipitating hydrometeor (in-precip) + ! in PDF component 1. + if ( isigma_hm_1(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( isigma_hm_1(pdf2hydromet_idx(ivar)), & + level, sigma_x_1(ivar), stats_zt ) + endif + + ! Standard deviation of the precipitating hydrometeor (in-precip) + ! in PDF component 2. + if ( isigma_hm_2(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( isigma_hm_2(pdf2hydromet_idx(ivar)), & + level, sigma_x_2(ivar), stats_zt ) + endif + + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Standard deviation of cloud nuclei concentration in PDF component 1. + if ( isigma_Ncn_1 > 0 ) then + call stat_update_var_pt( isigma_Ncn_1, level, & + sigma_x_1(iiPDF_Ncn), stats_zt ) + endif + + ! Standard deviation of cloud nuclei concentration in PDF component 2. + if ( isigma_Ncn_2 > 0 ) then + call stat_update_var_pt( isigma_Ncn_2, level, & + sigma_x_2(iiPDF_Ncn), stats_zt ) + endif + + ! Correlation of w and chi (old s) in PDF component 1. + ! This correlation should always be 0 because both the correlation + ! between w and rt and the correlation of w and theta-l within each + ! PDF component are defined to be 0 by CLUBB standards. + if ( icorr_w_chi_1 > 0 ) then + call stat_update_var_pt( icorr_w_chi_1, level, & + corr_array_1(iiPDF_w,iiPDF_chi), stats_zt ) + endif + + ! Correlation of w and chi (old s) in PDF component 2. + ! This correlation should always be 0 because both the correlation + ! between w and rt and the correlation of w and theta-l within each + ! PDF component are defined to be 0 by CLUBB standards. + if ( icorr_w_chi_2 > 0 ) then + call stat_update_var_pt( icorr_w_chi_2, level, & + corr_array_2(iiPDF_w,iiPDF_chi), stats_zt ) + endif + + ! Correlation of w and eta (old t) in PDF component 1. + ! This correlation should always be 0 because both the correlation + ! between w and rt and the correlation of w and theta-l within each + ! PDF component are defined to be 0 by CLUBB standards. + if ( icorr_w_eta_1 > 0 ) then + call stat_update_var_pt( icorr_w_eta_1, level, & + corr_array_1(iiPDF_w,iiPDF_eta), stats_zt ) + endif + + ! Correlation of w and eta (old t) in PDF component 2. + ! This correlation should always be 0 because both the correlation + ! between w and rt and the correlation of w and theta-l within each + ! PDF component are defined to be 0 by CLUBB standards. + if ( icorr_w_eta_2 > 0 ) then + call stat_update_var_pt( icorr_w_eta_2, level, & + corr_array_2(iiPDF_w,iiPDF_eta), stats_zt ) + endif + + do ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Correlation (in-precip) of w and the precipitating hydrometeor + ! in PDF component 1. + if ( icorr_w_hm_1(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( icorr_w_hm_1(pdf2hydromet_idx(ivar)), & + level, corr_array_1(ivar,iiPDF_w), stats_zt ) + endif + + ! Correlation (in-precip) of w and the precipitating hydrometeor + ! in PDF component 2. + if ( icorr_w_hm_2(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( icorr_w_hm_2(pdf2hydromet_idx(ivar)), & + level, corr_array_2(ivar,iiPDF_w), stats_zt ) + endif + + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Correlation of w and N_cn in PDF component 1. + if ( icorr_w_Ncn_1 > 0 ) then + call stat_update_var_pt( icorr_w_Ncn_1, level, & + corr_array_1(iiPDF_Ncn,iiPDF_w), stats_zt ) + endif + + ! Correlation of w and N_cn in PDF component 2. + if ( icorr_w_Ncn_2 > 0 ) then + call stat_update_var_pt( icorr_w_Ncn_2, level, & + corr_array_2(iiPDF_Ncn,iiPDF_w), stats_zt ) + endif + + ! Correlation of chi (old s) and eta (old t) in PDF component 1 found in + ! the correlation array. + ! The true correlation of chi and eta in each PDF component is solved for + ! by an equation and is part of CLUBB's PDF parameters. However, there + ! is an option in CLUBB, l_fix_chi_eta_correlations, that sets the + ! component correlation of chi and eta to a constant, prescribed value + ! because of SILHS. The correlation of chi and eta in PDF component 1 + ! that is calculated by an equation is stored in stats as + ! "corr_chi_eta_1". Here, "corr_chi_eta_1_ca" outputs whatever value is + ! found in the correlation array, whether or not it matches + ! "corr_chi_eta_1". + if ( icorr_chi_eta_1_ca > 0 ) then + call stat_update_var_pt( icorr_chi_eta_1_ca, level, & + corr_array_1(iiPDF_eta,iiPDF_chi), stats_zt ) + endif + + ! Correlation of chi (old s) and eta (old t) in PDF component 2 found in + ! the correlation array. + ! The true correlation of chi and eta in each PDF component is solved for + ! by an equation and is part of CLUBB's PDF parameters. However, there + ! is an option in CLUBB, l_fix_chi_eta_correlations, that sets the + ! component correlation of chi and eta to a constant, prescribed value + ! because of SILHS. The correlation of chi and eta in PDF component 2 + ! that is calculated by an equation is stored in stats as + ! "corr_chi_eta_2". Here, "corr_chi_eta_2_ca" outputs whatever value is + ! found in the correlation array, whether or not it matches + ! "corr_chi_eta_2". + if ( icorr_chi_eta_2_ca > 0 ) then + call stat_update_var_pt( icorr_chi_eta_2_ca, level, & + corr_array_2(iiPDF_eta,iiPDF_chi), stats_zt ) + endif + + do ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Correlation (in-precip) of chi (old s) and the precipitating + ! hydrometeor in PDF component 1. + if ( icorr_chi_hm_1(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( icorr_chi_hm_1(pdf2hydromet_idx(ivar)), & + level, corr_array_1(ivar,iiPDF_chi), stats_zt ) + endif + + ! Correlation (in-precip) of chi (old s) and the precipitating + ! hydrometeor in PDF component 2. + if ( icorr_chi_hm_2(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( icorr_chi_hm_2(pdf2hydromet_idx(ivar)), & + level, corr_array_2(ivar,iiPDF_chi), stats_zt ) + endif + + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Correlation of chi (old s) and N_cn in PDF component 1. + if ( icorr_chi_Ncn_1 > 0 ) then + call stat_update_var_pt( icorr_chi_Ncn_1, level, & + corr_array_1(iiPDF_Ncn,iiPDF_chi), stats_zt ) + endif + + ! Correlation of chi (old s) and N_cn in PDF component 2. + if ( icorr_chi_Ncn_2 > 0 ) then + call stat_update_var_pt( icorr_chi_Ncn_2, level, & + corr_array_2(iiPDF_Ncn,iiPDF_chi), stats_zt ) + endif + + do ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Correlation (in-precip) of eta (old t) and the precipitating + ! hydrometeor in PDF component 1. + if ( icorr_eta_hm_1(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( icorr_eta_hm_1(pdf2hydromet_idx(ivar)), & + level, corr_array_1(ivar,iiPDF_eta), stats_zt ) + endif + + ! Correlation (in-precip) of eta (old t) and the precipitating + ! hydrometeor in PDF component 2. + if ( icorr_eta_hm_2(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( icorr_eta_hm_2(pdf2hydromet_idx(ivar)), & + level, corr_array_2(ivar,iiPDF_eta), stats_zt ) + endif + + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Correlation of eta (old t) and N_cn in PDF component 1. + if ( icorr_eta_Ncn_1 > 0 ) then + call stat_update_var_pt( icorr_eta_Ncn_1, level, & + corr_array_1(iiPDF_Ncn,iiPDF_eta), stats_zt ) + endif + + ! Correlation of eta (old t) and N_cn in PDF component 2. + if ( icorr_eta_Ncn_2 > 0 ) then + call stat_update_var_pt( icorr_eta_Ncn_2, level, & + corr_array_2(iiPDF_Ncn,iiPDF_eta), stats_zt ) + endif + + do ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Correlation (in-precip) of N_cn and the precipitating + ! hydrometeor in PDF component 1. + if ( icorr_Ncn_hm_1(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( icorr_Ncn_hm_1(pdf2hydromet_idx(ivar)), & + level, corr_array_1(ivar,iiPDF_Ncn), stats_zt ) + endif + + ! Correlation (in-precip) of N_cn and the precipitating + ! hydrometeor in PDF component 2. + if ( icorr_Ncn_hm_2(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( icorr_Ncn_hm_2(pdf2hydromet_idx(ivar)), & + level, corr_array_2(ivar,iiPDF_Ncn), stats_zt ) + endif + + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + do ivar = iiPDF_Ncn+1, d_variables, 1 + do jvar = ivar+1, d_variables, 1 + + ! Correlation (in-precip) of two different hydrometeors (hmx and + ! hmy) in PDF component 1. + if ( icorr_hmx_hmy_1(pdf2hydromet_idx(jvar),pdf2hydromet_idx(ivar)) & + > 0 ) then + call stat_update_var_pt( & + icorr_hmx_hmy_1(pdf2hydromet_idx(jvar),pdf2hydromet_idx(ivar)), & + level, corr_array_1(jvar,ivar), stats_zt ) + endif + + ! Correlation (in-precip) of two different hydrometeors (hmx and + ! hmy) in PDF component 2. + if ( icorr_hmx_hmy_2(pdf2hydromet_idx(jvar),pdf2hydromet_idx(ivar)) & + > 0 ) then + call stat_update_var_pt( & + icorr_hmx_hmy_2(pdf2hydromet_idx(jvar),pdf2hydromet_idx(ivar)), & + level, corr_array_2(jvar,ivar), stats_zt ) + endif + + enddo ! jvar = ivar+1, d_variables, 1 + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + endif ! l_stats_samp + + + return + + end subroutine pdf_param_hm_stats + + !============================================================================= + subroutine pdf_param_ln_hm_stats( d_variables, level, mu_x_1_n, & + mu_x_2_n, sigma_x_1_n, & + sigma_x_2_n, corr_array_1_n, & + corr_array_2_n, l_stats_samp ) + + ! Description: + ! Record statistics for normalized PDF parameters involving hydrometeors. + + ! References: + !----------------------------------------------------------------------- + + use index_mapping, only: & + pdf2hydromet_idx ! Procedure(s) + + use corr_varnce_module, only: & + iiPDF_w, & ! Variable(s) + iiPDF_chi, & + iiPDF_eta, & + iiPDF_Ncn + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use stats_type_utilities, only: & + stat_update_var_pt ! Procedure(s) + + use stats_variables, only : & + imu_hm_1_n, & ! Variable(s) + imu_hm_2_n, & + imu_Ncn_1_n, & + imu_Ncn_2_n, & + isigma_hm_1_n, & + isigma_hm_2_n, & + isigma_Ncn_1_n, & + isigma_Ncn_2_n + + use stats_variables, only : & + icorr_w_hm_1_n, & ! Variables + icorr_w_hm_2_n, & + icorr_w_Ncn_1_n, & + icorr_w_Ncn_2_n, & + icorr_chi_hm_1_n, & + icorr_chi_hm_2_n, & + icorr_chi_Ncn_1_n, & + icorr_chi_Ncn_2_n, & + icorr_eta_hm_1_n, & + icorr_eta_hm_2_n, & + icorr_eta_Ncn_1_n, & + icorr_eta_Ncn_2_n, & + icorr_Ncn_hm_1_n, & + icorr_Ncn_hm_2_n, & + icorr_hmx_hmy_1_n, & + icorr_hmx_hmy_2_n, & + stats_zt + + implicit none + + ! Input Variables + integer, intent(in) :: & + d_variables, & ! Number of variables in the correlation array + level ! Vertical level index + + real( kind = core_rknd ), dimension(d_variables), intent(in) :: & + mu_x_1_n, & ! Mean array (normalized) of PDF vars. (comp. 1) [un. vary] + mu_x_2_n, & ! Mean array (normalized) of PDF vars. (comp. 2) [un. vary] + sigma_x_1_n, & ! Std. dev. array (normalized) of PDF vars (comp. 1) [u.v.] + sigma_x_2_n ! Std. dev. array (normalized) of PDF vars (comp. 2) [u.v.] + + real( kind = core_rknd ), dimension(d_variables, d_variables), & + intent(in) :: & + corr_array_1_n, & ! Corr. array (normalized) of PDF vars. (comp. 1) [-] + corr_array_2_n ! Corr. array (normalized) of PDF vars. (comp. 2) [-] + + logical, intent(in) :: & + l_stats_samp ! Flag to record statistical output. + + ! Local Variable + integer :: ivar, jvar ! Loop indices + + + !!! Output the statistics for normalized hydrometeor PDF parameters. + + ! Statistics + if ( l_stats_samp ) then + + do ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Mean (in-precip) of ln hm in PDF component 1. + if ( imu_hm_1_n(pdf2hydromet_idx(ivar)) > 0 ) then + if ( mu_x_1_n(ivar) > real( -huge( 0.0 ), kind = core_rknd ) ) then + call stat_update_var_pt( imu_hm_1_n(pdf2hydromet_idx(ivar)), & + level, mu_x_1_n(ivar), stats_zt ) + else + ! When hm1 is 0 (or below tolerance value), mu_hm_1_n is -inf, + ! and is set to -huge for the default CLUBB kind. Some + ! compilers have issues outputting to stats files (in single + ! precision) when the default CLUBB kind is in double precision. + ! Set to -huge for single precision. + call stat_update_var_pt( imu_hm_1_n(pdf2hydromet_idx(ivar)), & + level, real( -huge( 0.0 ), & + kind = core_rknd ), & + stats_zt ) + endif + endif + + ! Mean (in-precip) of ln hm in PDF component 2. + if ( imu_hm_2_n(pdf2hydromet_idx(ivar)) > 0 ) then + if ( mu_x_2_n(ivar) > real( -huge( 0.0 ), kind = core_rknd ) ) then + call stat_update_var_pt( imu_hm_2_n(pdf2hydromet_idx(ivar)), & + level, mu_x_2_n(ivar), stats_zt ) + else + ! When hm2 is 0 (or below tolerance value), mu_hm_2_n is -inf, + ! and is set to -huge for the default CLUBB kind. Some + ! compilers have issues outputting to stats files (in single + ! precision) when the default CLUBB kind is in double precision. + ! Set to -huge for single precision. + call stat_update_var_pt( imu_hm_2_n(pdf2hydromet_idx(ivar)), & + level, real( -huge( 0.0 ), & + kind = core_rknd ), & + stats_zt ) + endif + endif + + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Mean of ln N_cn in PDF component 1. + if ( imu_Ncn_1_n > 0 ) then + if ( mu_x_1_n(iiPDF_Ncn) & + > real( -huge( 0.0 ), kind = core_rknd ) ) then + call stat_update_var_pt( imu_Ncn_1_n, level, & + mu_x_1_n(iiPDF_Ncn), stats_zt ) + else + ! When Ncnm is 0 (or below tolerance value), mu_Ncn_1_n is -inf, + ! and is set to -huge for the default CLUBB kind. Some compilers + ! have issues outputting to stats files (in single precision) when + ! the default CLUBB kind is in double precision. + ! Set to -huge for single precision. + call stat_update_var_pt( imu_Ncn_1_n, level, & + real( -huge( 0.0 ), kind = core_rknd ), & + stats_zt ) + endif + endif + + ! Mean of ln N_cn in PDF component 2. + if ( imu_Ncn_2_n > 0 ) then + if ( mu_x_2_n(iiPDF_Ncn) & + > real( -huge( 0.0 ), kind = core_rknd ) ) then + call stat_update_var_pt( imu_Ncn_2_n, level, & + mu_x_2_n(iiPDF_Ncn), stats_zt ) + else + ! When Ncnm is 0 (or below tolerance value), mu_Ncn_2_n is -inf, + ! and is set to -huge for the default CLUBB kind. Some compilers + ! have issues outputting to stats files (in single precision) when + ! the default CLUBB kind is in double precision. + ! Set to -huge for single precision. + call stat_update_var_pt( imu_Ncn_2_n, level, & + real( -huge( 0.0 ), kind = core_rknd ), & + stats_zt ) + endif + endif + + do ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Standard deviation (in-precip) of ln hm in PDF component 1. + if ( isigma_hm_1_n(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( isigma_hm_1_n(pdf2hydromet_idx(ivar)), & + level, sigma_x_1_n(ivar), stats_zt ) + endif + + ! Standard deviation (in-precip) of ln hm in PDF component 2. + if ( isigma_hm_2_n(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( isigma_hm_2_n(pdf2hydromet_idx(ivar)), & + level, sigma_x_2_n(ivar), stats_zt ) + endif + + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Standard deviation of ln N_cn in PDF component 1. + if ( isigma_Ncn_1_n > 0 ) then + call stat_update_var_pt( isigma_Ncn_1_n, level, & + sigma_x_1_n(iiPDF_Ncn), stats_zt ) + endif + + ! Standard deviation of ln N_cn in PDF component 2. + if ( isigma_Ncn_2_n > 0 ) then + call stat_update_var_pt( isigma_Ncn_2_n, level, & + sigma_x_2_n(iiPDF_Ncn), stats_zt ) + endif + + do ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Correlation (in-precip) of w and ln hm in PDF component 1. + if ( icorr_w_hm_1_n(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( icorr_w_hm_1_n(pdf2hydromet_idx(ivar)), & + level, corr_array_1_n(ivar,iiPDF_w), stats_zt ) + endif + + ! Correlation (in-precip) of w and ln hm in PDF component 2. + if ( icorr_w_hm_2_n(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( icorr_w_hm_2_n(pdf2hydromet_idx(ivar)), & + level, corr_array_2_n(ivar,iiPDF_w), stats_zt ) + endif + + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Correlation of w and ln N_cn in PDF component 1. + if ( icorr_w_Ncn_1_n > 0 ) then + call stat_update_var_pt( icorr_w_Ncn_1_n, level, & + corr_array_1_n(iiPDF_Ncn,iiPDF_w), stats_zt ) + endif + + ! Correlation of w and ln N_cn in PDF component 2. + if ( icorr_w_Ncn_2_n > 0 ) then + call stat_update_var_pt( icorr_w_Ncn_2_n, level, & + corr_array_2_n(iiPDF_Ncn,iiPDF_w), stats_zt ) + endif + + do ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Correlation (in-precip) of chi (old s) and ln hm in PDF component 1. + if ( icorr_chi_hm_1_n(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt(icorr_chi_hm_1_n(pdf2hydromet_idx(ivar)), & + level, corr_array_1_n(ivar,iiPDF_chi), stats_zt ) + endif + + ! Correlation (in-precip) of chi( old s) and ln hm in PDF component 2. + if ( icorr_chi_hm_2_n(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt(icorr_chi_hm_2_n(pdf2hydromet_idx(ivar)), & + level, corr_array_2_n(ivar,iiPDF_chi), stats_zt ) + endif + + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Correlation of chi (old s) and ln N_cn in PDF component 1. + if ( icorr_chi_Ncn_1_n > 0 ) then + call stat_update_var_pt( icorr_chi_Ncn_1_n, level, & + corr_array_1_n(iiPDF_Ncn,iiPDF_chi), stats_zt ) + endif + + ! Correlation of chi(old s) and ln N_cn in PDF component 2. + if ( icorr_chi_Ncn_2_n > 0 ) then + call stat_update_var_pt( icorr_chi_Ncn_2_n, level, & + corr_array_2_n(iiPDF_Ncn,iiPDF_chi), stats_zt ) + endif + + do ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Correlation (in-precip) of eta (old t) and ln hm in PDF component 1. + if ( icorr_eta_hm_1_n(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt(icorr_eta_hm_1_n(pdf2hydromet_idx(ivar)), & + level, corr_array_1_n(ivar,iiPDF_eta), stats_zt ) + endif + + ! Correlation (in-precip) of eta (old t) and ln hm in PDF component 2. + if ( icorr_eta_hm_2_n(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt(icorr_eta_hm_2_n(pdf2hydromet_idx(ivar)), & + level, corr_array_2_n(ivar,iiPDF_eta), stats_zt ) + endif + + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Correlation of eta (old t) and ln N_cn in PDF component 1. + if ( icorr_eta_Ncn_1_n > 0 ) then + call stat_update_var_pt( icorr_eta_Ncn_1_n, level, & + corr_array_1_n(iiPDF_Ncn,iiPDF_eta), stats_zt ) + endif + + ! Correlation of eta (old t) and ln N_cn in PDF component 2. + if ( icorr_eta_Ncn_2_n > 0 ) then + call stat_update_var_pt( icorr_eta_Ncn_2_n, level, & + corr_array_2_n(iiPDF_Ncn,iiPDF_eta), stats_zt ) + endif + + do ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Correlation (in-precip) of ln N_cn and ln hm in PDF + ! component 1. + if ( icorr_Ncn_hm_1_n(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt(icorr_Ncn_hm_1_n(pdf2hydromet_idx(ivar)), & + level, corr_array_1_n(ivar,iiPDF_Ncn), & + stats_zt ) + endif + + ! Correlation (in-precip) of ln N_cn and ln hm in PDF + ! component 2. + if ( icorr_Ncn_hm_2_n(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt(icorr_Ncn_hm_2_n(pdf2hydromet_idx(ivar)), & + level, corr_array_2_n(ivar,iiPDF_Ncn), & + stats_zt ) + endif + + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + do ivar = iiPDF_Ncn+1, d_variables, 1 + do jvar = ivar+1, d_variables, 1 + + ! Correlation (in-precip) of ln hmx and ln hmy (two different + ! hydrometeors) in PDF component 1. + if (icorr_hmx_hmy_1_n(pdf2hydromet_idx(jvar),pdf2hydromet_idx(ivar))& + > 0 ) then + call stat_update_var_pt( & + icorr_hmx_hmy_1_n(pdf2hydromet_idx(jvar),pdf2hydromet_idx(ivar)), & + level, corr_array_1_n(jvar,ivar), stats_zt ) + endif + + ! Correlation (in-precip) of ln hmx and ln hmy (two different + ! hydrometeors) in PDF component 2. + if (icorr_hmx_hmy_2_n(pdf2hydromet_idx(jvar),pdf2hydromet_idx(ivar))& + > 0 ) then + call stat_update_var_pt( & + icorr_hmx_hmy_2_n(pdf2hydromet_idx(jvar),pdf2hydromet_idx(ivar)), & + level, corr_array_2_n(jvar,ivar), stats_zt ) + endif + + enddo ! jvar = ivar+1, d_variables, 1 + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + endif ! l_stats_samp + + + return + + end subroutine pdf_param_ln_hm_stats + + !============================================================================= + subroutine pack_pdf_params( hm1, hm2, d_variables, & ! In + mu_x_1, mu_x_2, sigma_x_1, sigma_x_2, & ! In + corr_array_1, corr_array_2, precip_frac, & ! In + precip_frac_1, precip_frac_2, & ! In + hydromet_pdf_params ) ! Out + + ! Description: + ! Pack the standard means and variances involving hydrometeors, as well as a + ! few other variables, into the structure hydromet_pdf_params. + + ! References: + !----------------------------------------------------------------------- + + use hydromet_pdf_parameter_module, only: & + hydromet_pdf_parameter ! Variable(s) + + use index_mapping, only: & + hydromet2pdf_idx ! Procedure(s) + + use parameters_model, only: & + hydromet_dim ! Variable(s) + + use corr_varnce_module, only: & + iiPDF_w, & ! Variable(s) + iiPDF_chi, & + iiPDF_eta, & + iiPDF_Ncn + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), dimension(hydromet_dim), intent(in) :: & + hm1, & ! Mean of a precip. hydrometeor (1st PDF component) [units vary] + hm2 ! Mean of a precip. hydrometeor (2nd PDF component) [units vary] + + integer, intent(in) :: & + d_variables ! Number of variables in the mean/stdev arrays + + real( kind = core_rknd ), dimension(d_variables), intent(in) :: & + mu_x_1, & ! Mean array of PDF vars. (1st PDF component) [units vary] + mu_x_2, & ! Mean array of PDF vars. (2nd PDF component) [units vary] + sigma_x_1, & ! Standard deviation array of PDF vars (comp. 1) [units vary] + sigma_x_2 ! Standard deviation array of PDF vars (comp. 2) [units vary] + + real( kind = core_rknd ), dimension(d_variables,d_variables), & + intent(in) :: & + corr_array_1, & ! Correlation array of PDF vars. (comp. 1) [-] + corr_array_2 ! Correlation array of PDF vars. (comp. 2) [-] + + real( kind = core_rknd ), intent(in) :: & + precip_frac, & ! Precipitation fraction (overall) [-] + precip_frac_1, & ! Precipitation fraction (1st PDF component) [-] + precip_frac_2 ! Precipitation fraction (2nd PDF component) [-] + + ! Output Variable + type(hydromet_pdf_parameter), intent(out) :: & + hydromet_pdf_params ! Hydrometeor PDF parameters [units vary] + + ! Local Variables + integer :: ivar ! Loop index + + + ! Pack remaining means and standard deviations into hydromet_pdf_params. + do ivar = 1, hydromet_dim, 1 + + ! Mean of a hydrometeor (overall) in the 1st PDF component. + hydromet_pdf_params%hm1(ivar) = hm1(ivar) + ! Mean of a hydrometeor (overall) in the 2nd PDF component. + hydromet_pdf_params%hm2(ivar) = hm2(ivar) + + ! Mean of a hydrometeor (in-precip) in the 1st PDF component. + hydromet_pdf_params%mu_hm_1(ivar) = mu_x_1(hydromet2pdf_idx(ivar)) + ! Mean of a hydrometeor (in-precip) in the 2nd PDF component. + hydromet_pdf_params%mu_hm_2(ivar) = mu_x_2(hydromet2pdf_idx(ivar)) + + ! Standard deviation of a hydrometeor (in-precip) in the + ! 1st PDF component. + hydromet_pdf_params%sigma_hm_1(ivar) = sigma_x_1(hydromet2pdf_idx(ivar)) + ! Standard deviation of a hydrometeor (in-precip) in the + ! 2nd PDF component. + hydromet_pdf_params%sigma_hm_2(ivar) = sigma_x_2(hydromet2pdf_idx(ivar)) + + ! Correlation (in-precip) of w and a hydrometeor in the 1st PDF + ! component. + hydromet_pdf_params%corr_w_hm_1(ivar) & + = corr_array_1( hydromet2pdf_idx(ivar), iiPDF_w ) + + ! Correlation (in-precip) of w and a hydrometeor in the 2nd PDF + ! component. + hydromet_pdf_params%corr_w_hm_2(ivar) & + = corr_array_2( hydromet2pdf_idx(ivar), iiPDF_w ) + + ! Correlation (in-precip) of chi and a hydrometeor in the 1st PDF + ! component. + hydromet_pdf_params%corr_chi_hm_1(ivar) & + = corr_array_1( hydromet2pdf_idx(ivar), iiPDF_chi ) + + ! Correlation (in-precip) of chi and a hydrometeor in the 2nd PDF + ! component. + hydromet_pdf_params%corr_chi_hm_2(ivar) & + = corr_array_2( hydromet2pdf_idx(ivar), iiPDF_chi ) + + ! Correlation (in-precip) of eta and a hydrometeor in the 1st PDF + ! component. + hydromet_pdf_params%corr_eta_hm_1(ivar) & + = corr_array_1( hydromet2pdf_idx(ivar), iiPDF_eta ) + + ! Correlation (in-precip) of eta and a hydrometeor in the 2nd PDF + ! component. + hydromet_pdf_params%corr_eta_hm_2(ivar) & + = corr_array_2( hydromet2pdf_idx(ivar), iiPDF_eta ) + + enddo ! ivar = 1, hydromet_dim, 1 + + ! Mean of Ncn (overall) in the 1st PDF component. + hydromet_pdf_params%mu_Ncn_1 = mu_x_1(iiPDF_Ncn) + ! Mean of Ncn (overall) in the 2nd PDF component. + hydromet_pdf_params%mu_Ncn_2 = mu_x_2(iiPDF_Ncn) + + ! Standard deviation of Ncn (overall) in the 1st PDF component. + hydromet_pdf_params%sigma_Ncn_1 = sigma_x_1(iiPDF_Ncn) + ! Standard deviation of Ncn (overall) in the 2nd PDF component. + hydromet_pdf_params%sigma_Ncn_2 = sigma_x_2(iiPDF_Ncn) + + ! Precipitation fraction (overall). + hydromet_pdf_params%precip_frac = precip_frac + ! Precipitation fraction (1st PDF component). + hydromet_pdf_params%precip_frac_1 = precip_frac_1 + ! Precipitation fraction (2nd PDF component). + hydromet_pdf_params%precip_frac_2 = precip_frac_2 + + + return + + end subroutine pack_pdf_params + + !============================================================================= + elemental function compute_rtp2_from_chi( pdf_params, corr_chi_eta_1, & + corr_chi_eta_2 ) & + result( rtp2_zt_from_chi ) + + ! Description: + ! Compute the variance of rt from the distribution of chi and eta. The + ! resulting variance will be consistent with CLUBB's extended PDF + ! involving chi and eta, including if l_fix_chi_eta_correlations = .true. . + + ! References: + ! None + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Constant + + use pdf_utilities, only: & + compute_variance_binormal ! Procedure + + use constants_clubb, only: & + one_half, & ! Constant(s) + one, & + two + + use pdf_parameter_module, only: & + pdf_parameter ! Type + + implicit none + + ! Input Variables + type(pdf_parameter), intent(in) :: & + pdf_params + + real( kind = core_rknd ), intent(in) :: & + corr_chi_eta_1, & ! Correlation of chi and eta in 1st PDF component [-] + corr_chi_eta_2 ! Correlation of chi and eta in 2nd PDF component [-] + + ! Output Variable + real( kind = core_rknd ) :: & + rtp2_zt_from_chi ! Grid-box variance of rtp2 on thermo. levels [kg/kg] + + ! Local Variables + real( kind = core_rknd ) :: & + varnce_rt_1_zt_from_chi, varnce_rt_2_zt_from_chi + + real( kind = core_rknd ) :: & + sigma_chi_1, & ! Standard deviation of chi (1st PDF comp.) [kg/kg] + sigma_chi_2, & ! Standard deviation of chi (2nd PDF comp.) [kg/kg] + sigma_eta_1, & ! Standard deviation of eta (1st PDF comp.) [kg/kg] + sigma_eta_2, & ! Standard deviation of eta (2nd PDF comp.) [kg/kg] + crt_1, & ! Coef. of r_t in chi/eta eqns. (1st comp.) [-] + crt_2, & ! Coef. of r_t in chi/eta eqns. (2nd comp.) [-] + rt_1, & ! Mean of rt (1st PDF component) [kg/kg] + rt_2, & ! Mean of rt (2nd PDF component) [kg/kg] + rtm, & ! Mean of rt (overall) [kg/kg] + sigma_rt_1_from_chi, & ! Standard deviation of rt (1st PDF comp.) [kg/kg] + sigma_rt_2_from_chi, & ! Standard deviation of rt (2nd PDF comp.) [kg/kg] + mixt_frac ! Weight of 1st gaussian PDF component [-] + + !----------------------------------------------------------------------- + + !----- Begin Code ----- + + ! Enter some PDF parameters + sigma_chi_1 = pdf_params%stdev_chi_1 + sigma_chi_2 = pdf_params%stdev_chi_2 + sigma_eta_1 = pdf_params%stdev_eta_1 + sigma_eta_2 = pdf_params%stdev_eta_2 + rt_1 = pdf_params%rt_1 + rt_2 = pdf_params%rt_2 + crt_1 = pdf_params%crt_1 + crt_2 = pdf_params%crt_2 + mixt_frac = pdf_params%mixt_frac + + varnce_rt_1_zt_from_chi & + = ( corr_chi_eta_1 * sigma_chi_1 * sigma_eta_1 & + + one_half * sigma_chi_1**2 + one_half * sigma_eta_1**2 ) & + / ( two * crt_1**2 ) + + varnce_rt_2_zt_from_chi & + = ( corr_chi_eta_2 * sigma_chi_2 * sigma_eta_2 & + + one_half * sigma_chi_2**2 + one_half * sigma_eta_2**2 ) & + / ( two * crt_2**2 ) + + rtm = mixt_frac*rt_1 + (one-mixt_frac)*rt_2 + + sigma_rt_1_from_chi = sqrt( varnce_rt_1_zt_from_chi ) + sigma_rt_2_from_chi = sqrt( varnce_rt_2_zt_from_chi ) + + rtp2_zt_from_chi & + = compute_variance_binormal( rtm, rt_1, rt_2, sigma_rt_1_from_chi, & + sigma_rt_2_from_chi, mixt_frac ) + + + return + + end function compute_rtp2_from_chi + +!=============================================================================== + +end module setup_clubb_pdf_params diff --git a/models/atm/cam/src/physics/clubb/sigma_sqd_w_module.F90 b/models/atm/cam/src/physics/clubb/sigma_sqd_w_module.F90 index 4c86686d9723..8f0987e2a7c8 100644 --- a/models/atm/cam/src/physics/clubb/sigma_sqd_w_module.F90 +++ b/models/atm/cam/src/physics/clubb/sigma_sqd_w_module.F90 @@ -1,4 +1,6 @@ -! $Id: sigma_sqd_w_module.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +!------------------------------------------------------------------------- +! $Id: sigma_sqd_w_module.F90 6849 2014-04-22 21:52:30Z charlass@uwm.edu $ +!=============================================================================== module sigma_sqd_w_module implicit none diff --git a/models/atm/cam/src/physics/clubb/sponge_layer_damping.F90 b/models/atm/cam/src/physics/clubb/sponge_layer_damping.F90 index 8f4e62e550d4..01f0b127a171 100644 --- a/models/atm/cam/src/physics/clubb/sponge_layer_damping.F90 +++ b/models/atm/cam/src/physics/clubb/sponge_layer_damping.F90 @@ -1,4 +1,6 @@ -!$Id: sponge_layer_damping.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +!------------------------------------------------------------------------- +!$Id: sponge_layer_damping.F90 7185 2014-08-11 17:45:21Z betlej@uwm.edu $ +!=============================================================================== module sponge_layer_damping ! Description: ! This module is used for damping variables in upper altitudes of the grid. @@ -42,14 +44,15 @@ module sponge_layer_damping thlm_sponge_damp_settings, & rtm_sponge_damp_settings, & uv_sponge_damp_settings + !$omp threadprivate(thlm_sponge_damp_settings, rtm_sponge_damp_settings, uv_sponge_damp_settings) type(sponge_damp_profile), public :: & thlm_sponge_damp_profile, & rtm_sponge_damp_profile, & uv_sponge_damp_profile -!$omp threadprivate(thlm_sponge_damp_profile, rtm_sponge_damp_profile, uv_sponge_damp_profile) +!$omp threadprivate(thlm_sponge_damp_profile, rtm_sponge_damp_profile, uv_sponge_damp_profile) private @@ -70,7 +73,7 @@ function sponge_damp_xm( dt, xm_ref, xm, damping_profile ) result( xm_p ) use grid_class, only: gr ! Variable(s) - use clubb_precision, only: time_precision, core_rknd ! Variable(s) + use clubb_precision, only: core_rknd ! Variable(s) implicit none @@ -78,7 +81,7 @@ function sponge_damp_xm( dt, xm_ref, xm, damping_profile ) result( xm_p ) intrinsic :: associated ! Input Variable(s) - real(kind=time_precision), intent(in) :: dt ! Model Timestep + real( kind = core_rknd ), intent(in) :: dt ! Model Timestep real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & xm_ref ! Reference to damp to [-] @@ -108,7 +111,7 @@ function sponge_damp_xm( dt, xm_ref, xm, damping_profile ) result( xm_p ) ! reduce noise in rtm in cloud_feedback_s12 (CGILS) ! xm_p(k) = xm(k) - real( ( ( xm(k) - xm_ref(k) ) / & ! damping_profile%tau_sponge_damp(k) ) * dt ) - dt_on_tau = real( dt, kind = core_rknd ) / damping_profile%tau_sponge_damp(k) + dt_on_tau = dt / damping_profile%tau_sponge_damp(k) ! Really, we should be using xm_ref at time n+1 rather than n. ! However, for steady profiles of xm_ref, it won't matter. @@ -135,18 +138,18 @@ subroutine initialize_tau_sponge_damp( dt, settings, damping_profile ) ! References: ! None !------------------------------------------------------------------------------------------- - use clubb_precision, only: time_precision, core_rknd ! Variable(s) + use clubb_precision, only: core_rknd ! Variable(s) use constants_clubb, only: fstderr ! Constant(s) use grid_class, only: gr ! Variable(s) - use interpolation, only: lin_int ! function + use interpolation, only: lin_interpolate_two_points ! function implicit none ! Input Variable(s) - real(kind=time_precision), intent(in) :: dt ! Model Timestep [s] + real( kind = core_rknd ), intent(in) :: dt ! Model Timestep [s] type(sponge_damp_settings), intent(in) :: & settings @@ -160,7 +163,7 @@ subroutine initialize_tau_sponge_damp( dt, settings, damping_profile ) allocate( damping_profile%tau_sponge_damp(1:gr%nz)) - if( settings%tau_sponge_damp_min < 2._core_rknd * real( dt, kind = core_rknd ) ) then + if( settings%tau_sponge_damp_min < 2._core_rknd * dt ) then write(fstderr,*) 'Error: in damping() tau_sponge_damp_min is too small!' stop end if @@ -178,7 +181,7 @@ subroutine initialize_tau_sponge_damp( dt, settings, damping_profile ) ! ( ( gr%zt(gr%nz)-gr%zt(k) ) / & ! (gr%zt(gr%nz) - gr%zt( gr%nz-damping_profile%n_sponge_damp ) ) ) damping_profile%tau_sponge_damp(k) = & - lin_int( gr%zt(k), gr%zt(gr%nz), & + lin_interpolate_two_points( gr%zt(k), gr%zt(gr%nz), & gr%zt(gr%nz) - gr%zt( gr%nz-damping_profile%n_sponge_damp ) , & settings%tau_sponge_damp_min, settings%tau_sponge_damp_max ) ! End Vince Larson's change diff --git a/models/atm/cam/src/physics/clubb/stat_file_module.F90 b/models/atm/cam/src/physics/clubb/stat_file_module.F90 index 2abde9d2fc00..f4324e51a03b 100644 --- a/models/atm/cam/src/physics/clubb/stat_file_module.F90 +++ b/models/atm/cam/src/physics/clubb/stat_file_module.F90 @@ -1,5 +1,6 @@ !------------------------------------------------------------------------------- -! $Id: stat_file_module.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +! $Id: stat_file_module.F90 7140 2014-07-31 19:14:05Z betlej@uwm.edu $ +!=============================================================================== module stat_file_module @@ -16,19 +17,29 @@ module stat_file_module public :: variable, stat_file + ! These are used in a 2D or 3D host model to output multiple columns + ! Set clubb_i and clubb_j according to the column within the host model; + ! The indices must not exceed nlon (for i) or nlat (for j). + integer, save, public :: clubb_i = 1, clubb_j = 1 +!$omp threadprivate(clubb_i, clubb_j) + private ! Default scope - + ! Structure to hold the description of a variable type variable ! Pointer to the array - real(kind=stat_rknd), dimension(:,:,:), pointer :: ptr + real(kind=stat_rknd), dimension(:,:,:), pointer :: ptr character(len = 30) :: name ! Variable name character(len = 100) :: description ! Variable description character(len = 20) :: units ! Variable units integer :: indx ! NetCDF module Id for var / GrADS index + + logical :: l_silhs ! If true, we sample this variable once for each SILHS + ! sample point per timestep, rather than just once per + ! timestep. end type variable ! Structure to hold the description of a NetCDF output file @@ -39,12 +50,12 @@ module stat_file_module ! File information - character(len = 200) :: & + character(len = 200) :: & fname, & ! File name without suffix fdir ! Path where fname resides - integer :: iounit ! This number is used internally by the - ! NetCDF module to track the data set, or by + integer :: iounit ! This number is used internally by the + ! NetCDF module to track the data set, or by ! GrADS to track the actual file unit. integer :: & nrecord, & ! Number of records written @@ -76,10 +87,10 @@ module stat_file_module rlat, & ! Latitude [Degrees N] rlon ! Longitude [Degrees E] - real(kind=time_precision) :: & + real( kind = core_rknd ) :: & dtwrite ! Interval between output [Seconds] - real(kind=time_precision) :: & + real( kind = time_precision ) :: & time ! Start time [Seconds] ! Statistical Variables diff --git a/models/atm/cam/src/physics/clubb/stats_clubb_utilities.F90 b/models/atm/cam/src/physics/clubb/stats_clubb_utilities.F90 new file mode 100644 index 000000000000..5e20835992d1 --- /dev/null +++ b/models/atm/cam/src/physics/clubb/stats_clubb_utilities.F90 @@ -0,0 +1,2944 @@ +!----------------------------------------------------------------------- +! $Id: stats_clubb_utilities.F90 7377 2014-11-11 02:43:45Z bmg2@uwm.edu $ +!=============================================================================== +module stats_clubb_utilities + + implicit none + + private ! Set Default Scope + + public :: stats_init, stats_begin_timestep, stats_end_timestep, & + stats_accumulate, stats_finalize, stats_accumulate_hydromet, & + stats_accumulate_lh_tend + + private :: stats_zero, stats_avg, stats_check_num_samples + + contains + + !----------------------------------------------------------------------- + subroutine stats_init( iunit, fname_prefix, fdir, l_stats_in, & + stats_fmt_in, stats_tsamp_in, stats_tout_in, fnamelist, & + nzmax, nlon, nlat, gzt, gzm, nnrad_zt, & + grad_zt, nnrad_zm, grad_zm, day, month, year, & + rlon, rlat, time_current, delt, l_silhs_out_in ) + ! + ! Description: + ! Initializes the statistics saving functionality of the CLUBB model. + ! + ! References: + ! None + !----------------------------------------------------------------------- + + use stats_variables, only: & + stats_zt, & ! Variables + ztscr01, & + ztscr02, & + ztscr03, & + ztscr04, & + ztscr05, & + ztscr06, & + ztscr07, & + ztscr08, & + ztscr09, & + ztscr10, & + ztscr11, & + ztscr12, & + ztscr13, & + ztscr14, & + ztscr15, & + ztscr16, & + ztscr17, & + ztscr18, & + ztscr19, & + ztscr20, & + ztscr21 + + use stats_variables, only: & + l_silhs_out, & ! Variable(s) + stats_lh_zt, & + stats_lh_sfc + + use stats_variables, only: & + stats_zm, & ! Variables + zmscr01, & + zmscr02, & + zmscr03, & + zmscr04, & + zmscr05, & + zmscr06, & + zmscr07, & + zmscr08, & + zmscr09, & + zmscr10, & + zmscr11, & + zmscr12, & + zmscr13, & + zmscr14, & + zmscr15, & + zmscr16, & + zmscr17, & + stats_rad_zt + + use stats_variables, only: & + stats_rad_zm, & + stats_sfc, & + l_stats, & + l_output_rad_files, & + stats_tsamp, & + stats_tout, & + l_stats_samp, & + l_stats_last, & + fname_zt, & + fname_lh_zt, & + fname_lh_sfc, & + fname_zm, & + fname_rad_zt, & + fname_rad_zm, & + fname_sfc, & + l_netcdf, & + l_grads + + use clubb_precision, only: & + time_precision, & ! Constant(s) + core_rknd + + use output_grads, only: & + open_grads ! Procedure + +#ifdef NETCDF + use output_netcdf, only: & + open_netcdf ! Procedure +#endif + + use stats_zm_module, only: & + nvarmax_zm, & ! Constant(s) + stats_init_zm ! Procedure(s) + + use stats_zt_module, only: & + nvarmax_zt, & ! Constant(s) + stats_init_zt ! Procedure(s) + + use stats_lh_zt_module, only: & + nvarmax_lh_zt, & ! Constant(s) + stats_init_lh_zt ! Procedure(s) + + use stats_lh_sfc_module, only: & + nvarmax_lh_sfc, & ! Constant(s) + stats_init_lh_sfc ! Procedure(s) + + use stats_rad_zt_module, only: & + nvarmax_rad_zt, & ! Constant(s) + stats_init_rad_zt ! Procedure(s) + + use stats_rad_zm_module, only: & + nvarmax_rad_zm, & ! Constant(s) + stats_init_rad_zm ! Procedure(s) + + use stats_sfc_module, only: & + nvarmax_sfc, & ! Constant(s) + stats_init_sfc ! Procedure(s) + + use error_code, only: & + clubb_at_least_debug_level ! Function + + use constants_clubb, only: & + fstdout, fstderr, var_length ! Constants + + use parameters_model, only: & + hydromet_dim ! Variable(s) + + implicit none + + ! Input Variables + integer, intent(in) :: iunit ! File unit for fnamelist + + character(len=*), intent(in) :: & + fname_prefix, & ! Start of the stats filenames + fdir ! Directory to output to + + logical, intent(in) :: & + l_stats_in ! Stats on? T/F + + character(len=*), intent(in) :: & + stats_fmt_in ! Format of the stats file output + + real( kind = core_rknd ), intent(in) :: & + stats_tsamp_in, & ! Sampling interval [s] + stats_tout_in ! Output interval [s] + + character(len=*), intent(in) :: & + fnamelist ! Filename holding the &statsnl + + integer, intent(in) :: & + nlon, & ! Number of points in the X direction [-] + nlat, & ! Number of points in the Y direction [-] + nzmax ! Grid points in the vertical [-] + + real( kind = core_rknd ), intent(in), dimension(nzmax) :: & + gzt, gzm ! Thermodynamic and momentum levels [m] + + integer, intent(in) :: nnrad_zt ! Grid points in the radiation grid [count] + + real( kind = core_rknd ), intent(in), dimension(nnrad_zt) :: grad_zt ! Radiation levels [m] + + integer, intent(in) :: nnrad_zm ! Grid points in the radiation grid [count] + + real( kind = core_rknd ), intent(in), dimension(nnrad_zm) :: grad_zm ! Radiation levels [m] + + integer, intent(in) :: day, month, year ! Time of year + + real( kind = core_rknd ), dimension(nlon), intent(in) :: & + rlon ! Longitude(s) [Degrees E] + + real( kind = core_rknd ), dimension(nlat), intent(in) :: & + rlat ! Latitude(s) [Degrees N] + + real( kind = time_precision ), intent(in) :: & + time_current ! Model time [s] + + real( kind = core_rknd ), intent(in) :: & + delt ! Timestep (dt_main in CLUBB) [s] + + logical, intent(in) :: & + l_silhs_out_in ! Whether to output SILHS files (stats_lh_zt, stats_lh_sfc) [boolean] + + ! Local Variables + logical :: l_error + + character(len=200) :: fname + + integer :: ivar, ntot, read_status + + ! Namelist Variables + + character(len=10) :: stats_fmt ! File storage convention + + character(len=var_length), dimension(nvarmax_zt) :: & + vars_zt ! Variables on the thermodynamic levels + + character(len=var_length), dimension(nvarmax_lh_zt) :: & + vars_lh_zt ! Latin Hypercube variables on the thermodynamic levels + + character(len=var_length), dimension(nvarmax_lh_sfc) :: & + vars_lh_sfc ! Latin Hypercube variables at the surface + + character(len=var_length), dimension(nvarmax_zm) :: & + vars_zm ! Variables on the momentum levels + + character(len=var_length), dimension(nvarmax_rad_zt) :: & + vars_rad_zt ! Variables on the radiation levels + + character(len=var_length), dimension(nvarmax_rad_zm) :: & + vars_rad_zm ! Variables on the radiation levels + + character(len=var_length), dimension(nvarmax_sfc) :: & + vars_sfc ! Variables at the model surface + + namelist /statsnl/ & + vars_zt, & + vars_zm, & + vars_lh_zt, & + vars_lh_sfc, & + vars_rad_zt, & + vars_rad_zm, & + vars_sfc + + ! ---- Begin Code ---- + + ! Initialize + l_error = .false. + + ! Set stats_variables variables with inputs from calling subroutine + l_stats = l_stats_in + + stats_tsamp = stats_tsamp_in + stats_tsamp = stats_tsamp_in + stats_tout = stats_tout_in + stats_fmt = trim( stats_fmt_in ) + l_silhs_out = l_silhs_out_in + + if ( .not. l_stats ) then + l_stats_samp = .false. + l_stats_last = .false. + return + end if + + ! Initialize namelist variables + + vars_zt = '' + vars_zm = '' + vars_lh_zt = '' + vars_lh_sfc = '' + vars_rad_zt = '' + vars_rad_zm = '' + vars_sfc = '' + + ! Reads list of variables that should be output to GrADS/NetCDF (namelist &statsnl) + + open(unit=iunit, file=fnamelist) + read(unit=iunit, nml=statsnl, iostat=read_status, end=100) + if ( read_status /= 0 ) then + if ( read_status > 0 ) then + write(fstderr,*) "Error reading stats namelist in file ", & + trim( fnamelist ) + else ! Read status < 0 + write(fstderr,*) "End of file marker reached while reading stats namelist in file ", & + trim( fnamelist ) + end if + write(fstderr,*) "One cause is having more statistical variables ", & + "listed in the namelist for var_zt, var_zm, or ", & + "var_sfc than allowed by nvarmax_zt, nvarmax_zm, ", & + "or nvarmax_sfc, respectively." + write(fstderr,*) "Maximum variables allowed for var_zt = ", nvarmax_zt + write(fstderr,*) "Maximum variables allowed for var_zm = ", nvarmax_zm + write(fstderr,*) "Maximum variables allowed for var_rad_zt = ", nvarmax_rad_zt + write(fstderr,*) "Maximum variables allowed for var_rad_zm = ", nvarmax_rad_zm + write(fstderr,*) "Maximum variables allowed for var_sfc = ", nvarmax_sfc + stop "stats_init: Error reading stats namelist." + end if ! read_status /= 0 + + close(unit=iunit) + + if ( clubb_at_least_debug_level( 1 ) ) then + write(fstdout,*) "--------------------------------------------------" + + write(fstdout,*) "Statistics" + + write(fstdout,*) "--------------------------------------------------" + write(fstdout,*) "vars_zt = " + ivar = 1 + do while ( vars_zt(ivar) /= '' ) + write(fstdout,*) vars_zt(ivar) + ivar = ivar + 1 + end do + + write(fstdout,*) "vars_zm = " + ivar = 1 + do while ( vars_zm(ivar) /= '' ) + write(fstdout,*) vars_zm(ivar) + ivar = ivar + 1 + end do + + if ( l_silhs_out ) then + write(fstdout,*) "vars_lh_zt = " + ivar = 1 + do while ( vars_lh_zt(ivar) /= '' ) + write(fstdout,*) vars_lh_zt(ivar) + ivar = ivar + 1 + end do + + write(fstdout,*) "vars_lh_sfc = " + ivar = 1 + do while ( vars_lh_sfc(ivar) /= '' ) + write(fstdout,*) vars_lh_sfc(ivar) + ivar = ivar + 1 + end do + end if ! l_silhs_out + + if ( l_output_rad_files ) then + write(fstdout,*) "vars_rad_zt = " + ivar = 1 + do while ( vars_rad_zt(ivar) /= '' ) + write(fstdout,*) vars_rad_zt(ivar) + ivar = ivar + 1 + end do + + write(fstdout,*) "vars_rad_zm = " + ivar = 1 + do while ( vars_rad_zm(ivar) /= '' ) + write(fstdout,*) vars_rad_zm(ivar) + ivar = ivar + 1 + end do + end if ! l_output_rad_files + + write(fstdout,*) "vars_sfc = " + ivar = 1 + do while ( vars_sfc(ivar) /= '' ) + write(fstdout,*) vars_sfc(ivar) + ivar = ivar + 1 + end do + + write(fstdout,*) "--------------------------------------------------" + end if ! clubb_at_least_debug_level 1 + + ! Determine file names for GrADS or NetCDF files + fname_zt = trim( fname_prefix )//"_zt" + fname_zm = trim( fname_prefix )//"_zm" + fname_lh_zt = trim( fname_prefix )//"_lh_zt" + fname_lh_sfc = trim( fname_prefix )//"_lh_sfc" + fname_rad_zt = trim( fname_prefix )//"_rad_zt" + fname_rad_zm = trim( fname_prefix )//"_rad_zm" + fname_sfc = trim( fname_prefix )//"_sfc" + + ! Parse the file type for stats output. Currently only GrADS and + ! netCDF > version 3.5 are supported by this code. + select case ( trim( stats_fmt ) ) + case ( "GrADS", "grads", "gr" ) + l_netcdf = .false. + l_grads = .true. + + case ( "NetCDF", "netcdf", "nc" ) + l_netcdf = .true. + l_grads = .false. + + case default + write(fstderr,*) "In module stats_clubb_utilities subroutine stats_init: " + write(fstderr,*) "Invalid stats output format "//trim( stats_fmt ) + stop "Fatal error" + + end select + + ! Check sampling and output frequencies + + ! The model time step length, delt (which is dt_main), should multiply + ! evenly into the statistical sampling time step length, stats_tsamp. + if ( abs( stats_tsamp/delt - real( floor( stats_tsamp/delt ), kind=core_rknd ) ) & + > 1.e-8_core_rknd) then + l_error = .true. ! This will cause the run to stop. + write(fstderr,*) 'Error: stats_tsamp should be an even multiple of ', & + 'delt (which is dt_main). Check the appropriate ', & + 'model.in file.' + write(fstderr,*) 'stats_tsamp = ', stats_tsamp + write(fstderr,*) 'delt = ', delt + end if + + ! The statistical sampling time step length, stats_tsamp, should multiply + ! evenly into the statistical output time step length, stats_tout. + if ( abs( stats_tout/stats_tsamp & + - real( floor( stats_tout/stats_tsamp ), kind=core_rknd) ) & + > 1.e-8_core_rknd) then + l_error = .true. ! This will cause the run to stop. + write(fstderr,*) 'Error: stats_tout should be an even multiple of ', & + 'stats_tsamp. Check the appropriate model.in file.' + write(fstderr,*) 'stats_tout = ', stats_tout + write(fstderr,*) 'stats_tsamp = ', stats_tsamp + end if + + ! Initialize zt (mass points) + + ivar = 1 + do while ( ichar(vars_zt(ivar)(1:1)) /= 0 & + .and. len_trim(vars_zt(ivar)) /= 0 & + .and. ivar <= nvarmax_zt ) + ivar = ivar + 1 + end do + ntot = ivar - 1 + + if ( any( vars_zt == "corr_w_hm_ov_adj" ) ) then + ! Correct for number of variables found under "corr_w_hm_ov_adj". + ! Subtract "corr_w_hm_ov_adj" from the number of zt statistical + ! variables. + ntot = ntot - 1 + ! Add 1 for each hydrometeor to the number of zt statistical variables. + ntot = ntot + hydromet_dim + endif + if ( any( vars_zt == "hmi" ) ) then + ! Correct for number of variables found under "hmi". + ! Subtract "hmi" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) for each hydrometeor + ! to the number of zt statistical variables. + ntot = ntot + 2 * hydromet_dim + endif + if ( any( vars_zt == "mu_hm_i" ) ) then + ! Correct for number of variables found under "mu_hm_i". + ! Subtract "mu_hm_i" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) for each hydrometeor + ! to the number of zt statistical variables. + ntot = ntot + 2 * hydromet_dim + endif + if ( any( vars_zt == "mu_Ncn_i" ) ) then + ! Correct for number of variables found under "mu_Ncn_i". + ! Subtract "mu_Ncn_i" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) to the number of zt + ! statistical variables. + ntot = ntot + 2 + endif + if ( any( vars_zt == "mu_hm_i_n" ) ) then + ! Correct for number of variables found under "mu_hm_i_n". + ! Subtract "mu_hm_i_n" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) for each hydrometeor + ! to the number of zt statistical variables. + ntot = ntot + 2 * hydromet_dim + endif + if ( any( vars_zt == "mu_Ncn_i_n" ) ) then + ! Correct for number of variables found under "mu_Ncn_i_n". + ! Subtract "mu_Ncn_i_n" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) to the number of zt + ! statistical variables. + ntot = ntot + 2 + endif + if ( any( vars_zt == "sigma_hm_i" ) ) then + ! Correct for number of variables found under "sigma_hm_i". + ! Subtract "sigma_hm_i" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) for each hydrometeor + ! to the number of zt statistical variables. + ntot = ntot + 2 * hydromet_dim + endif + if ( any( vars_zt == "sigma_Ncn_i" ) ) then + ! Correct for number of variables found under "sigma_Ncn_i". + ! Subtract "sigma_Ncn_i" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) to the number of zt + ! statistical variables. + ntot = ntot + 2 + endif + if ( any( vars_zt == "sigma_hm_i_n" ) ) then + ! Correct for number of variables found under "sigma_hm_i_n". + ! Subtract "sigma_hm_i_n" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) for each hydrometeor + ! to the number of zt statistical variables. + ntot = ntot + 2 * hydromet_dim + endif + if ( any( vars_zt == "sigma_Ncn_i_n" ) ) then + ! Correct for number of variables found under "sigma_Ncn_i_n". + ! Subtract "sigma_Ncn_i_n" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) to the number of zt + ! statistical variables. + ntot = ntot + 2 + endif + + if ( any( vars_zt == "corr_w_hm_i" ) ) then + ! Correct for number of variables found under "corr_w_hm_i". + ! Subtract "corr_w_hm_i" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) for each hydrometeor + ! to the number of zt statistical variables. + ntot = ntot + 2 * hydromet_dim + endif + if ( any( vars_zt == "corr_w_Ncn_i" ) ) then + ! Correct for number of variables found under "corr_w_Ncn_i". + ! Subtract "corr_w_Ncn_i" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) to the number of zt + ! statistical variables. + ntot = ntot + 2 + endif + if ( any( vars_zt == "corr_chi_hm_i" ) ) then + ! Correct for number of variables found under "corr_chi_hm_i". + ! Subtract "corr_chi_hm_i" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) for each hydrometeor + ! to the number of zt statistical variables. + ntot = ntot + 2 * hydromet_dim + endif + if ( any( vars_zt == "corr_chi_Ncn_i" ) ) then + ! Correct for number of variables found under "corr_chi_Ncn_i". + ! Subtract "corr_chi_Ncn_i" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) to the number of zt + ! statistical variables. + ntot = ntot + 2 + endif + if ( any( vars_zt == "corr_eta_hm_i" ) ) then + ! Correct for number of variables found under "corr_eta_hm_i". + ! Subtract "corr_eta_hm_i" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) for each hydrometeor + ! to the number of zt statistical variables. + ntot = ntot + 2 * hydromet_dim + endif + if ( any( vars_zt == "corr_eta_Ncn_i" ) ) then + ! Correct for number of variables found under "corr_eta_Ncn_i". + ! Subtract "corr_eta_Ncn_i" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) to the number of zt + ! statistical variables. + ntot = ntot + 2 + endif + if ( any( vars_zt == "corr_Ncn_hm_i" ) ) then + ! Correct for number of variables found under "corr_Ncn_hm_i". + ! Subtract "corr_Ncn_hm_i" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) for each hydrometeor + ! to the number of zt statistical variables. + ntot = ntot + 2 * hydromet_dim + endif + if ( any( vars_zt == "corr_hmx_hmy_i" ) ) then + ! Correct for number of variables found under "corr_hmx_hmy_i". + ! Subtract "corr_hmx_hmy_i" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) multipled by the + ! number of correlations between two hydrometeors, which is found by: + ! (1/2) * hydromet_dim * ( hydromet_dim - 1 ); + ! to the number of zt statistical variables. + ntot = ntot + hydromet_dim * ( hydromet_dim - 1 ) + endif + + if ( any( vars_zt == "corr_w_hm_i_n" ) ) then + ! Correct for number of variables found under "corr_w_hm_i_n". + ! Subtract "corr_w_hm_i_n" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) for each hydrometeor + ! to the number of zt statistical variables. + ntot = ntot + 2 * hydromet_dim + endif + if ( any( vars_zt == "corr_w_Ncn_i_n" ) ) then + ! Correct for number of variables found under "corr_w_Ncn_i_n". + ! Subtract "corr_w_Ncn_i_n" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) to the number of zt + ! statistical variables. + ntot = ntot + 2 + endif + if ( any( vars_zt == "corr_chi_hm_i_n" ) ) then + ! Correct for number of variables found under "corr_chi_hm_i_n". + ! Subtract "corr_chi_hm_i_n" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) for each hydrometeor + ! to the number of zt statistical variables. + ntot = ntot + 2 * hydromet_dim + endif + if ( any( vars_zt == "corr_chi_Ncn_i_n" ) ) then + ! Correct for number of variables found under "corr_chi_Ncn_i_n". + ! Subtract "corr_chi_Ncn_i_n" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) to the number of zt + ! statistical variables. + ntot = ntot + 2 + endif + if ( any( vars_zt == "corr_eta_hm_i_n" ) ) then + ! Correct for number of variables found under "corr_eta_hm_i_n". + ! Subtract "corr_eta_hm_i_n" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) for each hydrometeor + ! to the number of zt statistical variables. + ntot = ntot + 2 * hydromet_dim + endif + if ( any( vars_zt == "corr_eta_Ncn_i_n" ) ) then + ! Correct for number of variables found under "corr_eta_Ncn_i_n". + ! Subtract "corr_eta_Ncn_i_n" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) to the number of zt + ! statistical variables. + ntot = ntot + 2 + endif + if ( any( vars_zt == "corr_Ncn_hm_i_n" ) ) then + ! Correct for number of variables found under "corr_Ncn_hm_i_n". + ! Subtract "corr_Ncn_hm_i_n" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) for each hydrometeor + ! to the number of zt statistical variables. + ntot = ntot + 2 * hydromet_dim + endif + if ( any( vars_zt == "corr_hmx_hmy_i_n" ) ) then + ! Correct for number of variables found under "corr_hmx_hmy_i_n". + ! Subtract "corr_hmx_hmy_i_n" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) multipled by the + ! number of normalized correlations between two hydrometeors, which is + ! found by: (1/2) * hydromet_dim * ( hydromet_dim - 1 ); + ! to the number of zt statistical variables. + ntot = ntot + hydromet_dim * ( hydromet_dim - 1 ) + endif + + if ( any( vars_zt == "hmp2_zt" ) ) then + ! Correct for number of variables found under "hmp2_zt". + ! Subtract "hmp2_zt" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 1 for each hydrometeor to the number of zt statistical variables. + ntot = ntot + hydromet_dim + endif + + if ( any( vars_zt == "wp2hmp" ) ) then + ! Correct for number of variables found under "wp2hmp". + ! Subtract "wp2hmp" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 1 for each hydrometeor to the number of zt statistical variables. + ntot = ntot + hydromet_dim + endif + + if ( ntot >= nvarmax_zt ) then + write(fstderr,*) "There are more statistical variables listed in ", & + "vars_zt than allowed for by nvarmax_zt." + write(fstderr,*) "Check the number of variables listed for vars_zt ", & + "in the stats namelist, or change nvarmax_zt." + write(fstderr,*) "nvarmax_zt = ", nvarmax_zt + stop "stats_init: number of zt statistical variables exceeds limit" + end if + + stats_zt%num_output_fields = ntot + stats_zt%kk = nzmax + stats_zt%ii = nlon + stats_zt%jj = nlat + + allocate( stats_zt%z( stats_zt%kk ) ) + stats_zt%z = gzt + + allocate( stats_zt%accum_field_values( stats_zt%ii, stats_zt%jj, & + stats_zt%kk, stats_zt%num_output_fields ) ) + allocate( stats_zt %accum_num_samples( stats_zt%ii, stats_zt%jj, & + stats_zt%kk, stats_zt%num_output_fields ) ) + allocate( stats_zt%l_in_update( stats_zt%ii, stats_zt%jj, stats_zt%kk, & + stats_zt%num_output_fields ) ) + call stats_zero( stats_zt%ii, stats_zt%jj, stats_zt%kk, stats_zt%num_output_fields, & + stats_zt%accum_field_values, stats_zt%accum_num_samples, stats_zt%l_in_update ) + + allocate( stats_zt%file%var( stats_zt%num_output_fields ) ) + allocate( stats_zt%file%z( stats_zt%kk ) ) + + ! Allocate scratch space + + allocate( ztscr01(stats_zt%kk) ) + allocate( ztscr02(stats_zt%kk) ) + allocate( ztscr03(stats_zt%kk) ) + allocate( ztscr04(stats_zt%kk) ) + allocate( ztscr05(stats_zt%kk) ) + allocate( ztscr06(stats_zt%kk) ) + allocate( ztscr07(stats_zt%kk) ) + allocate( ztscr08(stats_zt%kk) ) + allocate( ztscr09(stats_zt%kk) ) + allocate( ztscr10(stats_zt%kk) ) + allocate( ztscr11(stats_zt%kk) ) + allocate( ztscr12(stats_zt%kk) ) + allocate( ztscr13(stats_zt%kk) ) + allocate( ztscr14(stats_zt%kk) ) + allocate( ztscr15(stats_zt%kk) ) + allocate( ztscr16(stats_zt%kk) ) + allocate( ztscr17(stats_zt%kk) ) + allocate( ztscr18(stats_zt%kk) ) + allocate( ztscr19(stats_zt%kk) ) + allocate( ztscr20(stats_zt%kk) ) + allocate( ztscr21(stats_zt%kk) ) + + ztscr01 = 0.0_core_rknd + ztscr02 = 0.0_core_rknd + ztscr03 = 0.0_core_rknd + ztscr04 = 0.0_core_rknd + ztscr05 = 0.0_core_rknd + ztscr06 = 0.0_core_rknd + ztscr07 = 0.0_core_rknd + ztscr08 = 0.0_core_rknd + ztscr09 = 0.0_core_rknd + ztscr10 = 0.0_core_rknd + ztscr11 = 0.0_core_rknd + ztscr12 = 0.0_core_rknd + ztscr13 = 0.0_core_rknd + ztscr14 = 0.0_core_rknd + ztscr15 = 0.0_core_rknd + ztscr16 = 0.0_core_rknd + ztscr17 = 0.0_core_rknd + ztscr18 = 0.0_core_rknd + ztscr19 = 0.0_core_rknd + ztscr20 = 0.0_core_rknd + ztscr21 = 0.0_core_rknd + + fname = trim( fname_zt ) + + if ( l_grads ) then + + ! Open GrADS file + call open_grads( iunit, fdir, fname, & + 1, stats_zt%kk, nlat, nlon, stats_zt%z, & + day, month, year, rlat, rlon, & + time_current+real(stats_tout,kind=time_precision), stats_tout, & + stats_zt%num_output_fields, stats_zt%file ) + + else ! Open NetCDF file +#ifdef NETCDF + call open_netcdf( nlat, nlon, fdir, fname, 1, stats_zt%kk, stats_zt%z, & ! In + day, month, year, rlat, rlon, & ! In + time_current, stats_tout, stats_zt%num_output_fields, & ! In + stats_zt%file ) ! InOut +#else + stop "This CLUBB program was not compiled with netCDF support." +#endif + + end if + + ! Default initialization for array indices for zt + + call stats_init_zt( vars_zt, l_error ) + + + ! Setup output file for stats_lh_zt (Latin Hypercube stats) + + if ( l_silhs_out ) then + + ivar = 1 + do while ( ichar(vars_lh_zt(ivar)(1:1)) /= 0 & + .and. len_trim(vars_lh_zt(ivar)) /= 0 & + .and. ivar <= nvarmax_lh_zt ) + ivar = ivar + 1 + end do + ntot = ivar - 1 + if ( ntot == nvarmax_lh_zt ) then + write(fstderr,*) "There are more statistical variables listed in ", & + "vars_zt than allowed for by nvarmax_lh_zt." + write(fstderr,*) "Check the number of variables listed for vars_lh_zt ", & + "in the stats namelist, or change nvarmax_lh_zt." + write(fstderr,*) "nvarmax_lh_zt = ", nvarmax_lh_zt + stop "stats_init: number of lh_zt statistical variables exceeds limit" + end if + + stats_lh_zt%num_output_fields = ntot + stats_lh_zt%kk = nzmax + stats_lh_zt%ii = nlon + stats_lh_zt%jj = nlat + + allocate( stats_lh_zt%z( stats_lh_zt%kk ) ) + stats_lh_zt%z = gzt + + allocate( stats_lh_zt%accum_field_values( stats_lh_zt%ii, stats_lh_zt%jj, & + stats_lh_zt%kk, stats_lh_zt%num_output_fields ) ) + allocate( stats_lh_zt%accum_num_samples( stats_lh_zt%ii, stats_lh_zt%jj, & + stats_lh_zt%kk, stats_lh_zt%num_output_fields ) ) + allocate( stats_lh_zt%l_in_update( stats_lh_zt%ii, stats_lh_zt%jj, stats_lh_zt%kk, & + stats_lh_zt%num_output_fields ) ) + call stats_zero( stats_lh_zt%ii, stats_lh_zt%jj, stats_lh_zt%kk, & + stats_lh_zt%num_output_fields, & + stats_lh_zt%accum_field_values, stats_lh_zt %accum_num_samples, stats_lh_zt%l_in_update ) + + allocate( stats_lh_zt%file%var( stats_lh_zt%num_output_fields ) ) + allocate( stats_lh_zt%file%z( stats_lh_zt%kk ) ) + + + fname = trim( fname_lh_zt ) + + if ( l_grads ) then + + ! Open GrADS file + call open_grads( iunit, fdir, fname, & + 1, stats_lh_zt%kk, nlat, nlon, stats_lh_zt%z, & + day, month, year, rlat, rlon, & + time_current+real(stats_tout,kind=time_precision), stats_tout, & + stats_lh_zt%num_output_fields, stats_lh_zt%file ) + + else ! Open NetCDF file +#ifdef NETCDF + call open_netcdf( nlat, nlon, fdir, fname, 1, stats_lh_zt%kk, stats_lh_zt%z, & ! In + day, month, year, rlat, rlon, & ! In + time_current, stats_tout, stats_lh_zt%num_output_fields, & ! In + stats_lh_zt%file ) ! InOut +#else + stop "This CLUBB program was not compiled with netCDF support." +#endif + + end if + + call stats_init_lh_zt( vars_lh_zt, l_error ) + + ivar = 1 + do while ( ichar(vars_lh_sfc(ivar)(1:1)) /= 0 & + .and. len_trim(vars_lh_sfc(ivar)) /= 0 & + .and. ivar <= nvarmax_lh_sfc ) + ivar = ivar + 1 + end do + ntot = ivar - 1 + if ( ntot == nvarmax_lh_sfc ) then + write(fstderr,*) "There are more statistical variables listed in ", & + "vars_zt than allowed for by nvarmax_lh_sfc." + write(fstderr,*) "Check the number of variables listed for vars_lh_sfc ", & + "in the stats namelist, or change nvarmax_lh_sfc." + write(fstderr,*) "nvarmax_lh_sfc = ", nvarmax_lh_sfc + stop "stats_init: number of lh_sfc statistical variables exceeds limit" + end if + + stats_lh_sfc%num_output_fields = ntot + stats_lh_sfc%kk = 1 + stats_lh_sfc%ii = nlon + stats_lh_sfc%jj = nlat + + allocate( stats_lh_sfc%z( stats_lh_sfc%kk ) ) + stats_lh_sfc%z = gzm(1) + + allocate( stats_lh_sfc%accum_field_values( stats_lh_sfc%ii, stats_lh_sfc%jj, & + stats_lh_sfc%kk, stats_lh_sfc%num_output_fields ) ) + allocate( stats_lh_sfc %accum_num_samples( stats_lh_sfc%ii, stats_lh_sfc%jj, & + stats_lh_sfc%kk, stats_lh_sfc%num_output_fields ) ) + allocate( stats_lh_sfc%l_in_update( stats_lh_sfc%ii, stats_lh_sfc%jj, & + stats_lh_sfc%kk, stats_lh_sfc%num_output_fields ) ) + + call stats_zero( stats_lh_sfc%ii, stats_lh_sfc%jj, stats_lh_sfc%kk, & + stats_lh_sfc%num_output_fields, stats_lh_sfc%accum_field_values, & + stats_lh_sfc %accum_num_samples, stats_lh_sfc%l_in_update ) + + allocate( stats_lh_sfc%file%var( stats_lh_sfc%num_output_fields ) ) + allocate( stats_lh_sfc%file%z( stats_lh_sfc%kk ) ) + + fname = trim( fname_lh_sfc ) + + if ( l_grads ) then + + ! Open GrADS file + call open_grads( iunit, fdir, fname, & + 1, stats_lh_sfc%kk, nlat, nlon, stats_lh_sfc%z, & + day, month, year, rlat, rlon, & + time_current+real(stats_tout,kind=time_precision), stats_tout, & + stats_lh_sfc%num_output_fields, stats_lh_sfc%file ) + + else ! Open NetCDF file +#ifdef NETCDF + call open_netcdf( nlat, nlon, fdir, fname, 1, stats_lh_sfc%kk, stats_lh_sfc%z, & ! In + day, month, year, rlat, rlon, & ! In + time_current, stats_tout, stats_lh_sfc%num_output_fields, & ! In + stats_lh_sfc%file ) ! InOut +#else + stop "This CLUBB program was not compiled with netCDF support." +#endif + + end if + + call stats_init_lh_sfc( vars_lh_sfc, l_error ) + + end if ! l_silhs_out + + ! Initialize stats_zm (momentum points) + + ivar = 1 + do while ( ichar(vars_zm(ivar)(1:1)) /= 0 & + .and. len_trim(vars_zm(ivar)) /= 0 & + .and. ivar <= nvarmax_zm ) + ivar = ivar + 1 + end do + ntot = ivar - 1 + + if ( any( vars_zm == "hydrometp2" ) ) then + ! Correct for number of variables found under "hydrometp2". + ! Subtract "hydrometp2" from the number of zm statistical variables. + ntot = ntot - 1 + ! Add 1 for each hydrometeor to the number of zm statistical variables. + ntot = ntot + hydromet_dim + endif + + if ( any( vars_zm == "wphydrometp" ) ) then + ! Correct for number of variables found under "wphydrometp". + ! Subtract "wphydrometp" from the number of zm statistical variables. + ntot = ntot - 1 + ! Add 1 for each hydrometeor to the number of zm statistical variables. + ntot = ntot + hydromet_dim + endif + + if ( any( vars_zm == "rtphmp" ) ) then + ! Correct for number of variables found under "rtphmp". + ! Subtract "rtphmp" from the number of zm statistical variables. + ntot = ntot - 1 + ! Add 1 for each hydrometeor to the number of zm statistical variables. + ntot = ntot + hydromet_dim + endif + + if ( any( vars_zm == "thlphmp" ) ) then + ! Correct for number of variables found under "thlphmp". + ! Subtract "thlphmp" from the number of zm statistical variables. + ntot = ntot - 1 + ! Add 1 for each hydrometeor to the number of zm statistical variables. + ntot = ntot + hydromet_dim + endif + + if ( any( vars_zm == "K_hm" ) ) then + ! Correct for number of variables found under "K_hm". + ! Subtract "K_hm" from the number of zm statistical variables. + ntot = ntot - 1 + ! Add 1 for each hydrometeor to the number of zm statistical variables. + ntot = ntot + hydromet_dim + endif + + if ( ntot == nvarmax_zm ) then + write(fstderr,*) "There are more statistical variables listed in ", & + "vars_zm than allowed for by nvarmax_zm." + write(fstderr,*) "Check the number of variables listed for vars_zm ", & + "in the stats namelist, or change nvarmax_zm." + write(fstderr,*) "nvarmax_zm = ", nvarmax_zm + stop "stats_init: number of zm statistical variables exceeds limit" + end if + + stats_zm%num_output_fields = ntot + stats_zm%kk = nzmax + stats_zm%ii = nlon + stats_zm%jj = nlat + + allocate( stats_zm%z( stats_zm%kk ) ) + stats_zm%z = gzm + + allocate( stats_zm%accum_field_values( stats_zm%ii, stats_zm%jj, & + stats_zm%kk, stats_zm%num_output_fields ) ) + allocate( stats_zm %accum_num_samples( stats_zm%ii, stats_zm%jj, & + stats_zm%kk, stats_zm%num_output_fields ) ) + allocate( stats_zm%l_in_update( stats_zm%ii, stats_zm%jj, stats_zm%kk, & + stats_zm%num_output_fields ) ) + + call stats_zero( stats_zm%ii, stats_zm%jj, stats_zm%kk, stats_zm%num_output_fields, & + stats_zm%accum_field_values, stats_zm %accum_num_samples, stats_zm%l_in_update ) + + allocate( stats_zm%file%var( stats_zm%num_output_fields ) ) + allocate( stats_zm%file%z( stats_zm%kk ) ) + + ! Allocate scratch space + + allocate( zmscr01(stats_zm%kk) ) + allocate( zmscr02(stats_zm%kk) ) + allocate( zmscr03(stats_zm%kk) ) + allocate( zmscr04(stats_zm%kk) ) + allocate( zmscr05(stats_zm%kk) ) + allocate( zmscr06(stats_zm%kk) ) + allocate( zmscr07(stats_zm%kk) ) + allocate( zmscr08(stats_zm%kk) ) + allocate( zmscr09(stats_zm%kk) ) + allocate( zmscr10(stats_zm%kk) ) + allocate( zmscr11(stats_zm%kk) ) + allocate( zmscr12(stats_zm%kk) ) + allocate( zmscr13(stats_zm%kk) ) + allocate( zmscr14(stats_zm%kk) ) + allocate( zmscr15(stats_zm%kk) ) + allocate( zmscr16(stats_zm%kk) ) + allocate( zmscr17(stats_zm%kk) ) + + ! Initialize to 0 + zmscr01 = 0.0_core_rknd + zmscr02 = 0.0_core_rknd + zmscr03 = 0.0_core_rknd + zmscr04 = 0.0_core_rknd + zmscr05 = 0.0_core_rknd + zmscr06 = 0.0_core_rknd + zmscr07 = 0.0_core_rknd + zmscr08 = 0.0_core_rknd + zmscr09 = 0.0_core_rknd + zmscr10 = 0.0_core_rknd + zmscr11 = 0.0_core_rknd + zmscr12 = 0.0_core_rknd + zmscr13 = 0.0_core_rknd + zmscr14 = 0.0_core_rknd + zmscr15 = 0.0_core_rknd + zmscr16 = 0.0_core_rknd + zmscr17 = 0.0_core_rknd + + + fname = trim( fname_zm ) + if ( l_grads ) then + + ! Open GrADS files + call open_grads( iunit, fdir, fname, & + 1, stats_zm%kk, nlat, nlon, stats_zm%z, & + day, month, year, rlat, rlon, & + time_current+real(stats_tout,kind=time_precision), stats_tout, & + stats_zm%num_output_fields, stats_zm%file ) + + else ! Open NetCDF file +#ifdef NETCDF + call open_netcdf( nlat, nlon, fdir, fname, 1, stats_zm%kk, stats_zm%z, & ! In + day, month, year, rlat, rlon, & ! In + time_current, stats_tout, stats_zm%num_output_fields, & ! In + stats_zm%file ) ! InOut + +#else + stop "This CLUBB program was not compiled with netCDF support." +#endif + end if + + call stats_init_zm( vars_zm, l_error ) + + ! Initialize stats_rad_zt (radiation points) + + if (l_output_rad_files) then + + ivar = 1 + do while ( ichar(vars_rad_zt(ivar)(1:1)) /= 0 & + .and. len_trim(vars_rad_zt(ivar)) /= 0 & + .and. ivar <= nvarmax_rad_zt ) + ivar = ivar + 1 + end do + ntot = ivar - 1 + if ( ntot == nvarmax_rad_zt ) then + write(fstderr,*) "There are more statistical variables listed in ", & + "vars_rad_zt than allowed for by nvarmax_rad_zt." + write(fstderr,*) "Check the number of variables listed for vars_rad_zt ", & + "in the stats namelist, or change nvarmax_rad_zt." + write(fstderr,*) "nvarmax_rad_zt = ", nvarmax_rad_zt + stop "stats_init: number of rad_zt statistical variables exceeds limit" + end if + + stats_rad_zt%num_output_fields = ntot + stats_rad_zt%kk = nnrad_zt + stats_rad_zt%ii = nlon + stats_rad_zt%jj = nlat + allocate( stats_rad_zt%z( stats_rad_zt%kk ) ) + stats_rad_zt%z = grad_zt + + allocate( stats_rad_zt%accum_field_values( stats_rad_zt%ii, stats_rad_zt%jj, & + stats_rad_zt%kk, stats_rad_zt%num_output_fields ) ) + allocate( stats_rad_zt%accum_num_samples( stats_rad_zt%ii, stats_rad_zt%jj, & + stats_rad_zt%kk, stats_rad_zt%num_output_fields ) ) + allocate( stats_rad_zt%l_in_update( stats_rad_zt%ii, stats_rad_zt%jj, & + stats_rad_zt%kk, stats_rad_zt%num_output_fields ) ) + + call stats_zero( stats_rad_zt%ii, stats_rad_zt%jj, stats_rad_zt%kk, & + stats_rad_zt%num_output_fields, stats_rad_zt%accum_field_values, & + stats_rad_zt%accum_num_samples, stats_rad_zt%l_in_update ) + + allocate( stats_rad_zt%file%var( stats_rad_zt%num_output_fields ) ) + allocate( stats_rad_zt%file%z( stats_rad_zt%kk ) ) + + fname = trim( fname_rad_zt ) + if ( l_grads ) then + + ! Open GrADS files + call open_grads( iunit, fdir, fname, & + 1, stats_rad_zt%kk, nlat, nlon, stats_rad_zt%z, & + day, month, year, rlat, rlon, & + time_current+real(stats_tout, kind=time_precision), stats_tout, & + stats_rad_zt%num_output_fields, stats_rad_zt%file ) + + else ! Open NetCDF file +#ifdef NETCDF + call open_netcdf( nlat, nlon, fdir, fname, & + 1, stats_rad_zt%kk, stats_rad_zt%z, & + day, month, year, rlat, rlon, & + time_current, stats_tout, & + stats_rad_zt%num_output_fields, stats_rad_zt%file ) + +#else + stop "This CLUBB program was not compiled with netCDF support." +#endif + end if + + call stats_init_rad_zt( vars_rad_zt, l_error ) + + ! Initialize stats_rad_zm (radiation points) + + ivar = 1 + do while ( ichar(vars_rad_zm(ivar)(1:1)) /= 0 & + .and. len_trim(vars_rad_zm(ivar)) /= 0 & + .and. ivar <= nvarmax_rad_zm ) + ivar = ivar + 1 + end do + ntot = ivar - 1 + if ( ntot == nvarmax_rad_zm ) then + write(fstderr,*) "There are more statistical variables listed in ", & + "vars_rad_zm than allowed for by nvarmax_rad_zm." + write(fstderr,*) "Check the number of variables listed for vars_rad_zm ", & + "in the stats namelist, or change nvarmax_rad_zm." + write(fstderr,*) "nvarmax_rad_zm = ", nvarmax_rad_zm + stop "stats_init: number of rad_zm statistical variables exceeds limit" + end if + + stats_rad_zm%num_output_fields = ntot + stats_rad_zm%kk = nnrad_zm + stats_rad_zm%ii = nlon + stats_rad_zm%jj = nlat + + allocate( stats_rad_zm%z( stats_rad_zm%kk ) ) + stats_rad_zm%z = grad_zm + + allocate( stats_rad_zm%accum_field_values( stats_rad_zm%ii, stats_rad_zm%jj, & + stats_rad_zm%kk, stats_rad_zm%num_output_fields ) ) + allocate( stats_rad_zm%accum_num_samples( stats_rad_zm%ii, stats_rad_zm%jj, & + stats_rad_zm%kk, stats_rad_zm%num_output_fields ) ) + allocate( stats_rad_zm%l_in_update( stats_rad_zm%ii, stats_rad_zm%jj, & + stats_rad_zm%kk, stats_rad_zm%num_output_fields ) ) + + call stats_zero( stats_rad_zm%ii, stats_rad_zm%jj, stats_rad_zm%kk, & + stats_rad_zm%num_output_fields, stats_rad_zm%accum_field_values, & + stats_rad_zm%accum_num_samples, stats_rad_zm%l_in_update ) + + allocate( stats_rad_zm%file%var( stats_rad_zm%num_output_fields ) ) + allocate( stats_rad_zm%file%z( stats_rad_zm%kk ) ) + + fname = trim( fname_rad_zm ) + if ( l_grads ) then + + ! Open GrADS files + call open_grads( iunit, fdir, fname, & + 1, stats_rad_zm%kk, nlat, nlon, stats_rad_zm%z, & + day, month, year, rlat, rlon, & + time_current+real(stats_tout,kind=time_precision), stats_tout, & + stats_rad_zm%num_output_fields, stats_rad_zm%file ) + + else ! Open NetCDF file +#ifdef NETCDF + call open_netcdf( nlat, nlon, fdir, fname, & + 1, stats_rad_zm%kk, stats_rad_zm%z, & + day, month, year, rlat, rlon, & + time_current, stats_tout, & + stats_rad_zm%num_output_fields, stats_rad_zm%file ) + +#else + stop "This CLUBB program was not compiled with netCDF support." +#endif + end if + + call stats_init_rad_zm( vars_rad_zm, l_error ) + end if ! l_output_rad_files + + + ! Initialize stats_sfc (surface point) + + ivar = 1 + do while ( ichar(vars_sfc(ivar)(1:1)) /= 0 & + .and. len_trim(vars_sfc(ivar)) /= 0 & + .and. ivar <= nvarmax_sfc ) + ivar = ivar + 1 + end do + ntot = ivar - 1 + if ( ntot == nvarmax_sfc ) then + write(fstderr,*) "There are more statistical variables listed in ", & + "vars_sfc than allowed for by nvarmax_sfc." + write(fstderr,*) "Check the number of variables listed for vars_sfc ", & + "in the stats namelist, or change nvarmax_sfc." + write(fstderr,*) "nvarmax_sfc = ", nvarmax_sfc + stop "stats_init: number of sfc statistical variables exceeds limit" + end if + + stats_sfc%num_output_fields = ntot + stats_sfc%kk = 1 + stats_sfc%ii = nlon + stats_sfc%jj = nlat + + allocate( stats_sfc%z( stats_sfc%kk ) ) + stats_sfc%z = gzm(1) + + allocate( stats_sfc%accum_field_values( stats_sfc%ii, stats_sfc%jj, & + stats_sfc%kk, stats_sfc%num_output_fields ) ) + allocate( stats_sfc%accum_num_samples( stats_sfc%ii, stats_sfc%jj, & + stats_sfc%kk, stats_sfc%num_output_fields ) ) + allocate( stats_sfc%l_in_update( stats_sfc%ii, stats_sfc%jj, & + stats_sfc%kk, stats_sfc%num_output_fields ) ) + + call stats_zero( stats_sfc%ii, stats_sfc%jj, stats_sfc%kk, stats_sfc%num_output_fields, & + stats_sfc%accum_field_values, stats_sfc%accum_num_samples, stats_sfc%l_in_update ) + + allocate( stats_sfc%file%var( stats_sfc%num_output_fields ) ) + allocate( stats_sfc%file%z( stats_sfc%kk ) ) + + fname = trim( fname_sfc ) + + if ( l_grads ) then + + ! Open GrADS files + call open_grads( iunit, fdir, fname, & + 1, stats_sfc%kk, nlat, nlon, stats_sfc%z, & + day, month, year, rlat, rlon, & + time_current+real(stats_tout,kind=time_precision), stats_tout, & + stats_sfc%num_output_fields, stats_sfc%file ) + + else ! Open NetCDF files +#ifdef NETCDF + call open_netcdf( nlat, nlon, fdir, fname, 1, stats_sfc%kk, stats_sfc%z, & ! In + day, month, year, rlat, rlon, & ! In + time_current, stats_tout, stats_sfc%num_output_fields, & ! In + stats_sfc%file ) ! InOut + +#else + stop "This CLUBB program was not compiled with netCDF support." +#endif + end if + + call stats_init_sfc( vars_sfc, l_error ) + + ! Check for errors + + if ( l_error ) then + write(fstderr,*) 'stats_init: errors found' + stop "Fatal error" + endif + + return + + ! If namelist was not found in input file, turn off statistics + + 100 continue + write(fstderr,*) 'Error with statsnl, statistics is turned off' + l_stats = .false. + l_stats_samp = .false. + l_stats_last = .false. + + return + end subroutine stats_init + !----------------------------------------------------------------------- + subroutine stats_zero( ii, jj, kk, nn, x, n, l_in_update ) + + ! Description: + ! Initialize stats to zero + ! References: + ! None + !----------------------------------------------------------------------- + use clubb_precision, only: & + stat_rknd, & ! Variable(s) + stat_nknd + + implicit none + + ! Input Variable(s) + integer, intent(in) :: ii, jj, kk, nn + + ! Output Variable(s) + real(kind=stat_rknd), dimension(ii,jj,kk,nn), intent(out) :: x + integer(kind=stat_nknd), dimension(ii,jj,kk,nn), intent(out) :: n + logical, dimension(ii,jj,kk,nn), intent(out) :: l_in_update + + ! Zero out arrays + + if ( nn > 0 ) then + x(:,:,:,:) = 0.0_stat_rknd + n(:,:,:,:) = 0_stat_nknd + l_in_update(:,:,:,:) = .false. + end if + + return + end subroutine stats_zero + + !----------------------------------------------------------------------- + subroutine stats_avg( ii, jj, kk, nn, x, n ) + + ! Description: + ! Compute the average of stats fields + ! References: + ! None + !----------------------------------------------------------------------- + use clubb_precision, only: & + stat_rknd, & ! Variable(s) + stat_nknd + + use stat_file_module, only: & + clubb_i, clubb_j ! Variable(s) + + implicit none + + ! External + intrinsic :: real + + ! Input Variable(s) + integer, intent(in) :: & + ii, & ! Number of points in X (i.e. latitude) dimension + jj, & ! Number of points in Y (i.e. longitude) dimension + kk, & ! Number of levels in vertical (i.e. Z) dimension + nn ! Number of variables being output to disk (e.g. cloud_frac, rain rate, etc.) + + integer(kind=stat_nknd), dimension(ii,jj,kk,nn), intent(in) :: & + n ! n is the number of samples for each of the nn fields + ! and each of the kk vertical levels + + ! Output Variable(s) + real(kind=stat_rknd), dimension(ii,jj,kk,nn), intent(inout) :: & + x ! The variable x contains the cumulative sums of n sample values of each of + ! the nn output fields (e.g. the sum of the sampled rain rate values) + + ! ---- Begin Code ---- + + ! Compute averages + where ( n(1,1,1:kk,1:nn) > 0 ) + x(clubb_i,clubb_j,1:kk,1:nn) = x(clubb_i,clubb_j,1:kk,1:nn) & + / real( n(clubb_i,clubb_j,1:kk,1:nn), kind=stat_rknd ) + end where + + return + end subroutine stats_avg + + !----------------------------------------------------------------------- + subroutine stats_begin_timestep( itime, stats_nsamp, stats_nout) + + ! Description: + ! Given the elapsed time, set flags determining specifics such as + ! if this time set should be sampled or if this is the first or + ! last time step. + !----------------------------------------------------------------------- + + use stats_variables, only: & + l_stats, & ! Variable(s) + l_stats_samp, & + l_stats_last + + + implicit none + + ! External + intrinsic :: mod + + ! Input Variable(s) + integer, intent(in) :: & + itime, & ! Elapsed model time [timestep] + stats_nsamp, & ! Stats sampling interval [timestep] + stats_nout ! Stats output interval [timestep] + + if ( .not. l_stats ) return + + ! Only sample time steps that are multiples of "stats_tsamp" + ! in a case's "model.in" file to shorten length of run + if ( mod( itime, stats_nsamp ) == 0 ) then + l_stats_samp = .true. + else + l_stats_samp = .false. + end if + + ! Indicates the end of the sampling time period. Signals to start writing to the file + if ( mod( itime, stats_nout ) == 0 ) then + l_stats_last = .true. + else + l_stats_last = .false. + end if + + return + + end subroutine stats_begin_timestep + + !----------------------------------------------------------------------- + subroutine stats_end_timestep( ) + + ! Description: + ! Called when the stats timestep has ended. This subroutine + ! is responsible for calling statistics to be written to the output + ! format. + ! + ! References: + ! None + !----------------------------------------------------------------------- + + use constants_clubb, only: & + fstderr ! Constant(s) + + use stats_variables, only: & + stats_zt, & ! Variable(s) + stats_lh_zt, & + stats_lh_sfc, & + stats_zm, & + stats_rad_zt, & + stats_rad_zm, & + stats_sfc, & + l_stats_last, & + l_output_rad_files, & + l_grads, & + l_silhs_out + + use output_grads, only: & + write_grads ! Procedure(s) + + use stat_file_module, only: & + clubb_i, & ! Variable(s) + clubb_j + +#ifdef NETCDF + use output_netcdf, only: & + write_netcdf ! Procedure(s) +#endif + + implicit none + + ! External + intrinsic :: floor + + ! Local Variables + + logical :: l_error + + ! ---- Begin Code ---- + + ! Check if it is time to write to file + + if ( .not. l_stats_last ) return + + ! Initialize + l_error = .false. + + call stats_check_num_samples( stats_zt, l_error ) + call stats_check_num_samples( stats_zm, l_error ) + call stats_check_num_samples( stats_sfc, l_error ) + if ( l_silhs_out ) then + call stats_check_num_samples( stats_lh_zt, l_error ) + call stats_check_num_samples( stats_lh_sfc, l_error ) + end if + if ( l_output_rad_files ) then + call stats_check_num_samples( stats_rad_zt, l_error ) + call stats_check_num_samples( stats_rad_zm, l_error ) + end if + + ! Stop the run if errors are found. + if ( l_error ) then + write(fstderr,*) 'Possible statistical sampling error' + write(fstderr,*) 'For details, set debug_level to a value of at ', & + 'least 1 in the appropriate model.in file.' + stop 'stats_end_timestep: error(s) found' + end if ! l_error + + ! Compute averages + call stats_avg( stats_zt%ii, stats_zt%jj, stats_zt%kk, stats_zt%num_output_fields, & + stats_zt%accum_field_values, stats_zt%accum_num_samples ) + call stats_avg( stats_zm%ii, stats_zm%jj, stats_zm%kk, stats_zm%num_output_fields, & + stats_zm%accum_field_values, stats_zm%accum_num_samples ) + if ( l_silhs_out ) then + call stats_avg( stats_lh_zt%ii, stats_lh_zt%jj, stats_lh_zt%kk, & + stats_lh_zt%num_output_fields, stats_lh_zt%accum_field_values, & + stats_lh_zt%accum_num_samples ) + call stats_avg( stats_lh_sfc%ii, stats_lh_sfc%jj, stats_lh_sfc%kk, & + stats_lh_sfc%num_output_fields, stats_lh_sfc%accum_field_values, & + stats_lh_sfc%accum_num_samples ) + end if + if ( l_output_rad_files ) then + call stats_avg( stats_rad_zt%ii, stats_rad_zt%jj, stats_rad_zt%kk, & + stats_rad_zt%num_output_fields, & + stats_rad_zt%accum_field_values, stats_rad_zt%accum_num_samples ) + call stats_avg( stats_rad_zm%ii, stats_rad_zm%jj, stats_rad_zm%kk, & + stats_rad_zm%num_output_fields, & + stats_rad_zm%accum_field_values, stats_rad_zm%accum_num_samples ) + end if + call stats_avg( stats_sfc%ii, stats_sfc%jj, stats_sfc%kk, stats_sfc%num_output_fields, & + stats_sfc%accum_field_values, stats_sfc%accum_num_samples ) + + ! Only write to the file and zero out the stats fields if we've reach the horizontal + ! limits of the domain (this is always true in the single-column case because it's 1x1). + if ( clubb_i == stats_zt%ii .and. clubb_j == stats_zt%jj ) then + ! Write to file + if ( l_grads ) then + call write_grads( stats_zt%file ) + call write_grads( stats_zm%file ) + if ( l_silhs_out ) then + call write_grads( stats_lh_zt%file ) + call write_grads( stats_lh_sfc%file ) + end if + if ( l_output_rad_files ) then + call write_grads( stats_rad_zt%file ) + call write_grads( stats_rad_zm%file ) + end if + call write_grads( stats_sfc%file ) + else ! l_netcdf +#ifdef NETCDF + call write_netcdf( stats_zt%file ) + call write_netcdf( stats_zm%file ) + if ( l_silhs_out ) then + call write_netcdf( stats_lh_zt%file ) + call write_netcdf( stats_lh_sfc%file ) + end if + if ( l_output_rad_files ) then + call write_netcdf( stats_rad_zt%file ) + call write_netcdf( stats_rad_zm%file ) + end if + call write_netcdf( stats_sfc%file ) +#else + stop "This program was not compiled with netCDF support" +#endif /* NETCDF */ + end if ! l_grads + + ! Reset sample fields + call stats_zero( stats_zt%ii, stats_zt%jj, stats_zt%kk, stats_zt%num_output_fields, & + stats_zt%accum_field_values, stats_zt%accum_num_samples, stats_zt%l_in_update ) + call stats_zero( stats_zm%ii, stats_zm%jj, stats_zm%kk, stats_zm%num_output_fields, & + stats_zm%accum_field_values, stats_zm%accum_num_samples, stats_zm%l_in_update ) + if ( l_silhs_out ) then + call stats_zero( stats_lh_zt%ii, stats_lh_zt%jj, stats_lh_zt%kk, & + stats_lh_zt%num_output_fields, stats_lh_zt%accum_field_values, & + stats_lh_zt%accum_num_samples, stats_lh_zt%l_in_update ) + call stats_zero( stats_lh_sfc%ii, stats_lh_sfc%jj, stats_lh_sfc%kk, & + stats_lh_sfc%num_output_fields, stats_lh_sfc%accum_field_values, & + stats_lh_sfc%accum_num_samples, stats_lh_sfc%l_in_update ) + end if + if ( l_output_rad_files ) then + call stats_zero( stats_rad_zt%ii, stats_rad_zt%jj, stats_rad_zt%kk, & + stats_rad_zt%num_output_fields, stats_rad_zt%accum_field_values, & + stats_rad_zt%accum_num_samples, stats_rad_zt%l_in_update ) + call stats_zero( stats_rad_zt%ii, stats_rad_zt%jj, stats_rad_zm%kk, & + stats_rad_zm%num_output_fields, stats_rad_zm%accum_field_values, & + stats_rad_zm%accum_num_samples, stats_rad_zm%l_in_update ) + end if + call stats_zero( stats_sfc%ii, stats_sfc%jj, stats_sfc%kk, stats_sfc%num_output_fields, & + stats_sfc%accum_field_values, & + stats_sfc%accum_num_samples, stats_sfc%l_in_update ) + + end if ! clubb_i = stats_zt%ii .and. clubb_j == stats_zt%jj + + + return + end subroutine stats_end_timestep + + !---------------------------------------------------------------------- + subroutine stats_accumulate & + ( um, vm, upwp, vpwp, up2, vp2, & + thlm, rtm, wprtp, wpthlp, & + wp2, wp3, rtp2, thlp2, rtpthlp, & + p_in_Pa, exner, rho, rho_zm, & + rho_ds_zm, rho_ds_zt, thv_ds_zm, & + thv_ds_zt, wm_zt, wm_zm, rcm, wprcp, rc_coef, & + rcm_zm, rtm_zm, thlm_zm, cloud_frac, ice_supersat_frac, & + cloud_frac_zm, ice_supersat_frac_zm, rcm_in_layer, & + cloud_cover, sigma_sqd_w, pdf_params, & + sclrm, sclrp2, sclrprtp, sclrpthlp, sclrm_forcing, & + wpsclrp, edsclrm, edsclrm_forcing ) + + ! Description: + ! Accumulate those stats variables that are preserved in CLUBB from timestep to + ! timestep, but not those stats that are not, (e.g. budget terms, longwave and + ! shortwave components, etc.) + ! + ! References: + ! None + !---------------------------------------------------------------------- + + use constants_clubb, only: & + cloud_frac_min ! Constant + + + use pdf_utilities, only: & + compute_variance_binormal ! Procedure + + use stats_variables, only: & + stats_zt, & ! Variables + stats_zm, & + stats_sfc, & + l_stats_samp, & + ithlm, & + iT_in_K, & + ithvm, & + irtm, & + ircm, & + ium, & + ivm, & + iwm_zt, & + iwm_zm, & + iug, & + ivg, & + icloud_frac, & + iice_supersat_frac, & + ircm_in_layer, & + icloud_cover + + use stats_variables, only: & + ip_in_Pa, & + iexner, & + irho_ds_zt, & + ithv_ds_zt, & + iLscale, & + iwp3, & + iwp3_zm, & + iwpthlp2, & + iwp2thlp, & + iwprtp2, & + iwp2rtp, & + iLscale_up, & + iLscale_down, & + itau_zt, & + iKh_zt + + use stats_variables, only: & + iwp2thvp, & ! Variable(s) + iwp2rcp, & + iwprtpthlp, & + isigma_sqd_w_zt, & + irho, & + irsat, & + irsati + + use stats_variables, only: & + imixt_frac, & ! Variable(s) + iw_1, & + iw_2, & + ivarnce_w_1, & + ivarnce_w_2, & + ithl_1, & + ithl_2, & + ivarnce_thl_1, & + ivarnce_thl_2, & + irt_1, & + irt_2, & + ivarnce_rt_1, & + ivarnce_rt_2, & + irc_1, & + irc_2, & + irsatl_1, & + irsatl_2, & + icloud_frac_1, & + icloud_frac_2 + + use stats_variables, only: & + ichi_1, & ! Variable(s) + ichi_2, & + istdev_chi_1, & + istdev_chi_2, & + ichip2, & + istdev_eta_1, & + istdev_eta_2, & + icovar_chi_eta_1, & + icovar_chi_eta_2, & + icorr_chi_eta_1, & + icorr_chi_eta_2, & + icrt_1, & + icrt_2, & + icthl_1, & + icthl_2, & + irrtthl, & + ichi + + use stats_variables, only: & + iwp2_zt, & ! Variable(s) + ithlp2_zt, & + iwpthlp_zt, & + iwprtp_zt, & + irtp2_zt, & + irtpthlp_zt, & + iup2_zt, & + ivp2_zt, & + iupwp_zt, & + ivpwp_zt, & + iwp2, & + irtp2, & + ithlp2, & + irtpthlp, & + iwprtp, & + iwpthlp, & + iwp4, & + iwpthvp, & + irtpthvp + + use stats_variables, only: & + ithlpthvp, & ! Variable(s) + itau_zm, & + iKh_zm, & + iK_hm, & + iwprcp, & + irc_coef, & + ithlprcp, & + irtprcp, & + ircp2, & + iupwp, & + ivpwp, & + iup2, & + ivp2, & + irho_zm, & + isigma_sqd_w, & + irho_ds_zm, & + ithv_ds_zm, & + iem + + use stats_variables, only: & + ishear, & ! Variable(s) + iFrad, & + icc, & + iz_cloud_base, & + ilwp, & + ivwp, & + ithlm_vert_avg, & + irtm_vert_avg, & + ium_vert_avg, & + ivm_vert_avg, & + iwp2_vert_avg, & + iup2_vert_avg, & + ivp2_vert_avg, & + irtp2_vert_avg, & + ithlp2_vert_avg + + use stats_variables, only: & + isclrm, & ! Variable(s) + isclrm_f, & + iedsclrm, & + iedsclrm_f, & + isclrprtp, & + isclrp2, & + isclrpthvp, & + isclrpthlp, & + isclrprcp, & + iwpsclrp, & + iwp2sclrp, & + iwpsclrp2, & + iwpsclrprtp, & + iwpsclrpthlp, & + iwpedsclrp + + use stats_variables, only: & + icloud_frac_zm, & + iice_supersat_frac_zm, & + ircm_zm, & + irtm_zm, & + ithlm_zm + + use stats_variables, only: & + iwp3_on_wp2, & + iwp3_on_wp2_zt, & + iSkw_velocity + + use stats_variables, only: & + ia3_coef, & ! Variables + ia3_coef_zt, & + ircm_in_cloud + + use grid_class, only: & + gr ! Variable + + use grid_class, only: & + zt2zm ! Procedure(s) + + use variables_diagnostic_module, only: & + thvm, & ! Variable(s) + ug, & + vg, & + Lscale, & + wpthlp2, & + wp2thlp, & + wprtp2, & + wp2rtp, & + Lscale_up, & + Lscale_down, & + tau_zt, & + Kh_zt, & + wp2thvp, & + wp2rcp, & + wprtpthlp, & + sigma_sqd_w_zt, & + rsat + + use variables_diagnostic_module, only: & + wp2_zt, & ! Variable(s) + thlp2_zt, & + wpthlp_zt, & + wprtp_zt, & + rtp2_zt, & + rtpthlp_zt, & + up2_zt, & + vp2_zt, & + upwp_zt, & + vpwp_zt, & + wp4, & + rtpthvp, & + thlpthvp, & + wpthvp, & + tau_zm, & + Kh_zm, & + K_hm,& + thlprcp, & + rtprcp, & + rcp2, & + em, & + Frad, & + sclrpthvp, & + sclrprcp, & + wp2sclrp, & + wpsclrp2, & + wpsclrprtp, & + wpsclrpthlp, & + wpedsclrp + + use variables_diagnostic_module, only: & + a3_coef, & ! Variable(s) + a3_coef_zt, & + wp3_zm, & + wp3_on_wp2, & + wp3_on_wp2_zt, & + Skw_velocity + + use pdf_parameter_module, only: & + pdf_parameter ! Type + + use T_in_K_module, only: & + thlm2T_in_K ! Procedure + + use constants_clubb, only: & + rc_tol ! Constant(s) + + use parameters_model, only: & + sclr_dim, & ! Variable(s) + edsclr_dim + + use stats_type_utilities, only: & + stat_update_var, & ! Procedure(s) + stat_update_var_pt + + use fill_holes, only: & + vertical_avg, & ! Procedure(s) + vertical_integral + + use interpolation, only: & + lin_interpolate_two_points ! Procedure + + use saturation, only: & + sat_mixrat_ice ! Procedure + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variable(s) + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + um, & ! u wind [m/s] + vm, & ! v wind [m/s] + upwp, & ! vertical u momentum flux [m^2/s^2] + vpwp, & ! vertical v momentum flux [m^2/s^2] + up2, & ! u'^2 [m^2/s^2] + vp2, & ! v'^2 [m^2/s^2] + thlm, & ! liquid potential temperature [K] + rtm, & ! total water mixing ratio [kg/kg] + wprtp, & ! w'rt' [(kg/kg) m/s] + wpthlp, & ! w'thl' [m K /s] + wp2, & ! w'^2 [m^2/s^2] + wp3, & ! w'^3 [m^3/s^3] + rtp2, & ! rt'^2 [(kg/kg)^2] + thlp2, & ! thl'^2 [K^2] + rtpthlp ! rt'thl' [kg/kg K] + + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + p_in_Pa, & ! Pressure (Pa) on thermodynamic points [Pa] + exner, & ! Exner function = ( p / p0 ) ** kappa [-] + rho, & ! Density [kg/m^3] + rho_zm, & ! Density [kg/m^3] + rho_ds_zm, & ! Dry, static density (momentum levels) [kg/m^3] + rho_ds_zt, & ! Dry, static density (thermo. levs.) [kg/m^3] + thv_ds_zm, & ! Dry, base-state theta_v (momentum levs.) [K] + thv_ds_zt, & ! Dry, base-state theta_v (thermo. levs.) [K] + wm_zt, & ! w on thermodynamic levels [m/s] + wm_zm ! w on momentum levels [m/s] + + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + rcm_zm, & ! Total water mixing ratio [kg/kg] + rtm_zm, & ! Total water mixing ratio [kg/kg] + thlm_zm, & ! Liquid potential temperature [K] + rcm, & ! Cloud water mixing ratio [kg/kg] + wprcp, & ! w'rc' [(kg/kg) m/s] + rc_coef, & ! Coefficient of X' R_l' in Eq. (34) [-] + cloud_frac, & ! Cloud fraction [-] + ice_supersat_frac, & ! Ice cloud fracion [-] + cloud_frac_zm, & ! Cloud fraction on zm levels [-] + ice_supersat_frac_zm, & ! Ice cloud fraction on zm levels [-] + rcm_in_layer, & ! Cloud water mixing ratio in cloud layer [kg/kg] + cloud_cover ! Cloud cover [-] + + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + sigma_sqd_w ! PDF width parameter (momentum levels) [-] + + type(pdf_parameter), dimension(gr%nz), intent(in) :: & + pdf_params ! PDF parameters [units vary] + + real( kind = core_rknd ), intent(in), dimension(gr%nz,sclr_dim) :: & + sclrm, & ! High-order passive scalar [units vary] + sclrp2, & ! High-order passive scalar variance [units^2] + sclrprtp, & ! High-order passive scalar covariance [units kg/kg] + sclrpthlp, & ! High-order passive scalar covariance [units K] + sclrm_forcing, & ! Large-scale forcing of scalar [units/s] + wpsclrp ! w'sclr' [units m/s] + + real( kind = core_rknd ), intent(in), dimension(gr%nz,edsclr_dim) :: & + edsclrm, & ! Eddy-diff passive scalar [units vary] + edsclrm_forcing ! Large-scale forcing of edscalar [units vary] + + ! Local Variables + + integer :: isclr, k + + real( kind = core_rknd ), dimension(gr%nz) :: & + T_in_K, & ! Absolute temperature [K] + rsati, & ! Saturation w.r.t ice [kg/kg] + shear, & ! Wind shear production term [m^2/s^3] + chi, & ! Mellor's 's' [kg/kg] + chip2, & ! Variance of Mellor's 's' [kg/kg] + rcm_in_cloud ! rcm in cloud [kg/kg] + + real( kind = core_rknd ) :: xtmp + + ! ---- Begin Code ---- + + ! Sample fields + + if ( l_stats_samp ) then + + ! stats_zt variables + + + if ( iT_in_K > 0 .or. irsati > 0 ) then + T_in_K = thlm2T_in_K( thlm, exner, rcm ) + else + T_in_K = -999._core_rknd + end if + + call stat_update_var( iT_in_K, T_in_K, stats_zt ) + + call stat_update_var( ithlm, thlm, stats_zt ) + call stat_update_var( ithvm, thvm, stats_zt ) + call stat_update_var( irtm, rtm, stats_zt ) + call stat_update_var( ircm, rcm, stats_zt ) + call stat_update_var( ium, um, stats_zt ) + call stat_update_var( ivm, vm, stats_zt ) + call stat_update_var( iwm_zt, wm_zt, stats_zt ) + call stat_update_var( iwm_zm, wm_zm, stats_zm ) + call stat_update_var( iug, ug, stats_zt ) + call stat_update_var( ivg, vg, stats_zt ) + call stat_update_var( icloud_frac, cloud_frac, stats_zt ) + call stat_update_var( iice_supersat_frac, ice_supersat_frac, stats_zt) + call stat_update_var( ircm_in_layer, rcm_in_layer, stats_zt ) + call stat_update_var( icloud_cover, cloud_cover, stats_zt ) + call stat_update_var( ip_in_Pa, p_in_Pa, stats_zt ) + call stat_update_var( iexner, exner, stats_zt ) + call stat_update_var( irho_ds_zt, rho_ds_zt, stats_zt ) + call stat_update_var( ithv_ds_zt, thv_ds_zt, stats_zt ) + call stat_update_var( iLscale, Lscale, stats_zt ) + call stat_update_var( iwp3, wp3, stats_zt ) + call stat_update_var( iwpthlp2, wpthlp2, stats_zt ) + call stat_update_var( iwp2thlp, wp2thlp, stats_zt ) + call stat_update_var( iwprtp2, wprtp2, stats_zt ) + call stat_update_var( iwp2rtp, wp2rtp, stats_zt ) + call stat_update_var( iLscale_up, Lscale_up, stats_zt ) + call stat_update_var( iLscale_down, Lscale_down, stats_zt ) + call stat_update_var( itau_zt, tau_zt, stats_zt ) + call stat_update_var( iKh_zt, Kh_zt, stats_zt ) + call stat_update_var( iwp2thvp, wp2thvp, stats_zt ) + call stat_update_var( iwp2rcp, wp2rcp, stats_zt ) + call stat_update_var( iwprtpthlp, wprtpthlp, stats_zt ) + call stat_update_var( isigma_sqd_w_zt, sigma_sqd_w_zt, stats_zt ) + call stat_update_var( irho, rho, stats_zt ) + call stat_update_var( irsat, rsat, stats_zt ) + if ( irsati > 0 ) then + rsati = sat_mixrat_ice( p_in_Pa, T_in_K ) + call stat_update_var( irsati, rsati, stats_zt ) + end if + + call stat_update_var( imixt_frac, pdf_params%mixt_frac, stats_zt ) + call stat_update_var( iw_1, pdf_params%w_1, stats_zt ) + call stat_update_var( iw_2, pdf_params%w_2, stats_zt ) + call stat_update_var( ivarnce_w_1, pdf_params%varnce_w_1, stats_zt ) + call stat_update_var( ivarnce_w_2, pdf_params%varnce_w_2, stats_zt ) + call stat_update_var( ithl_1, pdf_params%thl_1, stats_zt ) + call stat_update_var( ithl_2, pdf_params%thl_2, stats_zt ) + call stat_update_var( ivarnce_thl_1, pdf_params%varnce_thl_1, stats_zt ) + call stat_update_var( ivarnce_thl_2, pdf_params%varnce_thl_2, stats_zt ) + call stat_update_var( irt_1, pdf_params%rt_1, stats_zt ) + call stat_update_var( irt_2, pdf_params%rt_2, stats_zt ) + call stat_update_var( ivarnce_rt_1, pdf_params%varnce_rt_1, stats_zt ) + call stat_update_var( ivarnce_rt_2, pdf_params%varnce_rt_2, stats_zt ) + call stat_update_var( irc_1, pdf_params%rc_1, stats_zt ) + call stat_update_var( irc_2, pdf_params%rc_2, stats_zt ) + call stat_update_var( irsatl_1, pdf_params%rsatl_1, stats_zt ) + call stat_update_var( irsatl_2, pdf_params%rsatl_2, stats_zt ) + call stat_update_var( icloud_frac_1, pdf_params%cloud_frac_1, stats_zt ) + call stat_update_var( icloud_frac_2, pdf_params%cloud_frac_2, stats_zt ) + call stat_update_var( ichi_1, pdf_params%chi_1, stats_zt ) + call stat_update_var( ichi_2, pdf_params%chi_2, stats_zt ) + call stat_update_var( istdev_chi_1, pdf_params%stdev_chi_1, stats_zt ) + call stat_update_var( istdev_chi_2, pdf_params%stdev_chi_2, stats_zt ) + call stat_update_var( istdev_eta_1, pdf_params%stdev_eta_1, stats_zt ) + call stat_update_var( istdev_eta_2, pdf_params%stdev_eta_2, stats_zt ) + call stat_update_var( icovar_chi_eta_1, pdf_params%covar_chi_eta_1, stats_zt ) + call stat_update_var( icovar_chi_eta_2, pdf_params%covar_chi_eta_2, stats_zt ) + call stat_update_var( icorr_chi_eta_1, pdf_params%corr_chi_eta_1, stats_zt ) + call stat_update_var( icorr_chi_eta_2, pdf_params%corr_chi_eta_2, stats_zt ) + call stat_update_var( irrtthl, pdf_params%rrtthl, stats_zt ) + call stat_update_var( icrt_1, pdf_params%crt_1, stats_zt ) + call stat_update_var( icrt_2, pdf_params%crt_2, stats_zt ) + call stat_update_var( icthl_1, pdf_params%cthl_1, stats_zt ) + call stat_update_var( icthl_2, pdf_params%cthl_2, stats_zt ) + call stat_update_var( iwp2_zt, wp2_zt, stats_zt ) + call stat_update_var( ithlp2_zt, thlp2_zt, stats_zt ) + call stat_update_var( iwpthlp_zt, wpthlp_zt, stats_zt ) + call stat_update_var( iwprtp_zt, wprtp_zt, stats_zt ) + call stat_update_var( irtp2_zt, rtp2_zt, stats_zt ) + call stat_update_var( irtpthlp_zt, rtpthlp_zt, stats_zt ) + call stat_update_var( iup2_zt, up2_zt, stats_zt ) + call stat_update_var( ivp2_zt, vp2_zt, stats_zt ) + call stat_update_var( iupwp_zt, upwp_zt, stats_zt ) + call stat_update_var( ivpwp_zt, vpwp_zt, stats_zt ) + call stat_update_var( ia3_coef_zt, a3_coef_zt, stats_zt ) + call stat_update_var( iwp3_on_wp2_zt, wp3_on_wp2_zt, stats_zt ) + + if ( ichi > 0 ) then + ! Determine 's' from Mellor (1977) (extended liquid water) + chi(:) = pdf_params%mixt_frac * pdf_params%chi_1 & + + (1.0_core_rknd-pdf_params%mixt_frac) * pdf_params%chi_2 + call stat_update_var( ichi, chi, stats_zt ) + end if + + ! Calculate variance of chi + if ( ichip2 > 0 ) then + chip2 = compute_variance_binormal( chi, pdf_params%chi_1, pdf_params%chi_2, & + pdf_params%stdev_chi_1, pdf_params%stdev_chi_2, & + pdf_params%mixt_frac ) + call stat_update_var( ichip2, chip2, stats_zt ) + end if + + if ( sclr_dim > 0 ) then + do isclr=1, sclr_dim + call stat_update_var( isclrm(isclr), sclrm(:,isclr), stats_zt ) + call stat_update_var( isclrm_f(isclr), sclrm_forcing(:,isclr), stats_zt ) + end do + end if + + if ( edsclr_dim > 0 ) then + do isclr = 1, edsclr_dim + call stat_update_var( iedsclrm(isclr), edsclrm(:,isclr), stats_zt ) + call stat_update_var( iedsclrm_f(isclr), edsclrm_forcing(:,isclr), stats_zt ) + end do + end if + + ! Calculate rcm in cloud + if ( ircm_in_cloud > 0 ) then + where ( cloud_frac(:) > cloud_frac_min ) + rcm_in_cloud(:) = rcm / cloud_frac + else where + rcm_in_cloud(:) = rcm + end where + + call stat_update_var( ircm_in_cloud, rcm_in_cloud, stats_zt ) + end if + + ! stats_zm variables + + call stat_update_var( iwp2, wp2, stats_zm ) + call stat_update_var( iwp3_zm, wp3_zm, stats_zm ) + call stat_update_var( irtp2, rtp2, stats_zm ) + call stat_update_var( ithlp2, thlp2, stats_zm ) + call stat_update_var( irtpthlp, rtpthlp, stats_zm ) + call stat_update_var( iwprtp, wprtp, stats_zm ) + call stat_update_var( iwpthlp, wpthlp, stats_zm ) + call stat_update_var( iwp4, wp4, stats_zm ) + call stat_update_var( iwpthvp, wpthvp, stats_zm ) + call stat_update_var( irtpthvp, rtpthvp, stats_zm ) + call stat_update_var( ithlpthvp, thlpthvp, stats_zm ) + call stat_update_var( itau_zm, tau_zm, stats_zm ) + call stat_update_var( iKh_zm, Kh_zm, stats_zm ) + call stat_update_var( iwprcp, wprcp, stats_zm ) + call stat_update_var( irc_coef, rc_coef, stats_zm ) + call stat_update_var( ithlprcp, thlprcp, stats_zm ) + call stat_update_var( irtprcp, rtprcp, stats_zm ) + call stat_update_var( ircp2, rcp2, stats_zm ) + call stat_update_var( iupwp, upwp, stats_zm ) + call stat_update_var( ivpwp, vpwp, stats_zm ) + call stat_update_var( ivp2, vp2, stats_zm ) + call stat_update_var( iup2, up2, stats_zm ) + call stat_update_var( irho_zm, rho_zm, stats_zm ) + call stat_update_var( isigma_sqd_w, sigma_sqd_w, stats_zm ) + call stat_update_var( irho_ds_zm, rho_ds_zm, stats_zm ) + call stat_update_var( ithv_ds_zm, thv_ds_zm, stats_zm ) + call stat_update_var( iem, em, stats_zm ) + call stat_update_var( iFrad, Frad, stats_zm ) + + call stat_update_var( iSkw_velocity, Skw_velocity, stats_zm ) + call stat_update_var( ia3_coef, a3_coef, stats_zm ) + call stat_update_var( iwp3_on_wp2, wp3_on_wp2, stats_zm ) + + call stat_update_var( icloud_frac_zm, cloud_frac_zm, stats_zm ) + call stat_update_var( iice_supersat_frac_zm, ice_supersat_frac_zm, stats_zm ) + call stat_update_var( ircm_zm, rcm_zm, stats_zm ) + call stat_update_var( irtm_zm, rtm_zm, stats_zm ) + call stat_update_var( ithlm_zm, thlm_zm, stats_zm ) + + if ( sclr_dim > 0 ) then + do isclr=1, sclr_dim + call stat_update_var( isclrp2(isclr), sclrp2(:,isclr), stats_zm ) + call stat_update_var( isclrprtp(isclr), sclrprtp(:,isclr), stats_zm ) + call stat_update_var( isclrpthvp(isclr), sclrpthvp(:,isclr), stats_zm ) + call stat_update_var( isclrpthlp(isclr), sclrpthlp(:,isclr), stats_zm ) + call stat_update_var( isclrprcp(isclr), sclrprcp(:,isclr), stats_zm ) + call stat_update_var( iwpsclrp(isclr), wpsclrp(:,isclr), stats_zm ) + call stat_update_var( iwp2sclrp(isclr), wp2sclrp(:,isclr), stats_zm ) + call stat_update_var( iwpsclrp2(isclr), wpsclrp2(:,isclr), stats_zm ) + call stat_update_var( iwpsclrprtp(isclr), wpsclrprtp(:,isclr), stats_zm ) + call stat_update_var( iwpsclrpthlp(isclr), wpsclrpthlp(:,isclr), stats_zm ) + end do + end if + if ( edsclr_dim > 0 ) then + do isclr = 1, edsclr_dim + call stat_update_var( iwpedsclrp(isclr), wpedsclrp(:,isclr), stats_zm ) + end do + end if + + ! Calculate shear production + if ( ishear > 0 ) then + do k = 1, gr%nz-1, 1 + shear(k) = - upwp(k) * ( um(k+1) - um(k) ) * gr%invrs_dzm(k) & + - vpwp(k) * ( vm(k+1) - vm(k) ) * gr%invrs_dzm(k) + enddo + shear(gr%nz) = 0.0_core_rknd + end if + call stat_update_var( ishear, shear, stats_zm ) + + ! stats_sfc variables + + ! Cloud cover + call stat_update_var_pt( icc, 1, maxval( cloud_frac(1:gr%nz) ), stats_sfc ) + + ! Cloud base + if ( iz_cloud_base > 0 ) then + + k = 1 + do while ( rcm(k) < rc_tol .and. k < gr%nz ) + k = k + 1 + enddo + + if ( k > 1 .and. k < gr%nz) then + + ! Use linear interpolation to find the exact height of the + ! rc_tol kg/kg level. Brian. + call stat_update_var_pt( iz_cloud_base, 1, lin_interpolate_two_points( rc_tol, rcm(k), & + rcm(k-1), gr%zt(k), gr%zt(k-1) ), stats_sfc ) + + else + + ! Set the cloud base output to -10m, if it's clear. + ! Known magic number + call stat_update_var_pt( iz_cloud_base, 1, -10.0_core_rknd , stats_sfc ) + + end if ! k > 1 and k < gr%nz + + end if ! iz_cloud_base > 0 + + ! Liquid Water Path + if ( ilwp > 0 ) then + + xtmp & + = vertical_integral & + ( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & + rcm(2:gr%nz), gr%invrs_dzt(2:gr%nz) ) + + call stat_update_var_pt( ilwp, 1, xtmp, stats_sfc ) + + end if + + ! Vapor Water Path (Preciptable Water) + if ( ivwp > 0 ) then + + xtmp & + = vertical_integral & + ( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & + ( rtm(2:gr%nz) - rcm(2:gr%nz) ), gr%invrs_dzt(2:gr%nz) ) + + call stat_update_var_pt( ivwp, 1, xtmp, stats_sfc ) + + end if + + + ! Vertical average of thermodynamic level variables. + + ! Find the vertical average of thermodynamic level variables, averaged from + ! level 2 (the first thermodynamic level above model surface) through + ! level gr%nz (the top of the model). Use the vertical averaging function + ! found in fill_holes.F90. + + ! Vertical average of thlm. + call stat_update_var_pt( ithlm_vert_avg, 1, & + vertical_avg( (gr%nz-2+1), rho_ds_zt(2:gr%nz), & + thlm(2:gr%nz), gr%invrs_dzt(2:gr%nz) ), & + stats_sfc ) + + ! Vertical average of rtm. + call stat_update_var_pt( irtm_vert_avg, 1, & + vertical_avg( (gr%nz-2+1), rho_ds_zt(2:gr%nz), & + rtm(2:gr%nz), gr%invrs_dzt(2:gr%nz) ), & + stats_sfc ) + + ! Vertical average of um. + call stat_update_var_pt( ium_vert_avg, 1, & + vertical_avg( (gr%nz-2+1), rho_ds_zt(2:gr%nz), & + um(2:gr%nz), gr%invrs_dzt(2:gr%nz) ), & + stats_sfc ) + + ! Vertical average of vm. + call stat_update_var_pt( ivm_vert_avg, 1, & + vertical_avg( (gr%nz-2+1), rho_ds_zt(2:gr%nz), & + vm(2:gr%nz), gr%invrs_dzt(2:gr%nz) ), & + stats_sfc ) + + ! Vertical average of momentum level variables. + + ! Find the vertical average of momentum level variables, averaged over the + ! entire vertical profile (level 1 through level gr%nz). Use the vertical + ! averaging function found in fill_holes.F90. + + ! Vertical average of wp2. + call stat_update_var_pt( iwp2_vert_avg, 1, & + vertical_avg( (gr%nz-1+1), rho_ds_zm(1:gr%nz), & + wp2(1:gr%nz), gr%invrs_dzm(1:gr%nz) ), & + stats_sfc ) + + ! Vertical average of up2. + call stat_update_var_pt( iup2_vert_avg, 1, & + vertical_avg( (gr%nz-1+1), rho_ds_zm(1:gr%nz), & + up2(1:gr%nz), gr%invrs_dzm(1:gr%nz) ), & + stats_sfc ) + + ! Vertical average of vp2. + call stat_update_var_pt( ivp2_vert_avg, 1, & + vertical_avg( (gr%nz-1+1), rho_ds_zm(1:gr%nz), & + vp2(1:gr%nz), gr%invrs_dzm(1:gr%nz) ), & + stats_sfc ) + + ! Vertical average of rtp2. + call stat_update_var_pt( irtp2_vert_avg, 1, & + vertical_avg( (gr%nz-1+1), rho_ds_zm(1:gr%nz), & + rtp2(1:gr%nz), gr%invrs_dzm(1:gr%nz) ), & + stats_sfc ) + + ! Vertical average of thlp2. + call stat_update_var_pt( ithlp2_vert_avg, 1, & + vertical_avg( (gr%nz-1+1), rho_ds_zm(1:gr%nz), & + thlp2(1:gr%nz), gr%invrs_dzm(1:gr%nz) ), & + stats_sfc ) + + + end if ! l_stats_samp + + + return + end subroutine stats_accumulate +!------------------------------------------------------------------------------ + subroutine stats_accumulate_hydromet( hydromet, rho_ds_zt ) +! Description: +! Compute stats related the hydrometeors + +! References: +! None +!------------------------------------------------------------------------------ + use parameters_model, only: & + hydromet_dim ! Variable(s) + + use grid_class, only: & + gr ! Variable(s) + + use array_index, only: & + iirrm, iirsm, iirim, iirgm, & ! Variable(s) + iiNrm, iiNsm, iiNim, iiNgm + + use stats_variables, only: & + stats_sfc, & ! Variable(s) + irrm, & + irsm, & + irim, & + irgm, & + iNim, & + iNrm, & + iNsm, & + iNgm, & + iswp, & + irwp, & + iiwp + + use fill_holes, only: & + vertical_integral ! Procedure(s) + + use stats_type_utilities, only: & + stat_update_var, & ! Procedure(s) + stat_update_var_pt + + use stats_variables, only: & + stats_zt, & ! Variables + l_stats_samp + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), dimension(gr%nz,hydromet_dim), intent(in) :: & + hydromet ! All hydrometeors except for rcm [units vary] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + rho_ds_zt ! Dry, static density (thermo. levs.) [kg/m^3] + + ! Local Variables + real(kind=core_rknd) :: xtmp + + ! ---- Begin Code ---- + + if ( l_stats_samp ) then + + if ( iirrm > 0 ) then + call stat_update_var( irrm, hydromet(:,iirrm), stats_zt ) + end if + + if ( iirsm > 0 ) then + call stat_update_var( irsm, hydromet(:,iirsm), stats_zt ) + end if + + if ( iirim > 0 ) then + call stat_update_var( irim, hydromet(:,iirim), stats_zt ) + end if + + if ( iirgm > 0 ) then + call stat_update_var( irgm, & + hydromet(:,iirgm), stats_zt ) + end if + + if ( iiNim > 0 ) then + call stat_update_var( iNim, hydromet(:,iiNim), stats_zt ) + end if + + if ( iiNrm > 0 ) then + call stat_update_var( iNrm, hydromet(:,iiNrm), stats_zt ) + end if + + if ( iiNsm > 0 ) then + call stat_update_var( iNsm, hydromet(:,iiNsm), stats_zt ) + end if + + if ( iiNgm > 0 ) then + call stat_update_var( iNgm, hydromet(:,iiNgm), stats_zt ) + end if + + ! Snow Water Path + if ( iswp > 0 .and. iirsm > 0 ) then + + ! Calculate snow water path + xtmp & + = vertical_integral & + ( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & + hydromet(2:gr%nz,iirsm), gr%invrs_dzt(2:gr%nz) ) + + call stat_update_var_pt( iswp, 1, xtmp, stats_sfc ) + + end if ! iswp > 0 .and. iirsm > 0 + + ! Ice Water Path + if ( iiwp > 0 .and. iirim > 0 ) then + + xtmp & + = vertical_integral & + ( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & + hydromet(2:gr%nz,iirim), gr%invrs_dzt(2:gr%nz) ) + + call stat_update_var_pt( iiwp, 1, xtmp, stats_sfc ) + + end if + + ! Rain Water Path + if ( irwp > 0 .and. iirrm > 0 ) then + + xtmp & + = vertical_integral & + ( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & + hydromet(2:gr%nz,iirrm), gr%invrs_dzt(2:gr%nz) ) + + call stat_update_var_pt( irwp, 1, xtmp, stats_sfc ) + + end if ! irwp > 0 .and. irrm > 0 + end if ! l_stats_samp + + return + end subroutine stats_accumulate_hydromet +!------------------------------------------------------------------------------ + subroutine stats_accumulate_lh_tend( lh_hydromet_mc, lh_Ncm_mc, & + lh_thlm_mc, lh_rvm_mc, lh_rcm_mc ) +! Description: +! Compute stats for the tendency of latin hypercube sample points. + +! References: +! None +!------------------------------------------------------------------------------ + use parameters_model, only: & + hydromet_dim ! Variable(s) + + use grid_class, only: & + gr ! Variable(s) + + use array_index, only: & + iirrm, iirsm, iirim, iirgm, & ! Variable(s) + iiNrm, iiNsm, iiNim, iiNgm + + use stats_variables, only: & + ilh_rrm_mc, & ! Variable(s) + ilh_rsm_mc, & + ilh_rim_mc, & + ilh_rgm_mc, & + ilh_Ncm_mc, & + ilh_Nim_mc, & + ilh_Nrm_mc, & + ilh_Nsm_mc, & + ilh_Ngm_mc, & + ilh_rcm_mc, & + ilh_rvm_mc, & + ilh_thlm_mc + + use stats_variables, only: & + iAKstd, & ! Variable(s) + iAKstd_cld, & + iAKm_rcm, & + iAKm_rcc, & + iAKm, & + ilh_AKm, & + ilh_rcm_avg + + use variables_diagnostic_module, only: & + AKm, & ! Variable(s) + lh_AKm, & + AKstd, & + lh_rcm_avg, & + AKstd_cld, & + AKm_rcm, & + AKm_rcc + + use stats_type_utilities, only: & + stat_update_var ! Procedure(s) + + use stats_variables, only: & + stats_lh_zt, & ! Variables + l_stats_samp + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), dimension(gr%nz,hydromet_dim), intent(in) :: & + lh_hydromet_mc ! Tendency of hydrometeors except for rvm/rcm [units vary] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + lh_Ncm_mc, & ! Tendency of cloud droplet concentration [num/kg/s] + lh_thlm_mc, & ! Tendency of liquid potential temperature [kg/kg/s] + lh_rcm_mc, & ! Tendency of cloud water [kg/kg/s] + lh_rvm_mc ! Tendency of vapor [kg/kg/s] + + if ( l_stats_samp ) then + + call stat_update_var( ilh_thlm_mc, lh_thlm_mc, stats_lh_zt ) + call stat_update_var( ilh_rcm_mc, lh_rcm_mc, stats_lh_zt ) + call stat_update_var( ilh_rvm_mc, lh_rvm_mc, stats_lh_zt ) + + call stat_update_var( ilh_Ncm_mc, lh_Ncm_mc, stats_lh_zt ) + + if ( iirrm > 0 ) then + call stat_update_var( ilh_rrm_mc, lh_hydromet_mc(:,iirrm), stats_lh_zt ) + end if + + if ( iirsm > 0 ) then + call stat_update_var( ilh_rsm_mc, lh_hydromet_mc(:,iirsm), stats_lh_zt ) + end if + + if ( iirim > 0 ) then + call stat_update_var( ilh_rim_mc, lh_hydromet_mc(:,iirim), stats_lh_zt ) + end if + + if ( iirgm > 0 ) then + call stat_update_var( ilh_rgm_mc, lh_hydromet_mc(:,iirgm), stats_lh_zt ) + end if + + if ( iiNim > 0 ) then + call stat_update_var( ilh_Nim_mc, lh_hydromet_mc(:,iiNim), stats_lh_zt ) + end if + + if ( iiNrm > 0 ) then + call stat_update_var( ilh_Nrm_mc, lh_hydromet_mc(:,iiNrm), stats_lh_zt ) + end if + + if ( iiNsm > 0 ) then + call stat_update_var( ilh_Nsm_mc, lh_hydromet_mc(:,iiNsm), stats_lh_zt ) + end if + + if ( iiNgm > 0 ) then + call stat_update_var( ilh_Ngm_mc, lh_hydromet_mc(:,iiNgm), stats_lh_zt ) + end if + + call stat_update_var( iAKm, AKm, stats_lh_zt ) + call stat_update_var( ilh_AKm, lh_AKm, stats_lh_zt) + call stat_update_var( ilh_rcm_avg, lh_rcm_avg, stats_lh_zt ) + call stat_update_var( iAKstd, AKstd, stats_lh_zt ) + call stat_update_var( iAKstd_cld, AKstd_cld, stats_lh_zt ) + + call stat_update_var( iAKm_rcm, AKm_rcm, stats_lh_zt) + call stat_update_var( iAKm_rcc, AKm_rcc, stats_lh_zt ) + + end if ! l_stats_samp + + return + end subroutine stats_accumulate_lh_tend + + !----------------------------------------------------------------------- + subroutine stats_finalize( ) + + ! Description: + ! Close NetCDF files and deallocate scratch space and + ! stats file structures. + !----------------------------------------------------------------------- + + use stats_variables, only: & + stats_zt, & ! Variable(s) + stats_lh_zt, & + stats_lh_sfc, & + stats_zm, & + stats_rad_zt, & + stats_rad_zm, & + stats_sfc, & + l_netcdf, & + l_stats, & + l_output_rad_files, & + l_silhs_out + + use stats_variables, only: & + ztscr01, & ! Variable(s) + ztscr02, & + ztscr03, & + ztscr04, & + ztscr05, & + ztscr06, & + ztscr07, & + ztscr08, & + ztscr09, & + ztscr10, & + ztscr11, & + ztscr12, & + ztscr13, & + ztscr14, & + ztscr15, & + ztscr16, & + ztscr17, & + ztscr18, & + ztscr19, & + ztscr20, & + ztscr21 + + use stats_variables, only: & + zmscr01, & ! Variable(s) + zmscr02, & + zmscr03, & + zmscr04, & + zmscr05, & + zmscr06, & + zmscr07, & + zmscr08, & + zmscr09, & + zmscr10, & + zmscr11, & + zmscr12, & + zmscr13, & + zmscr14, & + zmscr15, & + zmscr16, & + zmscr17 + + use stats_variables, only: & + isclrm, & + isclrm_f, & + iedsclrm, & + iedsclrm_f, & + isclrprtp, & + isclrp2, & + isclrpthvp, & + isclrpthlp, & + isclrprcp, & + iwpsclrp, & + iwp2sclrp, & + iwpsclrp2, & + iwpsclrprtp, & + iwpsclrpthlp, & + iwpedsclrp + + use stats_variables, only: & + icorr_w_hm_ov_adj, & + ihm1, & + ihm2, & + imu_hm_1, & + imu_hm_2, & + imu_hm_1_n, & + imu_hm_2_n, & + isigma_hm_1, & + isigma_hm_2, & + isigma_hm_1_n, & + isigma_hm_2_n, & + icorr_w_hm_1, & + icorr_w_hm_2, & + icorr_chi_hm_1, & + icorr_chi_hm_2, & + icorr_eta_hm_1, & + icorr_eta_hm_2, & + icorr_Ncn_hm_1, & + icorr_Ncn_hm_2, & + icorr_hmx_hmy_1, & + icorr_hmx_hmy_2, & + icorr_w_hm_1_n, & + icorr_w_hm_2_n, & + icorr_chi_hm_1_n, & + icorr_chi_hm_2_n, & + icorr_eta_hm_1_n, & + icorr_eta_hm_2_n, & + icorr_Ncn_hm_1_n, & + icorr_Ncn_hm_2_n, & + icorr_hmx_hmy_1_n, & + icorr_hmx_hmy_2_n, & + ihmp2_zt, & + iwp2hmp, & + ihydrometp2, & + iwphydrometp, & + iK_hm, & + irtphmp, & + ithlphmp + +#ifdef NETCDF + use output_netcdf, only: & + close_netcdf ! Procedure +#endif + + implicit none + + if ( l_stats .and. l_netcdf ) then +#ifdef NETCDF + call close_netcdf( stats_zt%file ) + call close_netcdf( stats_lh_zt%file ) + call close_netcdf( stats_lh_sfc%file ) + call close_netcdf( stats_zm%file ) + call close_netcdf( stats_rad_zt%file ) + call close_netcdf( stats_rad_zm%file ) + call close_netcdf( stats_sfc%file ) +#else + stop "This program was not compiled with netCDF support" +#endif + end if + + if ( l_stats ) then + ! De-allocate all stats_zt variables + deallocate( stats_zt%z ) + + deallocate( stats_zt%accum_field_values ) + + deallocate( stats_zt%accum_num_samples ) + deallocate( stats_zt%l_in_update ) + + + deallocate( stats_zt%file%var ) + deallocate( stats_zt%file%z ) + deallocate( stats_zt%file%rlat ) + deallocate( stats_zt%file%rlon ) + + deallocate ( ztscr01 ) + deallocate ( ztscr02 ) + deallocate ( ztscr03 ) + deallocate ( ztscr04 ) + deallocate ( ztscr05 ) + deallocate ( ztscr06 ) + deallocate ( ztscr07 ) + deallocate ( ztscr08 ) + deallocate ( ztscr09 ) + deallocate ( ztscr10 ) + deallocate ( ztscr11 ) + deallocate ( ztscr12 ) + deallocate ( ztscr13 ) + deallocate ( ztscr14 ) + deallocate ( ztscr15 ) + deallocate ( ztscr16 ) + deallocate ( ztscr17 ) + deallocate ( ztscr18 ) + deallocate ( ztscr19 ) + deallocate ( ztscr20 ) + deallocate ( ztscr21 ) + + if ( l_silhs_out ) then + ! De-allocate all stats_lh_zt variables + deallocate( stats_lh_zt%z ) + + deallocate( stats_lh_zt%accum_field_values ) + + deallocate( stats_lh_zt%accum_num_samples ) + deallocate( stats_lh_zt%l_in_update ) + + + deallocate( stats_lh_zt%file%var ) + deallocate( stats_lh_zt%file%z ) + deallocate( stats_lh_zt%file%rlat ) + deallocate( stats_lh_zt%file%rlon ) + + ! De-allocate all stats_lh_sfc variables + deallocate( stats_lh_sfc%z ) + + deallocate( stats_lh_sfc%accum_field_values ) + + deallocate( stats_lh_sfc%accum_num_samples ) + deallocate( stats_lh_sfc%l_in_update ) + + + deallocate( stats_lh_sfc%file%var ) + deallocate( stats_lh_sfc%file%z ) + deallocate( stats_lh_sfc%file%rlat ) + deallocate( stats_lh_sfc%file%rlon ) + end if ! l_silhs_out + + ! De-allocate all stats_zm variables + deallocate( stats_zm%z ) + + deallocate( stats_zm%accum_field_values ) + deallocate( stats_zm%accum_num_samples ) + + deallocate( stats_zm%file%var ) + deallocate( stats_zm%file%z ) + deallocate( stats_zm%file%rlat ) + deallocate( stats_zm%file%rlon ) + deallocate( stats_zm%l_in_update ) + + deallocate ( zmscr01 ) + deallocate ( zmscr02 ) + deallocate ( zmscr03 ) + deallocate ( zmscr04 ) + deallocate ( zmscr05 ) + deallocate ( zmscr06 ) + deallocate ( zmscr07 ) + deallocate ( zmscr08 ) + deallocate ( zmscr09 ) + deallocate ( zmscr10 ) + deallocate ( zmscr11 ) + deallocate ( zmscr12 ) + deallocate ( zmscr13 ) + deallocate ( zmscr14 ) + deallocate ( zmscr15 ) + deallocate ( zmscr16 ) + deallocate ( zmscr17 ) + + if ( l_output_rad_files ) then + ! De-allocate all stats_rad_zt variables + deallocate( stats_rad_zt%z ) + + deallocate( stats_rad_zt%accum_field_values ) + deallocate( stats_rad_zt%accum_num_samples ) + + deallocate( stats_rad_zt%file%var ) + deallocate( stats_rad_zt%file%z ) + deallocate( stats_rad_zt%file%rlat ) + deallocate( stats_rad_zt%file%rlon ) + deallocate( stats_rad_zt%l_in_update ) + + ! De-allocate all stats_rad_zm variables + deallocate( stats_rad_zm%z ) + + deallocate( stats_rad_zm%accum_field_values ) + deallocate( stats_rad_zm%accum_num_samples ) + + deallocate( stats_rad_zm%file%var ) + deallocate( stats_rad_zm%file%z ) + deallocate( stats_rad_zm%l_in_update ) + + end if ! l_output_rad_files + + ! De-allocate all stats_sfc variables + deallocate( stats_sfc%z ) + + deallocate( stats_sfc%accum_field_values ) + deallocate( stats_sfc %accum_num_samples ) + deallocate( stats_sfc%l_in_update ) + + deallocate( stats_sfc%file%var ) + deallocate( stats_sfc%file%z ) + deallocate( stats_sfc%file%rlat ) + deallocate( stats_sfc%file%rlon ) + + ! De-allocate scalar indices + deallocate( isclrm ) + deallocate( isclrm_f ) + deallocate( iedsclrm ) + deallocate( iedsclrm_f ) + deallocate( isclrprtp ) + deallocate( isclrp2 ) + deallocate( isclrpthvp ) + deallocate( isclrpthlp ) + deallocate( isclrprcp ) + deallocate( iwpsclrp ) + deallocate( iwp2sclrp ) + deallocate( iwpsclrp2 ) + deallocate( iwpsclrprtp ) + deallocate( iwpsclrpthlp ) + deallocate( iwpedsclrp ) + + ! De-allocate hyderometeor statistical variables + deallocate( icorr_w_hm_ov_adj ) + deallocate( ihm1 ) + deallocate( ihm2 ) + deallocate( imu_hm_1 ) + deallocate( imu_hm_2 ) + deallocate( imu_hm_1_n ) + deallocate( imu_hm_2_n ) + deallocate( isigma_hm_1 ) + deallocate( isigma_hm_2 ) + deallocate( isigma_hm_1_n ) + deallocate( isigma_hm_2_n ) + deallocate( icorr_w_hm_1 ) + deallocate( icorr_w_hm_2 ) + deallocate( icorr_chi_hm_1 ) + deallocate( icorr_chi_hm_2 ) + deallocate( icorr_eta_hm_1 ) + deallocate( icorr_eta_hm_2 ) + deallocate( icorr_Ncn_hm_1 ) + deallocate( icorr_Ncn_hm_2 ) + deallocate( icorr_hmx_hmy_1 ) + deallocate( icorr_hmx_hmy_2 ) + deallocate( icorr_w_hm_1_n ) + deallocate( icorr_w_hm_2_n ) + deallocate( icorr_chi_hm_1_n ) + deallocate( icorr_chi_hm_2_n ) + deallocate( icorr_eta_hm_1_n ) + deallocate( icorr_eta_hm_2_n ) + deallocate( icorr_Ncn_hm_1_n ) + deallocate( icorr_Ncn_hm_2_n ) + deallocate( icorr_hmx_hmy_1_n ) + deallocate( icorr_hmx_hmy_2_n ) + deallocate( ihmp2_zt ) + deallocate( iwp2hmp ) + deallocate( ihydrometp2 ) + deallocate( iwphydrometp ) + deallocate( irtphmp ) + deallocate( ithlphmp ) + deallocate( iK_hm ) + end if ! l_stats + + + return + end subroutine stats_finalize + +!=============================================================================== + +!----------------------------------------------------------------------- +subroutine stats_check_num_samples( stats_grid, l_error ) + +! Description: +! Ensures that each variable in a stats grid is sampled the correct +! number of times. +! References: +! None +!----------------------------------------------------------------------- + + use constants_clubb, only: & + fstderr ! Constant + + use stats_type, only: & + stats ! Type + + use stats_variables, only: & + stats_tsamp, & ! Variable(s) + stats_tout + + use error_code, only: & + clubb_at_least_debug_level ! Procedure + + implicit none + + ! Input Variables + type (stats), intent(in) :: & + stats_grid ! Grid type [grid] + + ! Input/Output Variables + logical, intent(inout) :: & + l_error ! Indicates an error [boolean] + + ! Local Variables + integer :: ivar, kvar ! Loop variable [index] + + logical :: l_proper_sample + +!----------------------------------------------------------------------- + + !----- Begin Code ----- + + ! Look for errors by checking the number of sampling points + ! for each variable in the statistics grid at each vertical level. + do ivar = 1, stats_grid%num_output_fields + do kvar = 1, stats_grid%kk + + l_proper_sample = ( stats_grid %accum_num_samples(1,1,kvar,ivar) == 0 .or. & + stats_grid %accum_num_samples(1,1,kvar,ivar) == & + floor(stats_tout/stats_tsamp) ) + + if ( .not. l_proper_sample ) then + + l_error = .true. ! This will stop the run + + if ( clubb_at_least_debug_level( 1 ) ) then + write(fstderr,*) 'Possible sampling error for variable ', & + trim(stats_grid%file%var(ivar)%name), ' in stats_grid ', & + 'at k = ', kvar, & + '; stats_grid %accum_num_samples(',kvar,',',ivar,') = ', & + stats_grid %accum_num_samples(1,1,kvar,ivar) + end if ! clubb_at_lest_debug_level 1 + + + end if ! .not. l_proper_sample + + end do ! kvar = 1 .. stats_grid%kk + end do ! ivar = 1 .. stats_grid%num_output_fields + + return +end subroutine stats_check_num_samples +!----------------------------------------------------------------------- + +end module stats_clubb_utilities diff --git a/models/atm/cam/src/physics/clubb/stats_lh_sfc_module.F90 b/models/atm/cam/src/physics/clubb/stats_lh_sfc_module.F90 new file mode 100644 index 000000000000..c503821a3b30 --- /dev/null +++ b/models/atm/cam/src/physics/clubb/stats_lh_sfc_module.F90 @@ -0,0 +1,111 @@ +!----------------------------------------------------------------------- +! $Id: stats_lh_sfc_module.F90 7315 2014-09-30 20:49:54Z schemena@uwm.edu $ +!=============================================================================== + +module stats_lh_sfc_module + + + implicit none + + private ! Set Default Scope + + public :: stats_init_lh_sfc + + ! Constant parameters + integer, parameter, public :: nvarmax_lh_sfc = 10 ! Maximum variables allowed + + contains + +!----------------------------------------------------------------------- + subroutine stats_init_lh_sfc( vars_lh_sfc, l_error ) + +! Description: +! Initializes array indices for stats_lh_sfc +! References: +! None +!----------------------------------------------------------------------- + + use constants_clubb, only: & + fstderr ! Constant(s) + + use stats_variables, only: & + stats_lh_sfc ! Variable(s) + + use stats_variables, only: & + ilh_morr_snow_rate, & ! Variable(s) + ilh_vwp, & + ilh_lwp, & + ik_lh_start + + use stats_type_utilities, only: & + stat_assign ! Procedure + + implicit none + + ! External + intrinsic :: trim + + ! Input Variable + character(len= * ), dimension(nvarmax_lh_sfc), intent(in) :: vars_lh_sfc + + ! Input / Output Variable + logical, intent(inout) :: l_error + + ! Local Varables + integer :: i, k + + ! ---- Begin Code ---- + + ! Default initialization for array indices for stats_sfc is zero (see module + ! stats_variables) + + ! Assign pointers for statistics variables stats_sfc + + k = 1 + do i = 1, stats_lh_sfc%num_output_fields + + select case ( trim( vars_lh_sfc(i) ) ) + + case ( 'lh_morr_snow_rate' ) + ilh_morr_snow_rate = k + call stat_assign( var_index=ilh_morr_snow_rate, var_name="lh_morr_snow_rate", & + var_description="Snow+Ice+Graupel fallout rate from Morrison scheme [mm/day]", & + var_units="mm/day", l_silhs=.true., grid_kind=stats_lh_sfc ) + k = k + 1 + + case ( 'lh_vwp' ) + ilh_vwp = k + call stat_assign( var_index=ilh_vwp, var_name="lh_vwp", & + var_description="Vapor water path [kg/m^2]", var_units="kg/m^2", l_silhs=.true., & + grid_kind=stats_lh_sfc ) + k = k + 1 + + case ( 'lh_lwp' ) + ilh_lwp = k + call stat_assign( var_index=ilh_lwp, var_name="lh_lwp", & + var_description="Liquid water path [kg/m^2]", var_units="kg/m^2", l_silhs=.true., & + grid_kind=stats_lh_sfc ) + k = k + 1 + + case ( 'k_lh_start' ) + ik_lh_start = k + call stat_assign( var_index=ik_lh_start, var_name="k_lh_start", & + var_description="Index of height level for SILHS sampling preferentially within & + &cloud [integer]", var_units="integer", l_silhs=.true., & + grid_kind=stats_lh_sfc ) + k = k + 1 + + case default + write(fstderr,*) 'Error: unrecognized variable in vars_lh_sfc: ', & + trim( vars_lh_sfc(i) ) + l_error = .true. ! This will stop the run. + + end select + + end do ! i = 1, stats_lh_sfc%num_output_fields + + return + end subroutine stats_init_lh_sfc + +end module stats_lh_sfc_module + diff --git a/models/atm/cam/src/physics/clubb/stats_lh_zt_module.F90 b/models/atm/cam/src/physics/clubb/stats_lh_zt_module.F90 new file mode 100644 index 000000000000..8a6e710ea609 --- /dev/null +++ b/models/atm/cam/src/physics/clubb/stats_lh_zt_module.F90 @@ -0,0 +1,630 @@ +!----------------------------------------------------------------------- +! $Id: stats_lh_zt_module.F90 7315 2014-09-30 20:49:54Z schemena@uwm.edu $ +!=============================================================================== +module stats_lh_zt_module + + implicit none + + private ! Default Scope + + public :: stats_init_lh_zt + +! Constant parameters + integer, parameter, public :: nvarmax_lh_zt = 100 ! Maximum variables allowed + + contains + +!----------------------------------------------------------------------- + subroutine stats_init_lh_zt( vars_lh_zt, l_error ) + +! Description: +! Initializes array indices for stats_zt + +! Note: +! All code that is within subroutine stats_init_zt, including variable +! allocation code, is not called if l_stats is false. This subroutine is +! called only when l_stats is true. + +!----------------------------------------------------------------------- + + use constants_clubb, only: & + fstderr ! Constant(s) + + use stats_variables, only: & + stats_lh_zt ! Variable + + use stats_variables, only: & + iAKm, & ! Variable(s) + ilh_AKm, & + iAKstd, & + iAKstd_cld, & + iAKm_rcm, & + iAKm_rcc + + use stats_variables, only: & + ilh_thlm_mc, & ! Variable(s) + ilh_rvm_mc, & + ilh_rcm_mc, & + ilh_Ncm_mc, & + ilh_rrm_mc, & + ilh_Nrm_mc, & + ilh_rsm_mc, & + ilh_Nsm_mc, & + ilh_rgm_mc, & + ilh_Ngm_mc, & + ilh_rim_mc, & + ilh_Nim_mc, & + ilh_Vrr, & + ilh_VNr, & + ilh_rcm_avg + + use stats_variables, only: & + ilh_rrm, & ! Variable(s) + ilh_Nrm, & + ilh_rim, & + ilh_Nim, & + ilh_rsm, & + ilh_Nsm, & + ilh_rgm, & + ilh_Ngm, & + ilh_thlm, & + ilh_rcm, & + ilh_Ncm, & + ilh_Ncnm, & + ilh_rvm, & + ilh_wm, & + ilh_wp2_zt, & + ilh_rcp2_zt, & + ilh_rtp2_zt, & + ilh_thlp2_zt, & + ilh_rrp2_zt, & + ilh_Nrp2_zt, & + ilh_Ncp2_zt, & + ilh_Ncnp2_zt, & + ilh_cloud_frac, & + ilh_chi, & + ilh_eta, & + ilh_chip2, & + ilh_rrm_auto, & + ilh_rrm_accr, & + ilh_rrm_evap, & + ilh_Nrm_auto, & + ilh_Nrm_cond + + use stats_variables, only: & + ilh_cloud_frac_unweighted, & + ilh_precip_frac_unweighted,& + ilh_mixt_frac_unweighted + + use stats_variables, only: & + ilh_rrm_src_adj, & ! Variable(s) + ilh_rrm_cond_adj, & + ilh_Nrm_src_adj, & + ilh_Nrm_cond_adj + + use stats_variables, only: & + ilh_precip_frac, & + ilh_mixt_frac, & + ilh_m_vol_rad_rain + + use stats_type_utilities, only: & + stat_assign ! Procedure + + implicit none + + ! External + intrinsic :: trim + + ! Input Variable + character(len= * ), dimension(nvarmax_lh_zt), intent(in) :: vars_lh_zt + + ! Input / Output Variable + logical, intent(inout) :: l_error + + ! Local Varables + integer :: i, k + + ! ---- Begin Code ---- + + ! Default initialization for array indices for stats_lh_zt is zero (see module + ! stats_variables) + + ! Assign pointers for statistics variables stats_zt + + k = 1 + do i = 1, stats_lh_zt%num_output_fields + + select case ( trim( vars_lh_zt(i) ) ) + case ( 'AKm' ) ! Vince Larson 22 May 2005 + iAKm = k + call stat_assign( var_index=iAKm, var_name="AKm", & + var_description="Analytic Kessler ac [kg/kg]", var_units="kg/kg", l_silhs=.true., & + grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_AKm' ) ! Vince Larson 22 May 2005 + ilh_AKm = k + + call stat_assign( var_index=ilh_AKm, var_name="lh_AKm", & + var_description="LH Kessler estimate [kg/kg/s]", var_units="kg/kg/s", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'AKstd' ) + iAKstd = k + + call stat_assign( var_index=iAKstd, var_name="AKstd", & + var_description="Exact standard deviation of gba Kessler [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'AKstd_cld' ) + iAKstd_cld = k + + call stat_assign( var_index=iAKstd_cld, var_name="AKstd_cld", & + var_description="Exact w/in cloud std of gba Kessler [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'AKm_rcm' ) + iAKm_rcm = k + + call stat_assign( var_index=iAKm_rcm, var_name="AKm_rcm", & + var_description="Exact local gba auto based on rcm [kg/kg/s]", var_units="kg/kg/s", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'AKm_rcc' ) + iAKm_rcc = k + + call stat_assign( var_index=iAKm_rcc, var_name="AKm_rcc", & + var_description="Exact local gba based on w/in cloud rc [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rvm_mc' ) + ilh_rvm_mc = k + + call stat_assign( var_index=ilh_rvm_mc, var_name="lh_rvm_mc", & + var_description="Latin hypercube estimate of rvm_mc [kg/kg/s]", var_units="kg/kg/s", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_thlm_mc' ) + ilh_thlm_mc = k + + call stat_assign( var_index=ilh_thlm_mc, var_name="lh_thlm_mc", & + var_description="Latin hypercube estimate of thlm_mc [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rcm_mc' ) + ilh_rcm_mc = k + + call stat_assign( var_index=ilh_rcm_mc, var_name="lh_rcm_mc", & + var_description="Latin hypercube estimate of rcm_mc [kg/kg/s]", var_units="kg/kg/s", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Ncm_mc' ) + ilh_Ncm_mc = k + + call stat_assign( var_index=ilh_Ncm_mc, var_name="lh_Ncm_mc", & + var_description="Latin hypercube estimate of Ncm_mc [kg/kg/s]", var_units="kg/kg/s", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rrm_mc' ) + ilh_rrm_mc = k + + call stat_assign( var_index=ilh_rrm_mc, var_name="lh_rrm_mc", & + var_description="Latin hypercube estimate of rrm_mc [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Nrm_mc' ) + ilh_Nrm_mc = k + + call stat_assign( var_index=ilh_Nrm_mc, var_name="lh_Nrm_mc", & + var_description="Latin hypercube estimate of Nrm_mc [kg/kg/s]", var_units="kg/kg/s", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case('lh_rsm_mc') + ilh_rsm_mc = k + + call stat_assign( var_index=ilh_rsm_mc, var_name="lh_rsm_mc", & + var_description="Latin hypercube estimate of rsm_mc [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Nsm_mc' ) + ilh_Nsm_mc = k + + call stat_assign( var_index=ilh_Nsm_mc, var_name="lh_Nsm_mc", & + var_description="Latin hypercube estimate of Nsm_mc [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rgm_mc' ) + ilh_rgm_mc = k + + call stat_assign( var_index=ilh_rgm_mc, var_name="lh_rgm_mc", & + var_description="Latin hypercube estimate of rgm_mc [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Ngm_mc' ) + ilh_Ngm_mc = k + + call stat_assign( var_index=ilh_Ngm_mc, var_name="lh_Ngm_mc", & + var_description="Latin hypercube estimate of Ngm_mc [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rim_mc' ) + ilh_rim_mc = k + + call stat_assign( var_index=ilh_rim_mc, var_name="lh_rim_mc", & + var_description="Latin hypercube estimate of rim_mc [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Nim_mc' ) + ilh_Nim_mc = k + + call stat_assign( var_index=ilh_Nim_mc, var_name="lh_Nim_mc", & + var_description="Latin hypercube estimate of Nim_mc [kg/kg/s]", var_units="kg/kg/s", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Vrr' ) + ilh_Vrr = k + + call stat_assign( var_index=ilh_Vrr, var_name="lh_Vrr", & + var_description="Latin hypercube estimate of rrm sedimentation velocity [m/s]", & + var_units="m/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_VNr' ) + ilh_VNr = k + + call stat_assign( var_index=ilh_VNr, var_name="lh_VNr", & + var_description="Latin hypercube estimate of Nrm sedimentation velocity [m/s]", & + var_units="m/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rcm_avg' ) + ilh_rcm_avg = k + + call stat_assign( var_index=ilh_rcm_avg, var_name="lh_rcm_avg", & + var_description="Latin hypercube average estimate of rcm [kg/kg]", & + var_units="kg/kg", l_silhs=.true., grid_kind=stats_lh_zt ) + + k = k + 1 + + case ( 'lh_rrm' ) + ilh_rrm = k + + call stat_assign( var_index=ilh_rrm, var_name="lh_rrm", & + var_description="Latin hypercube estimate of rrm [kg/kg]", var_units="kg/kg", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Nrm' ) + ilh_Nrm = k + + call stat_assign( var_index=ilh_Nrm, var_name="lh_Nrm", & + var_description="Latin hypercube estimate of Nrm [count/kg]", var_units="count/kg", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rim' ) + ilh_rim = k + + call stat_assign( var_index=ilh_rim, var_name="lh_rim", & + var_description="Latin hypercube estimate of rim [kg/kg]", var_units="kg/kg", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Nim' ) + ilh_Nim = k + + call stat_assign( var_index=ilh_Nim, var_name="lh_Nim", & + var_description="Latin hypercube estimate of Nim [count/kg]", var_units="count/kg", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rsm' ) + ilh_rsm = k + + call stat_assign( var_index=ilh_rsm, var_name="lh_rsm", & + var_description="Latin hypercube estimate of rsm [kg/kg]", var_units="kg/kg", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Nsm' ) + ilh_Nsm = k + + call stat_assign( var_index=ilh_Nsm, var_name="lh_Nsm", & + var_description="Latin hypercube estimate of Nsm [count/kg]", & + var_units="count/kg", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + + case ( 'lh_rgm' ) + ilh_rgm = k + + call stat_assign( var_index=ilh_rgm, var_name="lh_rgm", & + var_description="Latin hypercube estimate of rgm [kg/kg]", var_units="kg/kg", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Ngm' ) + ilh_Ngm = k + + call stat_assign( var_index=ilh_Ngm, var_name="lh_Ngm", & + var_description="Latin hypercube estimate of Ngm [kg/kg]", var_units="kg/kg", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_thlm' ) + ilh_thlm = k + + call stat_assign( var_index=ilh_thlm, var_name="lh_thlm", & + var_description="Latin hypercube estimate of thlm [K]", var_units="K", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rcm' ) + ilh_rcm = k + + call stat_assign( var_index=ilh_rcm, var_name="lh_rcm", & + var_description="Latin hypercube estimate of rcm [kg/kg]", var_units="kg/kg", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Ncm' ) + ilh_Ncm = k + + call stat_assign( var_index=ilh_Ncm, var_name="lh_Ncm", & + var_description="Latin hypercube estimate of Ncm [count/kg]", var_units="count/kg", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Ncnm' ) + ilh_Ncnm = k + + call stat_assign( var_index=ilh_Ncnm, var_name="lh_Ncnm", & + var_description="Latin hypercube estimate of Ncnm [count/kg]", var_units="count/kg", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + + case ( 'lh_rvm' ) + ilh_rvm = k + + call stat_assign( var_index=ilh_rvm, var_name="lh_rvm", & + var_description="Latin hypercube estimate of rvm [kg/kg]", var_units="kg/kg", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_wm' ) + ilh_wm = k + + call stat_assign( var_index=ilh_wm, var_name="lh_wm", & + var_description="Latin hypercube estimate of vertical velocity [m/s]", & + var_units="m/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_cloud_frac' ) + ilh_cloud_frac = k + + ! Note: count is the udunits compatible unit + call stat_assign( var_index=ilh_cloud_frac, var_name="lh_cloud_frac", & + var_description="Latin hypercube estimate of cloud fraction [count]", & + var_units="count", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_cloud_frac_unweighted' ) + ilh_cloud_frac_unweighted = k + + call stat_assign( var_index=ilh_cloud_frac_unweighted, & + var_name="lh_cloud_frac_unweighted", var_description="Unweighted fraction of & + &silhs sample points that are in cloud [-]", var_units="-", l_silhs=.false., & + grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_chi' ) + ilh_chi = k + call stat_assign( var_index=ilh_chi, var_name="lh_chi", & + var_description="Latin hypercube estimate of Mellor's s (extended liq) [kg/kg]", & + var_units="kg/kg", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_eta' ) + ilh_eta = k + call stat_assign( var_index=ilh_eta, var_name="lh_eta", & + var_description="Latin hypercube estimate of Mellor's t [kg/kg]", var_units="kg/kg", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_chip2' ) + ilh_chip2 = k + call stat_assign( var_index=ilh_chip2, var_name="lh_chip2", & + var_description="Latin hypercube estimate of variance of chi(s) [kg/kg]", & + var_units="kg/kg", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_wp2_zt' ) + ilh_wp2_zt = k + call stat_assign( var_index=ilh_wp2_zt, var_name="lh_wp2_zt", & + var_description="Variance of the latin hypercube estimate of w [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Ncnp2_zt' ) + ilh_Ncnp2_zt = k + call stat_assign( var_index=ilh_Ncnp2_zt, var_name="lh_Ncnp2_zt", & + var_description="Variance of the latin hypercube estimate of Ncn [count^2/kg^2]", & + var_units="count^2/kg^2", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Ncp2_zt' ) + ilh_Ncp2_zt = k + call stat_assign( var_index=ilh_Ncp2_zt, var_name="lh_Ncp2_zt", & + var_description="Variance of the latin hypercube estimate of Nc [count^2/kg^2]", & + var_units="count^2/kg^2", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Nrp2_zt' ) + ilh_Nrp2_zt = k + call stat_assign( var_index=ilh_Nrp2_zt, var_name="lh_Nrp2_zt", & + var_description="Variance of the latin hypercube estimate of Nr [count^2/kg^2]", & + var_units="count^2/kg^2", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rcp2_zt' ) + ilh_rcp2_zt = k + call stat_assign( var_index=ilh_rcp2_zt, var_name="lh_rcp2_zt", & + var_description="Variance of the latin hypercube estimate of rc [kg^2/kg^2]", & + var_units="kg^2/kg^2", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rtp2_zt' ) + ilh_rtp2_zt = k + call stat_assign( var_index=ilh_rtp2_zt, var_name="lh_rtp2_zt", & + var_description="Variance of the latin hypercube estimate of rt [kg^2/kg^2]", & + var_units="kg^2/kg^2", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_thlp2_zt' ) + ilh_thlp2_zt = k + call stat_assign( var_index=ilh_thlp2_zt, var_name="lh_thlp2_zt", & + var_description="Variance of the latin hypercube estimate of thl [K^2]", & + var_units="K^2", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rrp2_zt' ) + ilh_rrp2_zt = k + call stat_assign( var_index=ilh_rrp2_zt, var_name="lh_rrp2_zt", & + var_description="Variance of the latin hypercube estimate of rr [kg^2/kg^2]", & + var_units="kg^2/kg^2", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rrm_auto' ) + ilh_rrm_auto = k + call stat_assign( var_index=ilh_rrm_auto, var_name="lh_rrm_auto", & + var_description="Latin hypercube estimate of autoconversion [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rrm_accr' ) + ilh_rrm_accr = k + call stat_assign( var_index=ilh_rrm_accr, var_name="lh_rrm_accr", & + var_description="Latin hypercube estimate of accretion [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rrm_evap' ) + ilh_rrm_evap = k + call stat_assign( var_index=ilh_rrm_evap, var_name="lh_rrm_evap", & + var_description="Latin hypercube estimate of evaporation [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Nrm_auto' ) + ilh_Nrm_auto = k + call stat_assign( var_index=ilh_Nrm_auto, var_name="lh_Nrm_auto", & + var_description="Latin hypercube estimate of Nrm autoconversion [num/kg/s]", & + var_units="num/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Nrm_cond' ) + ilh_Nrm_cond = k + call stat_assign( var_index=ilh_Nrm_cond, var_name="lh_Nrm_cond", & + var_description="Latin hypercube estimate of Nrm evaporation [num/kg/s]", & + var_units="num/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rrm_src_adj' ) + ilh_rrm_src_adj = k + call stat_assign( var_index=ilh_rrm_src_adj, var_name="lh_rrm_src_adj", & + var_description="Latin hypercube estimate of source adjustment (KK only!) [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rrm_cond_adj' ) + ilh_rrm_cond_adj = k + call stat_assign( var_index=ilh_rrm_cond_adj, var_name="lh_rrm_cond_adj", & + var_description="Latin hypercube estimate of evap adjustment (KK only!) [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Nrm_src_adj' ) + ilh_Nrm_src_adj = k + call stat_assign( var_index=ilh_Nrm_src_adj, var_name="lh_Nrm_src_adj", & + var_description="Latin hypercube estimate of Nrm source adjustment (KK only!) & + &[kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Nrm_cond_adj' ) + ilh_Nrm_cond_adj = k + call stat_assign( var_index=ilh_Nrm_cond_adj, var_name="lh_Nrm_cond_adj", & + var_description="Latin hypercube estimate of Nrm evap adjustment (KK only!) & + &[kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_precip_frac' ) + ilh_precip_frac = k + call stat_assign( var_index=ilh_precip_frac, var_name="lh_precip_frac", & + var_description="Latin hypercube estimate of precipitation fraction [-]", & + var_units="-", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_precip_frac_unweighted' ) + ilh_precip_frac_unweighted = k + call stat_assign( var_index=ilh_precip_frac_unweighted, & + var_name="lh_precip_frac_unweighted", & + var_description="Unweighted fraction of sample points in precipitation [-]", & + var_units="-", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_mixt_frac' ) + ilh_mixt_frac = k + call stat_assign( var_index=ilh_mixt_frac, var_name="lh_mixt_frac", & + var_description="Latin hypercube estimate of mixture fraction (weight of 1st PDF & + &component [-]", & + var_units="-", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_mixt_frac_unweighted' ) + ilh_mixt_frac_unweighted = k + call stat_assign( var_index=ilh_mixt_frac_unweighted, var_name="lh_mixt_frac_unweighted", & + var_description="Unweighted fraction of sample points in first PDF component [-]", & + var_units="-", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_m_vol_rad_rain' ) + ilh_m_vol_rad_rain = k + call stat_assign( var_index=ilh_m_vol_rad_rain, var_name="lh_m_vol_rad_rain", & + var_description="SILHS est. of rain radius", var_units="m", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case default + + write(fstderr,*) 'Error: unrecognized variable in vars_lh_zt: ', trim( vars_lh_zt(i) ) + + l_error = .true. ! This will stop the run. + + end select + + end do ! i = 1, stats_lh_zt%num_output_fields + + return + end subroutine stats_init_lh_zt + +end module stats_lh_zt_module diff --git a/models/atm/cam/src/physics/clubb/stats_rad_zm.F90 b/models/atm/cam/src/physics/clubb/stats_rad_zm.F90 deleted file mode 100644 index 79498a3fa8dd..000000000000 --- a/models/atm/cam/src/physics/clubb/stats_rad_zm.F90 +++ /dev/null @@ -1,157 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: stats_rad_zm.F90 4032 2009-08-17 21:45:29Z senkbeil@uwm.edu $ - -module stats_rad_zm - - implicit none - - private ! Default Scope - - public :: stats_init_rad_zm - -! Constant parameters - integer, parameter, public :: nvarmax_rad_zm = 250 ! Maximum variables allowed - - contains - -!----------------------------------------------------------------------- - subroutine stats_init_rad_zm( vars_rad_zm, l_error ) - -! Description: -! Initializes array indices for rad_zm variables -!----------------------------------------------------------------------- - - use constants_clubb, only: & - fstderr ! Constant(s) - - use stats_variables, only: & - rad_zm, & - iFrad_LW_rad, & ! Variable(s) - iFrad_SW_rad, & - iFrad_SW_up_rad, & - iFrad_LW_up_rad, & - iFrad_SW_down_rad, & - iFrad_LW_down_rad - - use stats_variables, only: & - ifulwcl, ifdlwcl, ifdswcl, ifuswcl ! Variable(s) - - use stats_type, only: & - stat_assign ! Procedure - - - implicit none - - ! Input Variable - character(len= * ), dimension(nvarmax_rad_zm), intent(in) :: vars_rad_zm - - ! Input/Output Variable - logical, intent(inout) :: l_error - - ! Local Varables - integer :: i, k - - ! ---- Begin Code ---- - - ! Default initialization for array indices for rad_zm - - iFrad_LW_rad = 0 - iFrad_SW_rad = 0 - iFrad_SW_up_rad = 0 - iFrad_LW_up_rad = 0 - iFrad_SW_down_rad = 0 - iFrad_LW_down_rad = 0 - - ifulwcl = 0 - ifdlwcl = 0 - ifdswcl = 0 - ifuswcl = 0 - -! Assign pointers for statistics variables rad_zm - - k = 1 - do i=1,rad_zm%nn - - select case ( trim(vars_rad_zm(i)) ) - - case('fulwcl') - ifulwcl = k - call stat_assign( ifulwcl, "fulwcl", & - "Upward clear-sky LW flux [W/m^2]", "W/m^2", rad_zm ) - k = k + 1 - - case( 'fdlwcl' ) - ifdlwcl = k - call stat_assign( ifdlwcl, "fdlwcl", & - "Downward clear-sky LW flux [W/m^2]", "W/m^2", rad_zm ) - k = k + 1 - - case( 'fdswcl' ) - ifdswcl = k - call stat_assign( ifdswcl, "fdswcl", & - "Downward clear-sky SW flux [W/m^2]", "W/m^2", rad_zm ) - k = k + 1 - - case( 'fuswcl' ) - ifuswcl = k - call stat_assign( ifuswcl, "fuswcl", & - "Upward clear-sky SW flux [W/m^2]", "W/m^2", rad_zm ) - k = k + 1 - - case ('Frad_LW_rad') - iFrad_LW_rad = k - - call stat_assign( iFrad_LW_rad, "Frad_LW_rad", & - "Net long-wave radiative flux [W/m^2]", "W/m^2", rad_zm ) - k = k + 1 - - case ('Frad_SW_rad') - iFrad_SW_rad = k - - call stat_assign( iFrad_SW_rad, "Frad_SW_rad", & - "Net short-wave radiative flux [W/m^2]", "W/m^2", rad_zm ) - k = k + 1 - - case ('Frad_SW_up_rad') - iFrad_SW_up_rad = k - - call stat_assign( iFrad_SW_up_rad, "Frad_SW_up_rad", & - "Short-wave upwelling radiative flux [W/m^2]", "W/m^2", rad_zm ) - k = k + 1 - - case ('Frad_LW_up_rad') - iFrad_LW_up_rad = k - - call stat_assign( iFrad_LW_up_rad, "Frad_LW_up_rad", & - "Long-wave upwelling radiative flux [W/m^2]", "W/m^2", rad_zm ) - k = k + 1 - - case ('Frad_SW_down_rad') - iFrad_SW_down_rad = k - - call stat_assign( iFrad_SW_down_rad, "Frad_SW_down_rad", & - "Short-wave downwelling radiative flux [W/m^2]", "W/m^2", rad_zm ) - k = k + 1 - - case ('Frad_LW_down_rad') - iFrad_LW_down_rad = k - - call stat_assign( iFrad_LW_down_rad, "Frad_LW_down_rad", & - "Long-wave downwelling radiative flux [W/m^2]", "W/m^2", rad_zm ) - k = k + 1 - - case default - - write(fstderr,*) 'Error: unrecognized variable in vars_rad_zm: ', trim( vars_rad_zm(i) ) - - l_error = .true. ! This will stop the run. - - - end select - - end do - - return - end subroutine stats_init_rad_zm - -end module stats_rad_zm diff --git a/models/atm/cam/src/physics/clubb/stats_rad_zm_module.F90 b/models/atm/cam/src/physics/clubb/stats_rad_zm_module.F90 new file mode 100644 index 000000000000..d36d2eeb0928 --- /dev/null +++ b/models/atm/cam/src/physics/clubb/stats_rad_zm_module.F90 @@ -0,0 +1,168 @@ +!----------------------------------------------------------------------- +! $Id: stats_rad_zm_module.F90 7315 2014-09-30 20:49:54Z schemena@uwm.edu $ +!=============================================================================== + +module stats_rad_zm_module + + implicit none + + private ! Default Scope + + public :: stats_init_rad_zm + +! Constant parameters + integer, parameter, public :: nvarmax_rad_zm = 250 ! Maximum variables allowed + + contains + +!----------------------------------------------------------------------- + subroutine stats_init_rad_zm( vars_rad_zm, l_error ) + +! Description: +! Initializes array indices for stats_rad_zm variables +!----------------------------------------------------------------------- + + use constants_clubb, only: & + fstderr ! Constant(s) + + use stats_variables, only: & + stats_rad_zm, & + iFrad_LW_rad, & ! Variable(s) + iFrad_SW_rad, & + iFrad_SW_up_rad, & + iFrad_LW_up_rad, & + iFrad_SW_down_rad, & + iFrad_LW_down_rad + + use stats_variables, only: & + ifulwcl, ifdlwcl, ifdswcl, ifuswcl ! Variable(s) + + use stats_type_utilities, only: & + stat_assign ! Procedure + + + implicit none + + ! Input Variable + character(len= * ), dimension(nvarmax_rad_zm), intent(in) :: vars_rad_zm + + ! Input/Output Variable + logical, intent(inout) :: l_error + + ! Local Varables + integer :: i, k + + ! ---- Begin Code ---- + + ! Default initialization for array indices for stats_rad_zm + + iFrad_LW_rad = 0 + iFrad_SW_rad = 0 + iFrad_SW_up_rad = 0 + iFrad_LW_up_rad = 0 + iFrad_SW_down_rad = 0 + iFrad_LW_down_rad = 0 + + ifulwcl = 0 + ifdlwcl = 0 + ifdswcl = 0 + ifuswcl = 0 + +! Assign pointers for statistics variables stats_rad_zm + + k = 1 + do i=1,stats_rad_zm%num_output_fields + + select case ( trim(vars_rad_zm(i)) ) + + case('fulwcl') + ifulwcl = k + call stat_assign( var_index=ifulwcl, var_name="fulwcl", & + var_description="Upward clear-sky LW flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_rad_zm ) + k = k + 1 + + case( 'fdlwcl' ) + ifdlwcl = k + call stat_assign( var_index=ifdlwcl, var_name="fdlwcl", & + var_description="Downward clear-sky LW flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_rad_zm ) + k = k + 1 + + case( 'fdswcl' ) + ifdswcl = k + call stat_assign( var_index=ifdswcl, var_name="fdswcl", & + var_description="Downward clear-sky SW flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_rad_zm ) + k = k + 1 + + case( 'fuswcl' ) + ifuswcl = k + call stat_assign( var_index=ifuswcl, var_name="fuswcl", & + var_description="Upward clear-sky SW flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_rad_zm ) + k = k + 1 + + case ('Frad_LW_rad') + iFrad_LW_rad = k + + call stat_assign( var_index=iFrad_LW_rad, var_name="Frad_LW_rad", & + var_description="Net long-wave radiative flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_rad_zm ) + k = k + 1 + + case ('Frad_SW_rad') + iFrad_SW_rad = k + + call stat_assign( var_index=iFrad_SW_rad, var_name="Frad_SW_rad", & + var_description="Net short-wave radiative flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_rad_zm ) + k = k + 1 + + case ('Frad_SW_up_rad') + iFrad_SW_up_rad = k + + call stat_assign( var_index=iFrad_SW_up_rad, var_name="Frad_SW_up_rad", & + var_description="Short-wave upwelling radiative flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_rad_zm ) + k = k + 1 + + case ('Frad_LW_up_rad') + iFrad_LW_up_rad = k + + call stat_assign( var_index=iFrad_LW_up_rad, var_name="Frad_LW_up_rad", & + var_description="Long-wave upwelling radiative flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_rad_zm ) + k = k + 1 + + case ('Frad_SW_down_rad') + iFrad_SW_down_rad = k + + call stat_assign( var_index=iFrad_SW_down_rad, var_name="Frad_SW_down_rad", & + var_description="Short-wave downwelling radiative flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_rad_zm ) + k = k + 1 + + case ('Frad_LW_down_rad') + iFrad_LW_down_rad = k + + call stat_assign( var_index=iFrad_LW_down_rad, var_name="Frad_LW_down_rad", & + var_description="Long-wave downwelling radiative flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_rad_zm ) + k = k + 1 + + case default + + write(fstderr,*) 'Error: unrecognized variable in vars_rad_zm: ', trim( vars_rad_zm(i) ) + + l_error = .true. ! This will stop the run. + + + end select + + end do + + return + end subroutine stats_init_rad_zm + +end module stats_rad_zm_module diff --git a/models/atm/cam/src/physics/clubb/stats_rad_zt.F90 b/models/atm/cam/src/physics/clubb/stats_rad_zt.F90 deleted file mode 100644 index 762fa5589e19..000000000000 --- a/models/atm/cam/src/physics/clubb/stats_rad_zt.F90 +++ /dev/null @@ -1,154 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: stats_rad_zt.F90 4032 2009-08-17 21:45:29Z senkbeil@uwm.edu $ - -module stats_rad_zt - - implicit none - - private ! Default Scope - - public :: stats_init_rad_zt - - ! Constant parameters - integer, parameter, public :: nvarmax_rad_zt = 250 ! Maximum variables allowed - - contains - -!----------------------------------------------------------------------- - subroutine stats_init_rad_zt( vars_rad_zt, l_error ) - -! Description: -! Initializes array indices for zt -! -! References: -! None -!----------------------------------------------------------------------- - - use constants_clubb, only: & - fstderr ! Constant(s) - - use stats_variables, only: & - rad_zt, & - iT_in_K_rad, & ! Variable(s) - ircil_rad, & - io3l_rad, & - irsnowm_rad, & - ircm_in_cloud_rad, & - icloud_frac_rad, & - iradht_rad, & - iradht_LW_rad, & - iradht_SW_rad - - use stats_type, only: & - stat_assign ! Procedure - - implicit none - - ! Input Variable - character(len= * ), dimension(nvarmax_rad_zt), intent(in) :: vars_rad_zt - - ! Input/Output Variable - logical, intent(inout) :: l_error - - ! Local Varables - integer :: i, k - - ! ---- Begin Code ---- - - ! Default initialization for array indices for rad_zt - - iT_in_K_rad = 0 - ircil_rad = 0 - io3l_rad = 0 - irsnowm_rad = 0 - ircm_in_cloud_rad = 0 - icloud_frac_rad = 0 - iradht_rad = 0 - iradht_LW_rad = 0 - iradht_SW_rad = 0 - - ! Assign pointers for statistics variables rad_zt - - k = 1 - do i=1,rad_zt%nn - - select case ( trim(vars_rad_zt(i)) ) - - case ('T_in_K_rad') - iT_in_K_rad = k - - call stat_assign( iT_in_K_rad, "T_in_K_rad", & - "Temperature [K]", "K", rad_zt ) - k = k + 1 - - case ('rcil_rad') - ircil_rad = k - - call stat_assign( ircil_rad, "rcil_rad", & - "Ice mixing ratio [kg/kg]", "kg/kg", rad_zt ) - k = k + 1 - - case ('o3l_rad') - io3l_rad = k - - call stat_assign( io3l_rad, "o3l_rad", & - "Ozone mixing ratio [kg/kg]", "kg/kg", rad_zt ) - k = k + 1 - - case ('rsnowm_rad') - irsnowm_rad = k - - call stat_assign( irsnowm_rad, "rsnowm_rad", & - "Snow water mixing ratio [kg/kg]", "kg/kg", rad_zt ) - k = k + 1 - - case ('rcm_in_cloud_rad') - ircm_in_cloud_rad = k - - call stat_assign( ircm_in_cloud_rad, "rcm_in_cloud_rad", & - "rcm in cloud layer [kg/kg]", "kg/kg", rad_zt ) - k = k + 1 - - case ('cloud_frac_rad') - icloud_frac_rad = k - - call stat_assign( icloud_frac_rad, "cloud_frac_rad", & - "Cloud fraction (between 0 and 1) [-]", "count", rad_zt ) - k = k + 1 - - case ('radht_rad') - iradht_rad = k - - call stat_assign( iradht_rad, "radht_rad", & - "Total radiative heating rate [K/s]", "K/s", rad_zt ) - k = k + 1 - - case ('radht_LW_rad') - iradht_LW_rad = k - - call stat_assign( iradht_LW_rad, "radht_LW_rad", & - "Long-wave radiative heating rate [K/s]", "K/s", rad_zt ) - k = k + 1 - - case ('radht_SW_rad') - iradht_SW_rad = k - - call stat_assign( iradht_SW_rad, "radht_SW_rad", & - "Short-wave radiative heating rate [K/s]", "K/s", rad_zt ) - k = k + 1 - - case default - - write(fstderr,*) 'Error: unrecognized variable in vars_rad_zt: ', trim( vars_rad_zt(i) ) - - l_error = .true. ! This will stop the run. - - - end select - - end do - - return - end subroutine stats_init_rad_zt - -end module stats_rad_zt diff --git a/models/atm/cam/src/physics/clubb/stats_rad_zt_module.F90 b/models/atm/cam/src/physics/clubb/stats_rad_zt_module.F90 new file mode 100644 index 000000000000..0dc65d20f005 --- /dev/null +++ b/models/atm/cam/src/physics/clubb/stats_rad_zt_module.F90 @@ -0,0 +1,195 @@ +!----------------------------------------------------------------------- +! $Id: stats_rad_zt_module.F90 7315 2014-09-30 20:49:54Z schemena@uwm.edu $ +!=============================================================================== + +module stats_rad_zt_module + + implicit none + + private ! Default Scope + + public :: stats_init_rad_zt + + ! Constant parameters + integer, parameter, public :: nvarmax_rad_zt = 250 ! Maximum variables allowed + + contains + +!----------------------------------------------------------------------- + subroutine stats_init_rad_zt( vars_rad_zt, l_error ) + +! Description: +! Initializes array indices for stats_zt +! +! References: +! None +!----------------------------------------------------------------------- + + use constants_clubb, only: & + fstderr ! Constant(s) + + use stats_variables, only: & + stats_rad_zt, & + iT_in_K_rad, & ! Variable(s) + ircil_rad, & + io3l_rad, & + irsm_rad, & + ircm_in_cloud_rad, & + icloud_frac_rad, & + iice_supersat_frac_rad, & + iradht_rad, & + iradht_LW_rad, & + iradht_SW_rad, & + ip_in_mb_rad, & + isp_humidity_rad + + use stats_type_utilities, only: & + stat_assign ! Procedure + + implicit none + + ! Input Variable + character(len= * ), dimension(nvarmax_rad_zt), intent(in) :: vars_rad_zt + + ! Input/Output Variable + logical, intent(inout) :: l_error + + ! Local Varables + integer :: i, k + + ! ---- Begin Code ---- + + ! Default initialization for array indices for stats_rad_zt + + iT_in_K_rad = 0 + ircil_rad = 0 + io3l_rad = 0 + irsm_rad = 0 + ircm_in_cloud_rad = 0 + icloud_frac_rad = 0 + iice_supersat_frac_rad = 0 + iradht_rad = 0 + iradht_LW_rad = 0 + iradht_SW_rad = 0 + ip_in_mb_rad = 0 + isp_humidity_rad = 0 + + + ! Assign pointers for statistics variables stats_rad_zt + + k = 1 + do i=1,stats_rad_zt%num_output_fields + + select case ( trim(vars_rad_zt(i)) ) + + case ('T_in_K_rad') + iT_in_K_rad = k + + call stat_assign( var_index=iT_in_K_rad, var_name="T_in_K_rad", & + var_description="Temperature [K]", var_units="K", l_silhs=.false., & + grid_kind=stats_rad_zt ) + k = k + 1 + + case ('rcil_rad') + ircil_rad = k + + call stat_assign( var_index=ircil_rad, var_name="rcil_rad", & + var_description="Ice mixing ratio [kg/kg]", var_units="kg/kg", l_silhs=.false., & + grid_kind=stats_rad_zt ) + k = k + 1 + + case ('o3l_rad') + io3l_rad = k + + call stat_assign( var_index=io3l_rad, var_name="o3l_rad", & + var_description="Ozone mixing ratio [kg/kg]", var_units="kg/kg", l_silhs=.false., & + grid_kind=stats_rad_zt ) + k = k + 1 + + case ('rsm_rad') + irsm_rad = k + + call stat_assign( var_index=irsm_rad, var_name="rsm_rad", & + var_description="Snow water mixing ratio [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_rad_zt ) + k = k + 1 + + case ('rcm_in_cloud_rad') + ircm_in_cloud_rad = k + + call stat_assign( var_index=ircm_in_cloud_rad, var_name="rcm_in_cloud_rad", & + var_description="rcm in cloud layer [kg/kg]", var_units="kg/kg", l_silhs=.false., & + grid_kind=stats_rad_zt ) + k = k + 1 + + case ('cloud_frac_rad') + icloud_frac_rad = k + + call stat_assign( var_index=icloud_frac_rad, var_name="cloud_frac_rad", & + var_description="Cloud fraction (between 0 and 1) [-]", var_units="count", & + l_silhs=.false., grid_kind=stats_rad_zt ) + k = k + 1 + + case ('ice_supersat_frac_rad') + iice_supersat_frac_rad = k + + call stat_assign( var_index=iice_supersat_frac_rad, var_name="ice_supersat_frac_rad", & + var_description="Ice cloud fraction (between 0 and 1) [-]", var_units="count", & + l_silhs=.false., grid_kind=stats_rad_zt ) + k = k + 1 + + case ('radht_rad') + iradht_rad = k + + call stat_assign( var_index=iradht_rad, var_name="radht_rad", & + var_description="Total radiative heating rate [K/s]", var_units="K/s", & + l_silhs=.false., grid_kind=stats_rad_zt ) + k = k + 1 + + case ('radht_LW_rad') + iradht_LW_rad = k + + call stat_assign( var_index=iradht_LW_rad, var_name="radht_LW_rad", & + var_description="Long-wave radiative heating rate [K/s]", var_units="K/s", & + l_silhs=.false., grid_kind=stats_rad_zt ) + k = k + 1 + + case ('radht_SW_rad') + iradht_SW_rad = k + + call stat_assign( var_index=iradht_SW_rad, var_name="radht_SW_rad", & + var_description="Short-wave radiative heating rate [K/s]", var_units="K/s", & + l_silhs=.false., grid_kind=stats_rad_zt ) + k = k + 1 + + case ('p_in_mb_rad') + ip_in_mb_rad = k + + call stat_assign( var_index=ip_in_mb_rad, var_name="p_in_mb_rad", & + var_description="Pressure [hPa]", var_units="hPa", & + l_silhs=.false., grid_kind=stats_rad_zt ) + k = k + 1 + + case ('sp_humidity_rad') + isp_humidity_rad = k + + call stat_assign( var_index=isp_humidity_rad, var_name="sp_humidity_rad", & + var_description="Specific humidity [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_rad_zt ) + k = k + 1 + + case default + + write(fstderr,*) 'Error: unrecognized variable in vars_rad_zt: ', trim( vars_rad_zt(i) ) + + l_error = .true. ! This will stop the run. + + + end select + + end do + + return + end subroutine stats_init_rad_zt + +end module stats_rad_zt_module diff --git a/models/atm/cam/src/physics/clubb/stats_sfc.F90 b/models/atm/cam/src/physics/clubb/stats_sfc.F90 deleted file mode 100644 index 3e6cf40e5346..000000000000 --- a/models/atm/cam/src/physics/clubb/stats_sfc.F90 +++ /dev/null @@ -1,467 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: stats_sfc.F90 5324 2011-07-27 21:05:45Z dschanen@uwm.edu $ - -module stats_sfc - - - implicit none - - private ! Set Default Scope - - public :: stats_init_sfc - - ! Constant parameters - integer, parameter, public :: nvarmax_sfc = 250 ! Maximum variables allowed - - contains - -!----------------------------------------------------------------------- - subroutine stats_init_sfc( vars_sfc, l_error ) - -! Description: -! Initializes array indices for sfc -! References: -! None -!----------------------------------------------------------------------- - - use constants_clubb, only: & - fstderr ! Constant(s) - - use stats_variables, only: & - sfc, & ! Variables - iustar, & - isoil_heat_flux, & - iveg_T_in_K, & - isfc_soil_T_in_K,& - ideep_soil_T_in_K, & - ilh, & - ish, & - icc, & - ilwp, & - ivwp, & - iiwp, & - iswp, & - irwp, & - iz_cloud_base, & - iz_inversion, & - irain_rate_sfc, & - irain_flux_sfc, & - irrainm_sfc, & - iwpthlp_sfc, & - iwprtp_sfc, & - iupwp_sfc, & - ivpwp_sfc, & - ithlm_vert_avg, & - irtm_vert_avg, & - ium_vert_avg, & - ivm_vert_avg, & - iwp2_vert_avg, & - iup2_vert_avg, & - ivp2_vert_avg, & - irtp2_vert_avg, & - ithlp2_vert_avg, & - iT_sfc - - use stats_variables, only: & - iwp23_matrix_condt_num, & - irtm_matrix_condt_num, & - ithlm_matrix_condt_num, & - irtp2_matrix_condt_num, & - ithlp2_matrix_condt_num, & - irtpthlp_matrix_condt_num, & - iup2_vp2_matrix_condt_num, & - iwindm_matrix_condt_num - - use stats_variables, only: & - imorr_rain_rate, & - imorr_snow_rate - - use stats_variables, only: & - irtm_spur_src, & - ithlm_spur_src - - use stats_type, only: & - stat_assign ! Procedure - - implicit none - - ! Input Variable - character(len= * ), dimension(nvarmax_sfc), intent(in) :: vars_sfc - - ! Output Variable - logical, intent(inout) :: l_error - - ! Local Varables - integer :: i, k - - ! ---- Begin Code ---- - - ! Default initialization for array indices for sfc - - isoil_heat_flux = 0 - iveg_T_in_K = 0 - isfc_soil_T_in_K = 0 - ideep_soil_T_in_K = 0 - - iustar = 0 - ilh = 0 - ish = 0 - icc = 0 - ilwp = 0 - irwp = 0 - ivwp = 0 ! nielsenb - iiwp = 0 ! nielsenb - iswp = 0 ! nielsenb - iz_cloud_base = 0 - iz_inversion = 0 - irain_rate_sfc = 0 ! Brian - irain_flux_sfc = 0 ! Brian - irrainm_sfc = 0 ! Brian - iwpthlp_sfc = 0 - iwprtp_sfc = 0 - iupwp_sfc = 0 - ivpwp_sfc = 0 - ithlm_vert_avg = 0 - irtm_vert_avg = 0 - ium_vert_avg = 0 - ivm_vert_avg = 0 - iwp2_vert_avg = 0 ! nielsenb - iup2_vert_avg = 0 - ivp2_vert_avg = 0 - irtp2_vert_avg = 0 - ithlp2_vert_avg = 0 - iT_sfc = 0 ! kcwhite - - ! These are estimates of the condition number on each LHS - ! matrix, and not located at the surface of the domain. - iwp23_matrix_condt_num = 0 - irtm_matrix_condt_num = 0 - ithlm_matrix_condt_num = 0 - irtp2_matrix_condt_num = 0 - ithlp2_matrix_condt_num = 0 - irtpthlp_matrix_condt_num = 0 - iup2_vp2_matrix_condt_num = 0 - iwindm_matrix_condt_num = 0 - - imorr_rain_rate = 0 - imorr_snow_rate = 0 - - irtm_spur_src = 0 - ithlm_spur_src = 0 - - ! Assign pointers for statistics variables sfc - - k = 1 - do i=1,sfc%nn - - select case ( trim(vars_sfc(i)) ) - case ('soil_heat_flux') - isoil_heat_flux = k - - call stat_assign(isoil_heat_flux, "soil_heat_flux", & - "soil_heat_flux[W/m^2]","W/m^2",sfc ) - k = k + 1 - case ('ustar') - iustar = k - - call stat_assign(iustar,"ustar", & - "Friction velocity [m/s]","m/s",sfc) - k = k + 1 - case ('veg_T_in_K') - iveg_T_in_K = k - - call stat_assign(iveg_T_in_K,"veg_T_in_K", & - "Surface Vegetation Temperature [K]","K",sfc) - k = k + 1 - case ('sfc_soil_T_in_K') - isfc_soil_T_in_K = k - - call stat_assign(isfc_soil_T_in_K,"sfc_soil_T_in_K", & - "Surface soil temperature [K]","K",sfc) - k = k + 1 - case ('deep_soil_T_in_K') - ideep_soil_T_in_K = k - - call stat_assign(ideep_soil_T_in_K,"deep_soil_T_in_K", & - "Deep soil Temperature [K]","K",sfc) - k = k + 1 - - case ('lh') - ilh = k - call stat_assign(ilh,"lh", & - "Surface latent heating [W/m^2]","W/m2",sfc) - k = k + 1 - - case ('sh') - ish = k - call stat_assign(ish,"sh", & - "Surface sensible heating [W/m^2]","W/m2",sfc) - k = k + 1 - - case ('cc') - icc = k - call stat_assign(icc,"cc", & - "Cloud cover [count]","count",sfc) - k = k + 1 - - case ('lwp') - ilwp = k - call stat_assign(ilwp,"lwp", & - "Liquid water path [kg/m^2]","kg/m2",sfc) - k = k + 1 - - case ('vwp') - ivwp = k - call stat_assign(ivwp,"vwp", & - "Vapor water path [kg/m^2]","kg/m2",sfc) - k = k + 1 - - case ('iwp') - iiwp = k - call stat_assign(iiwp,"iwp", & - "Ice water path [kg/m^2]","kg/m2",sfc) - k = k + 1 - - case ('swp') - iswp = k - call stat_assign(iswp,"swp", & - "Snow water path [kg/m^2]","kg/m2",sfc) - k = k + 1 - - case ('rwp') - irwp = k - call stat_assign(irwp,"rwp", & - "Rain water path [kg/m^2]","kg/m2",sfc) - k = k + 1 - - case ('z_cloud_base') - iz_cloud_base = k - call stat_assign(iz_cloud_base,"z_cloud_base", & - "Cloud base altitude [m]","m",sfc) - k = k + 1 - - case ('z_inversion') - iz_inversion = k - call stat_assign(iz_inversion,"z_inversion", & - "Inversion altitude [m]","m",sfc) - k = k + 1 - - case ('rain_rate_sfc') ! Brian - irain_rate_sfc = k - call stat_assign(irain_rate_sfc,"rain_rate_sfc", & - "Surface rainfall rate [mm/day]","mm/day",sfc) - k = k + 1 - - case ('rain_flux_sfc') ! Brian - irain_flux_sfc = k - - call stat_assign( irain_flux_sfc,"rain_flux_sfc", & - "Surface rain flux [W/m^2]", "W/m^2", sfc ) - k = k + 1 - - case ('rrainm_sfc') ! Brian - irrainm_sfc = k - - call stat_assign(irrainm_sfc,"rrainm_sfc", & - "Surface rain water mixing ratio [kg/kg]","kg/kg",sfc) - k = k + 1 - - case ( 'morr_rain_rate' ) - imorr_rain_rate = k - call stat_assign( imorr_rain_rate, "morr_rain_rate", & - "Total precip fallout rate from Morrison scheme [mm/day]","mm/day", sfc ) - k = k + 1 - - case ( 'morr_snow_rate' ) - imorr_snow_rate = k - call stat_assign( imorr_snow_rate, "morr_snow_rate", & - "Snow+Ice+Graupel fallout rate from Morrison scheme [mm/day]","mm/day", sfc ) - k = k + 1 - - case ('wpthlp_sfc') - iwpthlp_sfc = k - - call stat_assign(iwpthlp_sfc,"wpthlp_sfc", & - "wpthlp surface flux [K m/s]","K m/s",sfc) - k = k + 1 - - case ('wprtp_sfc') - iwprtp_sfc = k - - call stat_assign(iwprtp_sfc,"wprtp_sfc", & - "wprtp surface flux [kg/kg]","(kg/kg) m/s",sfc) - k = k + 1 - - case ('upwp_sfc') - iupwp_sfc = k - - call stat_assign(iupwp_sfc,"upwp_sfc", & - "upwp surface flux [m^2/s^2]","m^2/s^2",sfc) - k = k + 1 - - case ('vpwp_sfc') - ivpwp_sfc = k - - call stat_assign(ivpwp_sfc,"vpwp_sfc", & - "vpwp surface flux [m^2/s^2]","m^2/s^2",sfc) - k = k + 1 - - case ('thlm_vert_avg') - ithlm_vert_avg = k - - call stat_assign( ithlm_vert_avg, "thlm_vert_avg", & - "Vertical average (density-weighted) of thlm [K]", "K", sfc ) - k = k + 1 - - case ('rtm_vert_avg') - irtm_vert_avg = k - - call stat_assign( irtm_vert_avg, "rtm_vert_avg", & - "Vertical average (density-weighted) of rtm [kg/kg]", "kg/kg", sfc ) - k = k + 1 - - case ('um_vert_avg') - ium_vert_avg = k - - call stat_assign( ium_vert_avg, "um_vert_avg", & - "Vertical average (density-weighted) of um [m/s]", "m/s", sfc ) - k = k + 1 - - case ('vm_vert_avg') - ivm_vert_avg = k - - call stat_assign( ivm_vert_avg, "vm_vert_avg", & - "Vertical average (density-weighted) of vm [m/s]", "m/s", sfc ) - k = k + 1 - - case ('wp2_vert_avg') - iwp2_vert_avg = k - - call stat_assign( iwp2_vert_avg, "wp2_vert_avg", & - "Vertical average (density-weighted) of wp2 [m^2/s^2]", "m^2/s^2", & - sfc ) - k = k + 1 - - case ('up2_vert_avg') - iup2_vert_avg = k - - call stat_assign( iup2_vert_avg, "up2_vert_avg", & - "Vertical average (density-weighted) of up2 [m^2/s^2]", "m^2/s^2", & - sfc ) - k = k + 1 - - case ('vp2_vert_avg') - ivp2_vert_avg = k - - call stat_assign( ivp2_vert_avg, "vp2_vert_avg", & - "Vertical average (density-weighted) of vp2 [m^2/s^2]", "m^2/s^2", & - sfc ) - k = k + 1 - - case ('rtp2_vert_avg') - irtp2_vert_avg = k - - call stat_assign( irtp2_vert_avg, "rtp2_vert_avg", & - "Vertical average (density-weighted) of rtp2 [kg^2/kg^2]", & - "kg^2/kg^2", sfc ) - k = k + 1 - - case ('thlp2_vert_avg') - ithlp2_vert_avg = k - - call stat_assign( ithlp2_vert_avg, "thlp2_vert_avg", & - "Vertical average (density-weighted) of thlp2 [K^2]", "K^2", sfc ) - k = k + 1 - - case ('T_sfc') - iT_sfc = k - - call stat_assign( iT_sfc, "T_sfc", "Surface Temperature [K]", "K", sfc ) - k = k + 1 - - case ('wp23_matrix_condt_num') - iwp23_matrix_condt_num = k - call stat_assign(iwp23_matrix_condt_num,"wp23_matrix_condt_num", & - "Estimate of the condition number for wp2/3 [count]","count",sfc) - k = k + 1 - - case ('thlm_matrix_condt_num') - ithlm_matrix_condt_num = k - call stat_assign(ithlm_matrix_condt_num,"thlm_matrix_condt_num", & - "Estimate of the condition number for thlm/wpthlp [count]", & - "count",sfc) - k = k + 1 - - case ('rtm_matrix_condt_num') - irtm_matrix_condt_num = k - - call stat_assign(irtm_matrix_condt_num,"rtm_matrix_condt_num", & - "Estimate of the condition number for rtm/wprtp [count]", & - "count",sfc) - k = k + 1 - - case ('thlp2_matrix_condt_num') - ithlp2_matrix_condt_num = k - - call stat_assign(ithlp2_matrix_condt_num,"thlp2_matrix_condt_num", & - "Estimate of the condition number for thlp2 [count]", & - "count",sfc) - k = k + 1 - - case ('rtp2_matrix_condt_num') - irtp2_matrix_condt_num = k - call stat_assign(irtp2_matrix_condt_num,"rtp2_matrix_condt_num", & - "Estimate of the condition number for rtp2 [count]", & - "count",sfc) - k = k + 1 - - case ('rtpthlp_matrix_condt_num') - irtpthlp_matrix_condt_num = k - call stat_assign(irtpthlp_matrix_condt_num,"rtpthlp_matrix_condt_num", & - "Estimate of the condition number for rtpthlp [count]", & - "count",sfc) - k = k + 1 - - case ('up2_vp2_matrix_condt_num') - iup2_vp2_matrix_condt_num = k - call stat_assign(iup2_vp2_matrix_condt_num,"up2_vp2_matrix_condt_num", & - "Estimate of the condition number for up2/vp2 [count]","count",sfc) - k = k + 1 - - case ('windm_matrix_condt_num') - iwindm_matrix_condt_num = k - call stat_assign(iwindm_matrix_condt_num,"windm_matrix_condt_num", & - "Estimate of the condition number for the mean wind [count]","count",sfc) - - k = k + 1 - - case ('rtm_spur_src') - irtm_spur_src = k - - call stat_assign(irtm_spur_src, "rtm_spur_src", & - "rtm spurious source [kg/(m^2 s)]", "kg/(m^2 s)",sfc ) - k = k + 1 - - case ('thlm_spur_src') - ithlm_spur_src = k - - call stat_assign(ithlm_spur_src, "thlm_spur_src", & - "thlm spurious source [(K kg) / (m^2 s)]", "(K kg) / (m^2 s)",sfc ) - k = k + 1 - - case default - write(fstderr,*) 'Error: unrecognized variable in vars_sfc: ', & - trim( vars_sfc(i) ) - l_error = .true. ! This will stop the run. - - end select - - end do - - return - - end subroutine stats_init_sfc - - -end module stats_sfc - diff --git a/models/atm/cam/src/physics/clubb/stats_sfc_module.F90 b/models/atm/cam/src/physics/clubb/stats_sfc_module.F90 new file mode 100644 index 000000000000..834b1f937816 --- /dev/null +++ b/models/atm/cam/src/physics/clubb/stats_sfc_module.F90 @@ -0,0 +1,460 @@ +!----------------------------------------------------------------------- +! $Id: stats_sfc_module.F90 7315 2014-09-30 20:49:54Z schemena@uwm.edu $ +!=============================================================================== +module stats_sfc_module + + + implicit none + + private ! Set Default Scope + + public :: stats_init_sfc + + ! Constant parameters + integer, parameter, public :: nvarmax_sfc = 250 ! Maximum variables allowed + + contains + +!----------------------------------------------------------------------- + subroutine stats_init_sfc( vars_sfc, l_error ) + +! Description: +! Initializes array indices for stats_sfc +! References: +! None +!----------------------------------------------------------------------- + + use constants_clubb, only: & + fstderr ! Constant(s) + + use stats_variables, only: & + stats_sfc, & ! Variables + iustar, & + isoil_heat_flux, & + iveg_T_in_K, & + isfc_soil_T_in_K,& + ideep_soil_T_in_K, & + ilh, & + ish, & + icc, & + ilwp, & + ivwp, & + iiwp, & + iswp, & + irwp, & + iz_cloud_base, & + iz_inversion, & + iprecip_rate_sfc, & + irain_flux_sfc, & + irrm_sfc + + use stats_variables, only: & + iwpthlp_sfc, & + iwprtp_sfc, & + iupwp_sfc, & + ivpwp_sfc, & + ithlm_vert_avg, & + irtm_vert_avg, & + ium_vert_avg, & + ivm_vert_avg, & + iwp2_vert_avg, & + iup2_vert_avg, & + ivp2_vert_avg, & + irtp2_vert_avg, & + ithlp2_vert_avg, & + iT_sfc + + use stats_variables, only: & + iwp23_matrix_condt_num, & + irtm_matrix_condt_num, & + ithlm_matrix_condt_num, & + irtp2_matrix_condt_num, & + ithlp2_matrix_condt_num, & + irtpthlp_matrix_condt_num, & + iup2_vp2_matrix_condt_num, & + iwindm_matrix_condt_num + + use stats_variables, only: & + imorr_snow_rate ! Variable(s) + + use stats_variables, only: & + irtm_spur_src, & + ithlm_spur_src, & + irsm_sd_morr_int + + use stats_type_utilities, only: & + stat_assign ! Procedure + + implicit none + + ! External + intrinsic :: trim + + ! Input Variable + character(len= * ), dimension(nvarmax_sfc), intent(in) :: vars_sfc + + ! Input / Output Variable + logical, intent(inout) :: l_error + + ! Local Varables + integer :: i, k + + ! ---- Begin Code ---- + + ! Default initialization for array indices for stats_sfc is zero (see module + ! stats_variables) + + ! Assign pointers for statistics variables stats_sfc using stat_assign + + k = 1 + do i = 1, stats_sfc%num_output_fields + + select case ( trim( vars_sfc(i) ) ) + case ('soil_heat_flux') + isoil_heat_flux = k + + call stat_assign( var_index=isoil_heat_flux, var_name="soil_heat_flux", & + var_description="soil_heat_flux[W/m^2]", var_units="W/m^2", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + case ('ustar') + iustar = k + + call stat_assign( var_index=iustar, var_name="ustar", & + var_description="Friction velocity [m/s]", var_units="m/s", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + case ('veg_T_in_K') + iveg_T_in_K = k + + call stat_assign( var_index=iveg_T_in_K, var_name="veg_T_in_K", & + var_description="Surface Vegetation Temperature [K]", var_units="K", & + l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + case ('sfc_soil_T_in_K') + isfc_soil_T_in_K = k + + call stat_assign( var_index=isfc_soil_T_in_K, var_name="sfc_soil_T_in_K", & + var_description="Surface soil temperature [K]", var_units="K", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + case ('deep_soil_T_in_K') + ideep_soil_T_in_K = k + + call stat_assign( var_index=ideep_soil_T_in_K, var_name="deep_soil_T_in_K", & + var_description="Deep soil Temperature [K]", var_units="K", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + + case ('lh') + ilh = k + call stat_assign( var_index=ilh, var_name="lh", & + var_description="Surface latent heating [W/m^2]", var_units="W/m2", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + + case ('sh') + ish = k + call stat_assign( var_index=ish, var_name="sh", & + var_description="Surface sensible heating [W/m^2]", var_units="W/m2", & + l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('cc') + icc = k + call stat_assign( var_index=icc, var_name="cc", var_description="Cloud cover [count]", & + var_units="count", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('lwp') + ilwp = k + call stat_assign( var_index=ilwp, var_name="lwp", & + var_description="Liquid water path [kg/m^2]", var_units="kg/m2", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + + case ('vwp') + ivwp = k + call stat_assign( var_index=ivwp, var_name="vwp", & + var_description="Vapor water path [kg/m^2]", var_units="kg/m2", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + + case ('iwp') + iiwp = k + call stat_assign( var_index=iiwp, var_name="iwp", & + var_description="Ice water path [kg/m^2]", var_units="kg/m2", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + + case ('swp') + iswp = k + call stat_assign( var_index=iswp, var_name="swp", & + var_description="Snow water path [kg/m^2]", var_units="kg/m2", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + + case ('rwp') + irwp = k + call stat_assign( var_index=irwp, var_name="rwp", & + var_description="Rain water path [kg/m^2]", var_units="kg/m2", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + + case ('z_cloud_base') + iz_cloud_base = k + call stat_assign( var_index=iz_cloud_base, var_name="z_cloud_base", & + var_description="Cloud base altitude [m]", var_units="m", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + + case ('z_inversion') + iz_inversion = k + call stat_assign( var_index=iz_inversion, var_name="z_inversion", & + var_description="Inversion altitude [m]", var_units="m", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + + case ('precip_rate_sfc') ! Brian + iprecip_rate_sfc = k + call stat_assign( var_index=iprecip_rate_sfc, var_name="precip_rate_sfc", & + var_description="Surface rainfall rate [mm/day]", var_units="mm/day", & + l_silhs=.true., grid_kind=stats_sfc ) + k = k + 1 + + case ('rain_flux_sfc') ! Brian + irain_flux_sfc = k + + call stat_assign( var_index=irain_flux_sfc, var_name="rain_flux_sfc", & + var_description="Surface rain flux [W/m^2]", var_units="W/m^2", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + + case ('rrm_sfc') ! Brian + irrm_sfc = k + + call stat_assign( var_index=irrm_sfc, var_name="rrm_sfc", & + var_description="Surface rain water mixing ratio [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ( 'morr_snow_rate' ) + imorr_snow_rate = k + call stat_assign( var_index=imorr_snow_rate, var_name="morr_snow_rate", & + var_description="Snow+Ice+Graupel fallout rate from Morrison scheme [mm/day]", & + var_units="mm/day", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('wpthlp_sfc') + iwpthlp_sfc = k + + call stat_assign( var_index=iwpthlp_sfc, var_name="wpthlp_sfc", & + var_description="wpthlp surface flux [K m/s]", var_units="K m/s", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + + case ('wprtp_sfc') + iwprtp_sfc = k + + call stat_assign( var_index=iwprtp_sfc, var_name="wprtp_sfc", & + var_description="wprtp surface flux [kg/kg]", var_units="(kg/kg) m/s", & + l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('upwp_sfc') + iupwp_sfc = k + + call stat_assign( var_index=iupwp_sfc, var_name="upwp_sfc", & + var_description="upwp surface flux [m^2/s^2]", var_units="m^2/s^2", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + + case ('vpwp_sfc') + ivpwp_sfc = k + + call stat_assign( var_index=ivpwp_sfc, var_name="vpwp_sfc", & + var_description="vpwp surface flux [m^2/s^2]", var_units="m^2/s^2", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + + case ('thlm_vert_avg') + ithlm_vert_avg = k + + call stat_assign( var_index=ithlm_vert_avg, var_name="thlm_vert_avg", & + var_description="Vertical average (density-weighted) of thlm [K]", var_units="K", & + l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('rtm_vert_avg') + irtm_vert_avg = k + + call stat_assign( var_index=irtm_vert_avg, var_name="rtm_vert_avg", & + var_description="Vertical average (density-weighted) of rtm [kg/kg]", & + var_units="kg/kg", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('um_vert_avg') + ium_vert_avg = k + + call stat_assign( var_index=ium_vert_avg, var_name="um_vert_avg", & + var_description="Vertical average (density-weighted) of um [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('vm_vert_avg') + ivm_vert_avg = k + + call stat_assign( var_index=ivm_vert_avg, var_name="vm_vert_avg", & + var_description="Vertical average (density-weighted) of vm [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('wp2_vert_avg') + iwp2_vert_avg = k + + call stat_assign( var_index=iwp2_vert_avg, var_name="wp2_vert_avg", & + var_description="Vertical average (density-weighted) of wp2 [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('up2_vert_avg') + iup2_vert_avg = k + + call stat_assign( var_index=iup2_vert_avg, var_name="up2_vert_avg", & + var_description="Vertical average (density-weighted) of up2 [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('vp2_vert_avg') + ivp2_vert_avg = k + + call stat_assign( var_index=ivp2_vert_avg, var_name="vp2_vert_avg", & + var_description="Vertical average (density-weighted) of vp2 [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('rtp2_vert_avg') + irtp2_vert_avg = k + + call stat_assign( var_index=irtp2_vert_avg, var_name="rtp2_vert_avg", & + var_description="Vertical average (density-weighted) of rtp2 [kg^2/kg^2]", & + var_units="kg^2/kg^2", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('thlp2_vert_avg') + ithlp2_vert_avg = k + + call stat_assign( var_index=ithlp2_vert_avg, var_name="thlp2_vert_avg", & + var_description="Vertical average (density-weighted) of thlp2 [K^2]", & + var_units="K^2", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('T_sfc') + iT_sfc = k + + call stat_assign( var_index=iT_sfc, var_name="T_sfc", & + var_description="Surface Temperature [K]", var_units="K", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + + case ('wp23_matrix_condt_num') + iwp23_matrix_condt_num = k + call stat_assign( var_index=iwp23_matrix_condt_num, var_name="wp23_matrix_condt_num", & + var_description="Estimate of the condition number for wp2/3 [count]", & + var_units="count", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('thlm_matrix_condt_num') + ithlm_matrix_condt_num = k + call stat_assign( var_index=ithlm_matrix_condt_num, var_name="thlm_matrix_condt_num", & + var_description="Estimate of the condition number for thlm/wpthlp [count]", & + var_units="count", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('rtm_matrix_condt_num') + irtm_matrix_condt_num = k + + call stat_assign( var_index=irtm_matrix_condt_num, var_name="rtm_matrix_condt_num", & + var_description="Estimate of the condition number for rtm/wprtp [count]", & + var_units="count", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('thlp2_matrix_condt_num') + ithlp2_matrix_condt_num = k + + call stat_assign( var_index=ithlp2_matrix_condt_num, var_name="thlp2_matrix_condt_num", & + var_description="Estimate of the condition number for thlp2 [count]", & + var_units="count", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('rtp2_matrix_condt_num') + irtp2_matrix_condt_num = k + call stat_assign( var_index=irtp2_matrix_condt_num, var_name="rtp2_matrix_condt_num", & + var_description="Estimate of the condition number for rtp2 [count]", & + var_units="count", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('rtpthlp_matrix_condt_num') + irtpthlp_matrix_condt_num = k + call stat_assign( var_index=irtpthlp_matrix_condt_num, & + var_name="rtpthlp_matrix_condt_num", & + var_description="Estimate of the condition number for rtpthlp [count]", & + var_units="count", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('up2_vp2_matrix_condt_num') + iup2_vp2_matrix_condt_num = k + call stat_assign( var_index=iup2_vp2_matrix_condt_num, & + var_name="up2_vp2_matrix_condt_num", & + var_description="Estimate of the condition number for up2/vp2 [count]", & + var_units="count", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('windm_matrix_condt_num') + iwindm_matrix_condt_num = k + call stat_assign( var_index=iwindm_matrix_condt_num, var_name="windm_matrix_condt_num", & + var_description="Estimate of the condition number for the mean wind [count]", & + var_units="count", l_silhs=.false., grid_kind=stats_sfc ) + + k = k + 1 + + case ('rtm_spur_src') + irtm_spur_src = k + + call stat_assign( var_index=irtm_spur_src, var_name="rtm_spur_src", & + var_description="rtm spurious source [kg/(m^2 s)]", var_units="kg/(m^2 s)", & + l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('thlm_spur_src') + ithlm_spur_src = k + + call stat_assign( var_index=ithlm_spur_src, var_name="thlm_spur_src", & + var_description="thlm spurious source [(K kg) / (m^2 s)]", & + var_units="(K kg) / (m^2 s)", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('rs_sd_morr_int') + irsm_sd_morr_int = k + + call stat_assign( var_index=irsm_sd_morr_int, var_name="rs_sd_morr_int", & + var_description="rsm_sd_morr vertical integral [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_sfc ) + k = k + 1 + + case default + write(fstderr,*) 'Error: unrecognized variable in vars_sfc: ', & + trim( vars_sfc(i) ) + l_error = .true. ! This will stop the run. + + end select + + end do ! 1 .. stats_sfc%num_output_fields + + return + + end subroutine stats_init_sfc + + +end module stats_sfc_module + diff --git a/models/atm/cam/src/physics/clubb/stats_subs.F90 b/models/atm/cam/src/physics/clubb/stats_subs.F90 deleted file mode 100644 index 5c22e588e4b4..000000000000 --- a/models/atm/cam/src/physics/clubb/stats_subs.F90 +++ /dev/null @@ -1,2357 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: stats_subs.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -module stats_subs - - implicit none - - private ! Set Default Scope - - public :: stats_init, stats_begin_timestep, stats_end_timestep, & - stats_accumulate, stats_finalize, stats_accumulate_hydromet, & - stats_accumulate_LH_tend - - private :: stats_zero, stats_avg - - contains - - !----------------------------------------------------------------------- - subroutine stats_init( iunit, fname_prefix, fdir, l_stats_in, & - stats_fmt_in, stats_tsamp_in, stats_tout_in, fnamelist, & - nzmax, gzt, gzm, nnrad_zt, & - grad_zt, nnrad_zm, grad_zm, day, month, year, & - rlat, rlon, time_current, delt ) - ! - ! Description: - ! Initializes the statistics saving functionality of the CLUBB model. - ! - ! References: - ! None - !----------------------------------------------------------------------- - - use stats_variables, only: & - zt, & ! Variables - ztscr01, & - ztscr02, & - ztscr03, & - ztscr04, & - ztscr05, & - ztscr06, & - ztscr07, & - ztscr08, & - ztscr09, & - ztscr10, & - ztscr11, & - ztscr12, & - ztscr13, & - ztscr14, & - ztscr15, & - ztscr16, & - ztscr17, & - ztscr18, & - ztscr19, & - ztscr20, & - ztscr21 - - use stats_variables, only: & - zm, & - zmscr01, & - zmscr02, & - zmscr03, & - zmscr04, & - zmscr05, & - zmscr06, & - zmscr07, & - zmscr08, & - zmscr09, & - zmscr10, & - zmscr11, & - zmscr12, & - zmscr13, & - zmscr14, & - zmscr15, & - zmscr16, & - zmscr17, & - rad_zt, & - rad_zm, & - sfc, & - l_stats, & - l_output_rad_files, & - stats_tsamp, & - stats_tout, & - l_stats_samp, & - l_stats_last, & - fname_zt, & - fname_zm, & - fname_rad_zt, & - fname_rad_zm, & - fname_sfc, & - l_netcdf, & - l_grads - - use clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - - use output_grads, only: & - open_grads ! Procedure - -#ifdef NETCDF - use output_netcdf, only: & - open_netcdf ! Procedure -#endif - - use stats_zm, only: & - nvarmax_zm, & ! Constant(s) - stats_init_zm ! Procedure(s) - - use stats_zt, only: & - nvarmax_zt, & ! Constant(s) - stats_init_zt ! Procedure(s) - - use stats_rad_zt, only: & - nvarmax_rad_zt, & ! Constant(s) - stats_init_rad_zt ! Procedure(s) - - use stats_rad_zm, only: & - nvarmax_rad_zm, & ! Constant(s) - stats_init_rad_zm ! Procedure(s) - - use stats_sfc, only: & - nvarmax_sfc, & ! Constant(s) - stats_init_sfc ! Procedure(s) - - use error_code, only: & - clubb_at_least_debug_level ! Function - - use constants_clubb, only: & - fstdout, fstderr, var_length ! Constants - - implicit none - - ! Input Variables - - integer, intent(in) :: iunit ! File unit for fnamelist - - character(len=*), intent(in) :: & - fname_prefix, & ! Start of the stats filenames - fdir ! Directory to output to - - logical, intent(in) :: l_stats_in ! Stats on? T/F - - character(len=*), intent(in) :: & - stats_fmt_in ! Format of the stats file output - - real(kind=time_precision), intent(in) :: & - stats_tsamp_in, & ! Sampling interval [s] - stats_tout_in ! Output interval [s] - - character(len=*), intent(in) :: & - fnamelist ! Filename holding the &statsnl - - integer, intent(in) :: nzmax ! Grid points in the vertical [count] - - real( kind = core_rknd ), intent(in), dimension(nzmax) :: & - gzt, gzm ! Thermodynamic and momentum levels [m] - - integer, intent(in) :: nnrad_zt ! Grid points in the radiation grid [count] - - real( kind = core_rknd ), intent(in), dimension(nnrad_zt) :: grad_zt ! Radiation levels [m] - - integer, intent(in) :: nnrad_zm ! Grid points in the radiation grid [count] - - real( kind = core_rknd ), intent(in), dimension(nnrad_zm) :: grad_zm ! Radiation levels [m] - - integer, intent(in) :: day, month, year ! Time of year - - real( kind = core_rknd ), dimension(1), intent(in) :: & - rlat, rlon ! Latitude and Longitude [Degrees N/E] - - real(kind=time_precision), intent(in) :: & - time_current ! Model time [s] - - real(kind=time_precision), intent(in) :: & - delt ! Timestep (dt_main in CLUBB) [s] - - - ! Local Variables - - ! Namelist Variables - - character(len=10) :: stats_fmt ! File storage convention - - character(len=var_length), dimension(nvarmax_zt) :: & - vars_zt ! Variables on the thermodynamic levels - - character(len=var_length), dimension(nvarmax_zm) :: & - vars_zm ! Variables on the momentum levels - - character(len=var_length), dimension(nvarmax_rad_zt) :: & - vars_rad_zt ! Variables on the radiation levels - - character(len=var_length), dimension(nvarmax_rad_zm) :: & - vars_rad_zm ! Variables on the radiation levels - - character(len=var_length), dimension(nvarmax_sfc) :: & - vars_sfc ! Variables at the model surface - - namelist /statsnl/ & - vars_zt, & - vars_zm, & - vars_rad_zt, & - vars_rad_zm, & - vars_sfc - - ! Local Variables - - logical :: l_error - - character(len=200) :: fname - - integer :: i, ntot, read_status - - ! Initialize - l_error = .false. - - ! Set stats_variables variables with inputs from calling subroutine - l_stats = l_stats_in - - stats_tsamp = stats_tsamp_in - stats_tsamp = stats_tsamp_in - stats_tout = stats_tout_in - stats_fmt = trim( stats_fmt_in ) - - if ( .not. l_stats ) then - l_stats_samp = .false. - l_stats_last = .false. - return - end if - - ! Initialize namelist variables - - vars_zt = '' - vars_zm = '' - vars_rad_zt = '' - vars_rad_zm = '' - vars_sfc = '' - - ! Reads list of variables that should be output to GrADS/NetCDF (namelist &statsnl) - - open(unit=iunit, file=fnamelist) - read(unit=iunit, nml=statsnl, iostat=read_status, end=100) - if ( read_status /= 0 ) then - if ( read_status > 0 ) then - write(fstderr,*) "Error reading stats namelist in file ", & - trim( fnamelist ) - else ! Read status < 0 - write(fstderr,*) "End of file marker reached while reading stats namelist in file ", & - trim( fnamelist ) - end if - write(fstderr,*) "One cause is having more statistical variables ", & - "listed in the namelist for var_zt, var_zm, or ", & - "var_sfc than allowed by nvarmax_zt, nvarmax_zm, ", & - "or nvarmax_sfc, respectively." - write(fstderr,*) "Maximum variables allowed for var_zt = ", nvarmax_zt - write(fstderr,*) "Maximum variables allowed for var_zm = ", nvarmax_zm - write(fstderr,*) "Maximum variables allowed for var_rad_zt = ", nvarmax_rad_zt - write(fstderr,*) "Maximum variables allowed for var_rad_zm = ", nvarmax_rad_zm - write(fstderr,*) "Maximum variables allowed for var_sfc = ", nvarmax_sfc - stop "stats_init: Error reading stats namelist." - end if - close(unit=iunit) - - if ( clubb_at_least_debug_level( 1 ) ) then - write(fstdout,*) "--------------------------------------------------" - - write(fstdout,*) "Statistics" - - write(fstdout,*) "--------------------------------------------------" - write(fstdout,*) "vars_zt = " - i = 1 - do while ( vars_zt(i) /= '' ) - write(fstdout,*) vars_zt(i) - i = i + 1 - end do - - write(fstdout,*) "vars_zm = " - i = 1 - do while ( vars_zm(i) /= '' ) - write(fstdout,*) vars_zm(i) - i = i + 1 - end do - - if (l_output_rad_files) then - write(fstdout,*) "vars_rad_zt = " - i = 1 - do while ( vars_rad_zt(i) /= '' ) - write(fstdout,*) vars_rad_zt(i) - i = i + 1 - end do - - write(fstdout,*) "vars_rad_zm = " - i = 1 - do while ( vars_rad_zm(i) /= '' ) - write(fstdout,*) vars_rad_zm(i) - i = i + 1 - end do - end if ! l_output_rad_files - - write(fstdout,*) "vars_sfc = " - i = 1 - do while ( vars_sfc(i) /= '' ) - write(fstdout,*) vars_sfc(i) - i = i + 1 - end do - - write(fstdout,*) "--------------------------------------------------" - end if ! clubb_at_least_debug_level 1 - - ! Determine file names for GrADS or NetCDF files - fname_zt = trim( fname_prefix )//"_zt" - fname_zm = trim( fname_prefix )//"_zm" - fname_rad_zt = trim( fname_prefix )//"_rad_zt" - fname_rad_zm = trim( fname_prefix )//"_rad_zm" - fname_sfc = trim( fname_prefix )//"_sfc" - - ! Parse the file type for stats output. Currently only GrADS and - ! NetCDF v3 are supported by this code. - - select case( trim( stats_fmt ) ) - case( "GrADS", "grads", "gr" ) - l_netcdf = .false. - l_grads = .true. - - case ( "NetCDF", "netcdf", "nc" ) - l_netcdf = .true. - l_grads = .false. - - case default - write(fstderr,*) "Invalid data format "//trim( stats_fmt ) - stop - - end select - - ! Check sampling and output frequencies - - ! The model time step length, delt (which is dt_main), should multiply - ! evenly into the statistical sampling time step length, stats_tsamp. - if ( abs( stats_tsamp/delt - real( floor( stats_tsamp/delt ), kind=time_precision ) ) & - > 1.e-8_time_precision ) then - l_error = .true. ! This will cause the run to stop. - write(fstderr,*) 'Error: stats_tsamp should be an even multiple of ', & - 'delt (which is dt_main). Check the appropriate ', & - 'model.in file.' - write(fstderr,*) 'stats_tsamp = ', stats_tsamp - write(fstderr,*) 'delt = ', delt - end if - - ! The statistical sampling time step length, stats_tsamp, should multiply - ! evenly into the statistical output time step length, stats_tout. - if ( abs( stats_tout/stats_tsamp & - - real( floor( stats_tout/stats_tsamp ), kind=time_precision ) ) & - > 1.e-8_time_precision ) then - l_error = .true. ! This will cause the run to stop. - write(fstderr,*) 'Error: stats_tout should be an even multiple of ', & - 'stats_tsamp. Check the appropriate model.in file.' - write(fstderr,*) 'stats_tout = ', stats_tout - write(fstderr,*) 'stats_tsamp = ', stats_tsamp - end if - - ! Initialize zt (mass points) - - i = 1 - do while ( ichar(vars_zt(i)(1:1)) /= 0 & - .and. len_trim(vars_zt(i)) /= 0 & - .and. i <= nvarmax_zt ) - i = i + 1 - enddo - ntot = i - 1 - if ( ntot == nvarmax_zt ) then - write(fstderr,*) "There are more statistical variables listed in ", & - "vars_zt than allowed for by nvarmax_zt." - write(fstderr,*) "Check the number of variables listed for vars_zt ", & - "in the stats namelist, or change nvarmax_zt." - write(fstderr,*) "nvarmax_zt = ", nvarmax_zt - stop "stats_init: number of zt statistical variables exceeds limit" - end if - - zt%nn = ntot - zt%kk = nzmax - - allocate( zt%z( zt%kk ) ) - zt%z = gzt - - allocate( zt%x( 1, 1, zt%kk, zt%nn ) ) - allocate( zt%n( 1, 1, zt%kk, zt%nn ) ) - allocate( zt%l_in_update( 1, 1, zt%kk, zt%nn ) ) - call stats_zero( zt%kk, zt%nn, zt%x, zt%n, zt%l_in_update ) - - allocate( zt%f%var( zt%nn ) ) - allocate( zt%f%z( zt%kk ) ) - - ! Allocate scratch space - - allocate( ztscr01(zt%kk) ) - allocate( ztscr02(zt%kk) ) - allocate( ztscr03(zt%kk) ) - allocate( ztscr04(zt%kk) ) - allocate( ztscr05(zt%kk) ) - allocate( ztscr06(zt%kk) ) - allocate( ztscr07(zt%kk) ) - allocate( ztscr08(zt%kk) ) - allocate( ztscr09(zt%kk) ) - allocate( ztscr10(zt%kk) ) - allocate( ztscr11(zt%kk) ) - allocate( ztscr12(zt%kk) ) - allocate( ztscr13(zt%kk) ) - allocate( ztscr14(zt%kk) ) - allocate( ztscr15(zt%kk) ) - allocate( ztscr16(zt%kk) ) - allocate( ztscr17(zt%kk) ) - allocate( ztscr18(zt%kk) ) - allocate( ztscr19(zt%kk) ) - allocate( ztscr20(zt%kk) ) - allocate( ztscr21(zt%kk) ) - - ztscr01 = 0.0_core_rknd - ztscr02 = 0.0_core_rknd - ztscr03 = 0.0_core_rknd - ztscr04 = 0.0_core_rknd - ztscr05 = 0.0_core_rknd - ztscr06 = 0.0_core_rknd - ztscr07 = 0.0_core_rknd - ztscr08 = 0.0_core_rknd - ztscr09 = 0.0_core_rknd - ztscr10 = 0.0_core_rknd - ztscr11 = 0.0_core_rknd - ztscr12 = 0.0_core_rknd - ztscr13 = 0.0_core_rknd - ztscr14 = 0.0_core_rknd - ztscr15 = 0.0_core_rknd - ztscr16 = 0.0_core_rknd - ztscr17 = 0.0_core_rknd - ztscr18 = 0.0_core_rknd - ztscr19 = 0.0_core_rknd - ztscr20 = 0.0_core_rknd - ztscr21 = 0.0_core_rknd - - fname = trim( fname_zt ) - - if ( l_grads ) then - - ! Open GrADS file - call open_grads( iunit, fdir, fname, & - 1, zt%kk, zt%z, & - day, month, year, rlat, rlon, & - time_current+stats_tout, stats_tout, & - zt%nn, zt%f ) - - else ! Open NetCDF file -#ifdef NETCDF - call open_netcdf( 1, 1, fdir, fname, 1, zt%kk, zt%z, & ! In - day, month, year, rlat, rlon, & ! In - time_current+stats_tout, stats_tout, zt%nn, & ! In - zt%f ) ! InOut -#else - stop "netCDF support was not compiled into this build." -#endif - - end if - - ! Default initialization for array indices for zt - - call stats_init_zt( vars_zt, l_error ) - - ! Initialize zm (momentum points) - - i = 1 - do while ( ichar(vars_zm(i)(1:1)) /= 0 & - .and. len_trim(vars_zm(i)) /= 0 & - .and. i <= nvarmax_zm ) - i = i + 1 - end do - ntot = i - 1 - if ( ntot == nvarmax_zm ) then - write(fstderr,*) "There are more statistical variables listed in ", & - "vars_zm than allowed for by nvarmax_zm." - write(fstderr,*) "Check the number of variables listed for vars_zm ", & - "in the stats namelist, or change nvarmax_zm." - write(fstderr,*) "nvarmax_zm = ", nvarmax_zm - stop "stats_init: number of zm statistical variables exceeds limit" - end if - - zm%nn = ntot - zm%kk = nzmax - - allocate( zm%z( zm%kk ) ) - zm%z = gzm - - allocate( zm%x( 1, 1, zm%kk, zm%nn ) ) - allocate( zm%n( 1, 1, zm%kk, zm%nn ) ) - allocate( zm%l_in_update( 1, 1, zm%kk, zm%nn ) ) - - call stats_zero( zm%kk, zm%nn, zm%x, zm%n, zm%l_in_update ) - - allocate( zm%f%var( zm%nn ) ) - allocate( zm%f%z( zm%kk ) ) - - ! Allocate scratch space - - allocate( zmscr01(zm%kk) ) - allocate( zmscr02(zm%kk) ) - allocate( zmscr03(zm%kk) ) - allocate( zmscr04(zm%kk) ) - allocate( zmscr05(zm%kk) ) - allocate( zmscr06(zm%kk) ) - allocate( zmscr07(zm%kk) ) - allocate( zmscr08(zm%kk) ) - allocate( zmscr09(zm%kk) ) - allocate( zmscr10(zm%kk) ) - allocate( zmscr11(zm%kk) ) - allocate( zmscr12(zm%kk) ) - allocate( zmscr13(zm%kk) ) - allocate( zmscr14(zm%kk) ) - allocate( zmscr15(zm%kk) ) - allocate( zmscr16(zm%kk) ) - allocate( zmscr17(zm%kk) ) - - zmscr01 = 0.0_core_rknd - zmscr02 = 0.0_core_rknd - zmscr03 = 0.0_core_rknd - zmscr04 = 0.0_core_rknd - zmscr05 = 0.0_core_rknd - zmscr06 = 0.0_core_rknd - zmscr07 = 0.0_core_rknd - zmscr08 = 0.0_core_rknd - zmscr09 = 0.0_core_rknd - zmscr10 = 0.0_core_rknd - zmscr11 = 0.0_core_rknd - zmscr12 = 0.0_core_rknd - zmscr13 = 0.0_core_rknd - zmscr14 = 0.0_core_rknd - zmscr15 = 0.0_core_rknd - zmscr16 = 0.0_core_rknd - zmscr17 = 0.0_core_rknd - - - fname = trim( fname_zm ) - if ( l_grads ) then - - ! Open GrADS files - call open_grads( iunit, fdir, fname, & - 1, zm%kk, zm%z, & - day, month, year, rlat, rlon, & - time_current+stats_tout, stats_tout, & - zm%nn, zm%f ) - - else ! Open NetCDF file -#ifdef NETCDF - call open_netcdf( 1, 1, fdir, fname, 1, zm%kk, zm%z, & ! In - day, month, year, rlat, rlon, & ! In - time_current+stats_tout, stats_tout, zm%nn, & ! In - zm%f ) ! InOut - -#else - stop "netCDF support was not compiled into this build." -#endif - end if - - call stats_init_zm( vars_zm, l_error ) - - ! Initialize rad_zt (radiation points) - - if (l_output_rad_files) then - - i = 1 - do while ( ichar(vars_rad_zt(i)(1:1)) /= 0 & - .and. len_trim(vars_rad_zt(i)) /= 0 & - .and. i <= nvarmax_rad_zt ) - i = i + 1 - end do - ntot = i - 1 - if ( ntot == nvarmax_rad_zt ) then - write(fstderr,*) "There are more statistical variables listed in ", & - "vars_rad_zt than allowed for by nvarmax_rad_zt." - write(fstderr,*) "Check the number of variables listed for vars_rad_zt ", & - "in the stats namelist, or change nvarmax_rad_zt." - write(fstderr,*) "nvarmax_rad_zt = ", nvarmax_rad_zt - stop "stats_init: number of rad_zt statistical variables exceeds limit" - end if - - rad_zt%nn = ntot - rad_zt%kk = nnrad_zt - - allocate( rad_zt%z( rad_zt%kk ) ) - rad_zt%z = grad_zt - - allocate( rad_zt%x( 1, 1, rad_zt%kk, rad_zt%nn ) ) - allocate( rad_zt%n( 1, 1, rad_zt%kk, rad_zt%nn ) ) - allocate( rad_zt%l_in_update( 1, 1, rad_zt%kk, rad_zt%nn ) ) - - call stats_zero( rad_zt%kk, rad_zt%nn, rad_zt%x, rad_zt%n, rad_zt%l_in_update ) - - allocate( rad_zt%f%var( rad_zt%nn ) ) - allocate( rad_zt%f%z( rad_zt%kk ) ) - - ! Allocate scratch space - - !allocate( radscr01(rad%kk) ) - !allocate( radscr02(rad%kk) ) - !allocate( radscr03(rad%kk) ) - !allocate( radscr04(rad%kk) ) - !allocate( radscr05(rad%kk) ) - !allocate( radscr06(rad%kk) ) - !allocate( radscr07(rad%kk) ) - !allocate( radscr08(rad%kk) ) - !allocate( radscr09(rad%kk) ) - !allocate( radscr10(rad%kk) ) - !allocate( radscr11(rad%kk) ) - !allocate( radscr12(rad%kk) ) - !allocate( radscr13(rad%kk) ) - !allocate( radscr14(rad%kk) ) - !allocate( radscr15(rad%kk) ) - !allocate( radscr16(rad%kk) ) - !allocate( radscr17(rad%kk) ) - - !radscr01 = 0.0_core_rknd - !radscr02 = 0.0_core_rknd - !radscr03 = 0.0_core_rknd - !radscr04 = 0.0_core_rknd - !radscr05 = 0.0_core_rknd - !radscr06 = 0.0_core_rknd - !radscr07 = 0.0_core_rknd - !radscr08 = 0.0_core_rknd - !radscr09 = 0.0_core_rknd - !radscr10 = 0.0_core_rknd - !radscr11 = 0.0_core_rknd - !radscr12 = 0.0_core_rknd - !radscr13 = 0.0_core_rknd - !radscr14 = 0.0_core_rknd - !radscr15 = 0.0_core_rknd - !radscr16 = 0.0_core_rknd - !radscr17 = 0.0_core_rknd - - - fname = trim( fname_rad_zt ) - if ( l_grads ) then - - ! Open GrADS files - call open_grads( iunit, fdir, fname, & - 1, rad_zt%kk, rad_zt%z, & - day, month, year, rlat, rlon, & - time_current+stats_tout, stats_tout, & - rad_zt%nn, rad_zt%f ) - - else ! Open NetCDF file -#ifdef NETCDF - call open_netcdf( 1, 1, fdir, fname, & - 1, rad_zt%kk, rad_zt%z, & - day, month, year, rlat, rlon, & - time_current+stats_tout, stats_tout, & - rad_zt%nn, rad_zt%f ) - -#else - stop "netCDF support was not compiled into this build." -#endif - end if - - call stats_init_rad_zt( vars_rad_zt, l_error ) - - ! Initialize rad_zm (radiation points) - - i = 1 - do while ( ichar(vars_rad_zm(i)(1:1)) /= 0 & - .and. len_trim(vars_rad_zm(i)) /= 0 & - .and. i <= nvarmax_rad_zm ) - i = i + 1 - end do - ntot = i - 1 - if ( ntot == nvarmax_rad_zm ) then - write(fstderr,*) "There are more statistical variables listed in ", & - "vars_rad_zm than allowed for by nvarmax_rad_zm." - write(fstderr,*) "Check the number of variables listed for vars_rad_zm ", & - "in the stats namelist, or change nvarmax_rad_zm." - write(fstderr,*) "nvarmax_rad_zm = ", nvarmax_rad_zm - stop "stats_init: number of rad_zm statistical variables exceeds limit" - end if - - rad_zm%nn = ntot - rad_zm%kk = nnrad_zm - - allocate( rad_zm%z( rad_zm%kk ) ) - rad_zm%z = grad_zm - - allocate( rad_zm%x( 1, 1, rad_zm%kk, rad_zm%nn ) ) - allocate( rad_zm%n( 1, 1, rad_zm%kk, rad_zm%nn ) ) - allocate( rad_zm%l_in_update( 1, 1, rad_zm%kk, rad_zm%nn ) ) - - call stats_zero( rad_zm%kk, rad_zm%nn, rad_zm%x, rad_zm%n, rad_zm%l_in_update ) - - allocate( rad_zm%f%var( rad_zm%nn ) ) - allocate( rad_zm%f%z( rad_zm%kk ) ) - - ! Allocate scratch space - - !allocate( radscr01(rad%kk) ) - !allocate( radscr02(rad%kk) ) - !allocate( radscr03(rad%kk) ) - !allocate( radscr04(rad%kk) ) - !allocate( radscr05(rad%kk) ) - !allocate( radscr06(rad%kk) ) - !allocate( radscr07(rad%kk) ) - !allocate( radscr08(rad%kk) ) - !allocate( radscr09(rad%kk) ) - !allocate( radscr10(rad%kk) ) - !allocate( radscr11(rad%kk) ) - !allocate( radscr12(rad%kk) ) - !allocate( radscr13(rad%kk) ) - !allocate( radscr14(rad%kk) ) - !allocate( radscr15(rad%kk) ) - !allocate( radscr16(rad%kk) ) - !allocate( radscr17(rad%kk) ) - - !radscr01 = 0.0_core_rknd - !radscr02 = 0.0_core_rknd - !radscr03 = 0.0_core_rknd - !radscr04 = 0.0_core_rknd - !radscr05 = 0.0_core_rknd - !radscr06 = 0.0_core_rknd - !radscr07 = 0.0_core_rknd - !radscr08 = 0.0_core_rknd - !radscr09 = 0.0_core_rknd - !radscr10 = 0.0_core_rknd - !radscr11 = 0.0_core_rknd - !radscr12 = 0.0_core_rknd - !radscr13 = 0.0_core_rknd - !radscr14 = 0.0_core_rknd - !radscr15 = 0.0_core_rknd - !radscr16 = 0.0_core_rknd - !radscr17 = 0.0_core_rknd - - - fname = trim( fname_rad_zm ) - if ( l_grads ) then - - ! Open GrADS files - call open_grads( iunit, fdir, fname, & - 1, rad_zm%kk, rad_zm%z, & - day, month, year, rlat, rlon, & - time_current+stats_tout, stats_tout, & - rad_zm%nn, rad_zm%f ) - - else ! Open NetCDF file -#ifdef NETCDF - call open_netcdf( 1, 1, fdir, fname, & - 1, rad_zm%kk, rad_zm%z, & - day, month, year, rlat, rlon, & - time_current+stats_tout, stats_tout, & - rad_zm%nn, rad_zm%f ) - -#else - stop "netCDF support was not compiled into this build." -#endif - end if - - call stats_init_rad_zm( vars_rad_zm, l_error ) - end if ! l_output_rad_files - - - ! Initialize sfc (surface point) - - i = 1 - do while ( ichar(vars_sfc(i)(1:1)) /= 0 & - .and. len_trim(vars_sfc(i)) /= 0 & - .and. i <= nvarmax_sfc ) - i = i + 1 - end do - ntot = i - 1 - if ( ntot == nvarmax_sfc ) then - write(fstderr,*) "There are more statistical variables listed in ", & - "vars_sfc than allowed for by nvarmax_sfc." - write(fstderr,*) "Check the number of variables listed for vars_sfc ", & - "in the stats namelist, or change nvarmax_sfc." - write(fstderr,*) "nvarmax_sfc = ", nvarmax_sfc - stop "stats_init: number of sfc statistical variables exceeds limit" - end if - - sfc%nn = ntot - sfc%kk = 1 - - allocate( sfc%z( sfc%kk ) ) - sfc%z = gzm(1) - - allocate( sfc%x( 1, 1, sfc%kk, sfc%nn ) ) - allocate( sfc%n( 1, 1, sfc%kk, sfc%nn ) ) - allocate( sfc%l_in_update( 1, 1, sfc%kk, sfc%nn ) ) - - call stats_zero( sfc%kk, sfc%nn, sfc%x, sfc%n, sfc%l_in_update ) - - allocate( sfc%f%var( sfc%nn ) ) - allocate( sfc%f%z( sfc%kk ) ) - - fname = trim( fname_sfc ) - - if ( l_grads ) then - - ! Open GrADS files - call open_grads( iunit, fdir, fname, & - 1, sfc%kk, sfc%z, & - day, month, year, rlat, rlon, & - time_current+stats_tout, stats_tout, & - sfc%nn, sfc%f ) - - else ! Open NetCDF files -#ifdef NETCDF - call open_netcdf( 1, 1, fdir, fname, 1, sfc%kk, sfc%z, & ! In - day, month, year, rlat, rlon, & ! In - time_current+stats_tout, stats_tout, sfc%nn, & ! In - sfc%f ) ! InOut - -#else - stop "netCDF support was not compiled into this build." -#endif - end if - - call stats_init_sfc( vars_sfc, l_error ) - - ! Check for errors - - if ( l_error ) then - write(fstderr,*) 'stats_init: errors found' - stop - endif - - return - - ! If namelist was not found in input file, turn off statistics - - 100 continue - write(fstderr,*) 'Error with statsnl, statistics is turned off' - l_stats = .false. - l_stats_samp = .false. - l_stats_last = .false. - - return - end subroutine stats_init - !----------------------------------------------------------------------- - subroutine stats_zero( kk, nn, x, n, l_in_update ) - - ! Description: - ! Initialize stats to zero - !----------------------------------------------------------------------- - use clubb_precision, only: & - stat_rknd, & ! Variable(s) - stat_nknd - - implicit none - - ! Input - integer, intent(in) :: kk, nn - - ! Output - real(kind=stat_rknd), dimension(1,1,kk,nn), intent(out) :: x - integer(kind=stat_nknd), dimension(1,1,kk,nn), intent(out) :: n - logical, dimension(1,1,kk,nn), intent(out) :: l_in_update - - ! Zero out arrays - - if ( nn > 0 ) then - x(:,:,:,:) = 0.0_stat_rknd - n(:,:,:,:) = 0_stat_nknd - l_in_update(:,:,:,:) = .false. - end if - - return - end subroutine stats_zero - - !----------------------------------------------------------------------- - subroutine stats_avg( kk, nn, x, n ) - - ! Description: - ! Compute the average of stats fields - !----------------------------------------------------------------------- - use clubb_precision, only: & - stat_rknd, & ! Variable(s) - stat_nknd - - implicit none - - ! Input - integer, intent(in) :: nn, kk - integer(kind=stat_nknd), dimension(1,1,kk,nn), intent(in) :: n - - ! Output - real(kind=stat_rknd), dimension(1,1,kk,nn), intent(inout) :: x - - ! Internal - - integer k,m - - ! Compute averages - - do m=1,nn - do k=1,kk - - if ( n(1,1,k,m) > 0 ) then - x(1,1,k,m) = x(1,1,k,m) / real( n(1,1,k,m), kind=stat_rknd ) - end if - - end do - end do - - return - end subroutine stats_avg - - !----------------------------------------------------------------------- - subroutine stats_begin_timestep( time_elapsed ) - - ! Description: - ! Given the elapsed time, set flags determining specifics such as - ! if this time set should be sampled or if this is the first or - ! last time step. - !----------------------------------------------------------------------- - - use stats_variables, only: & - l_stats, & ! Variable(s) - l_stats_samp, & - l_stats_last, & - stats_tsamp, & - stats_tout - - use clubb_precision, only: & - time_precision ! Variable(s) - - implicit none - - ! Input - - real(kind=time_precision), intent(in) :: & - time_elapsed ! Elapsed model time [s] - - if ( .not. l_stats ) return - - ! Only sample time steps that are multiples of "stats_tsamp" - ! in a case's "model.in" file to shorten length of run - if ( mod( time_elapsed, stats_tsamp ) < 1.e-8_time_precision ) then - l_stats_samp = .true. - else - l_stats_samp = .false. - end if - - ! Indicates the end of the sampling time period. Signals to start writing to the file - if ( mod( time_elapsed, stats_tout ) < 1.e-8_time_precision ) then - l_stats_last = .true. - else - l_stats_last = .false. - end if - - return - - end subroutine stats_begin_timestep - - !----------------------------------------------------------------------- - subroutine stats_end_timestep( ) - - ! Description: Called when the stats timestep has ended. This subroutine - ! is responsible for calling statistics to be written to the output - ! format. - !----------------------------------------------------------------------- - - use constants_clubb, only: & - fstderr ! Constant(s) - - use stats_variables, only: & - zt, & ! Variable(s) - zm, & - rad_zt, & - rad_zm, & - sfc, & - l_stats_last, & - stats_tsamp, & - stats_tout, & - l_output_rad_files, & - l_grads - - use clubb_precision, only: & - time_precision ! Variable(s) - - use output_grads, only: & - write_grads ! Procedure(s) - - use error_code, only: & - clubb_at_least_debug_level ! Procedure(s) - -#ifdef NETCDF - use output_netcdf, only: & - write_netcdf ! Procedure(s) -#endif - - implicit none - - ! Local Variables - - integer :: i, k - - logical :: l_error - - ! Check if it is time to write to file - - if ( .not. l_stats_last ) return - - ! Initialize - l_error = .false. - - ! Look for errors by checking the number of sampling points - ! for each variable in the zt statistics at each vertical level. - do i = 1, zt%nn - do k = 1, zt%kk - - if ( zt%n(1,1,k,i) /= 0 .and. & - zt%n(1,1,k,i) /= floor(stats_tout/stats_tsamp) ) then - - l_error = .true. ! This will stop the run - - if ( clubb_at_least_debug_level( 1 ) ) then - write(fstderr,*) 'Possible sampling error for variable ', & - trim(zt%f%var(i)%name), ' in zt ', & - 'at k = ', k, & - '; zt%n(',k,',',i,') = ', zt%n(1,1,k,i) - endif - - endif - - enddo - enddo - - ! Look for errors by checking the number of sampling points - ! for each variable in the zm statistics at each vertical level. - do i = 1, zm%nn - do k = 1, zm%kk - - if ( zm%n(1,1,k,i) /= 0 .and. & - zm%n(1,1,k,i) /= floor(stats_tout/stats_tsamp) ) then - - l_error = .true. ! This will stop the run - - if ( clubb_at_least_debug_level( 1 ) ) then - write(fstderr,*) 'Possible sampling error for variable ', & - trim(zm%f%var(i)%name), ' in zm ', & - 'at k = ', k, & - '; zm%n(',k,',',i,') = ', zm%n(1,1,k,i) - endif - - endif - - enddo - enddo - - if (l_output_rad_files) then - ! Look for errors by checking the number of sampling points - ! for each variable in the rad_zt statistics at each vertical level. - do i = 1, rad_zt%nn - do k = 1, rad_zt%kk - - if ( rad_zt%n(1,1,k,i) /= 0 .and. & - rad_zt%n(1,1,k,i) /= floor(stats_tout/stats_tsamp) ) then - - l_error = .true. ! This will stop the run - - if ( clubb_at_least_debug_level( 1 ) ) then - write(fstderr,*) 'Possible sampling error for variable ', & - trim(rad_zt%f%var(i)%name), ' in rad_zt ', & - 'at k = ', k, & - '; rad_zt%n(',k,',',i,') = ', rad_zt%n(1,1,k,i) - endif - - endif - - enddo - enddo - - ! Look for errors by checking the number of sampling points - ! for each variable in the rad_zm statistics at each vertical level. - do i = 1, rad_zm%nn - do k = 1, rad_zm%kk - - if ( rad_zm%n(1,1,k,i) /= 0 .and. & - rad_zm%n(1,1,k,i) /= floor(stats_tout/stats_tsamp) ) then - - l_error = .true. ! This will stop the run - - if ( clubb_at_least_debug_level( 1 ) ) then - write(fstderr,*) 'Possible sampling error for variable ', & - trim(rad_zm%f%var(i)%name), ' in rad_zm ', & - 'at k = ', k, & - '; rad_zm%n(',k,',',i,') = ', rad_zm%n(1,1,k,i) - endif - - endif - - enddo - enddo - end if ! l_output_rad_files - - ! Look for errors by checking the number of sampling points - ! for each variable in the sfc statistics at each vertical level. - do i = 1, sfc%nn - do k = 1, sfc%kk - - if ( sfc%n(1,1,k,i) /= 0 .and. & - sfc%n(1,1,k,i) /= floor(stats_tout/stats_tsamp) ) then - - l_error = .true. ! This will stop the run - - if ( clubb_at_least_debug_level( 1 ) ) then - write(fstderr,*) 'Possible sampling error for variable ', & - trim(sfc%f%var(i)%name), ' in sfc ', & - 'at k = ', k, & - '; sfc%n(',k,',',i,') = ', sfc%n(1,1,k,i) - endif - - endif - - enddo - enddo - - ! Stop the run if errors are found. - if ( l_error ) then - write(fstderr,*) 'Possible statistical sampling error' - write(fstderr,*) 'For details, set debug_level to a value of at ', & - 'least 1 in the appropriate model.in file.' - stop 'stats_end_timestep: error(s) found' - endif - - ! Compute averages - call stats_avg( zt%kk, zt%nn, zt%x, zt%n ) - call stats_avg( zm%kk, zm%nn, zm%x, zm%n ) - if (l_output_rad_files) then - call stats_avg( rad_zt%kk, rad_zt%nn, rad_zt%x, rad_zt%n ) - call stats_avg( rad_zm%kk, rad_zm%nn, rad_zm%x, rad_zm%n ) - end if - call stats_avg( sfc%kk, sfc%nn, sfc%x, sfc%n ) - - ! Write to file - if ( l_grads ) then - call write_grads( zt%f ) - call write_grads( zm%f ) - if (l_output_rad_files) then - call write_grads( rad_zt%f ) - call write_grads( rad_zm%f ) - end if - call write_grads( sfc%f ) - else ! l_netcdf -#ifdef NETCDF - call write_netcdf( zt%f ) - call write_netcdf( zm%f ) - if (l_output_rad_files) then - call write_netcdf( rad_zt%f ) - call write_netcdf( rad_zm%f ) - end if - call write_netcdf( sfc%f ) -#else - stop "This program was not compiled with netCDF support" -#endif - endif - - ! Reset sample fields - call stats_zero( zt%kk, zt%nn, zt%x, zt%n, zt%l_in_update ) - call stats_zero( zm%kk, zm%nn, zm%x, zm%n, zm%l_in_update ) - if (l_output_rad_files) then - call stats_zero( rad_zt%kk, rad_zt%nn, rad_zt%x, rad_zt%n, rad_zt%l_in_update ) - call stats_zero( rad_zm%kk, rad_zm%nn, rad_zm%x, rad_zm%n, rad_zm%l_in_update ) - end if - call stats_zero( sfc%kk, sfc%nn, sfc%x, sfc%n, sfc%l_in_update ) - - - return - end subroutine stats_end_timestep - - !---------------------------------------------------------------------- - subroutine stats_accumulate & - ( um, vm, upwp, vpwp, up2, vp2, & - thlm, rtm, wprtp, wpthlp, & - wp2, wp3, rtp2, thlp2, rtpthlp, & - p_in_Pa, exner, rho, rho_zm, & - rho_ds_zm, rho_ds_zt, thv_ds_zm, & - thv_ds_zt, wm_zt, wm_zm, rcm, wprcp, & - rcm_zm, rtm_zm, thlm_zm, cloud_frac, & - cloud_frac_zm, rcm_in_layer, cloud_cover, & - sigma_sqd_w, pdf_params, & - sclrm, sclrp2, sclrprtp, sclrpthlp, sclrm_forcing, & - wpsclrp, edsclrm, edsclrm_forcing ) - - ! Description: - ! Accumulate those stats variables that are preserved in CLUBB from timestep to - ! timestep, but not those stats that are not, (e.g. budget terms, longwave and - ! shortwave components, etc.) - !---------------------------------------------------------------------- - - use stats_variables, only: & - zt, & ! Variables - zm, & - sfc, & - l_stats_samp, & - ithlm, & - iT_in_K, & - ithvm, & - irtm, & - ircm, & - ium, & - ivm, & - iwm_zt, & - iwm_zm, & - iug, & - ivg, & - icloud_frac, & - ircm_in_layer, & - icloud_cover, & - ip_in_Pa, & - iexner, & - irho_ds_zt, & - ithv_ds_zt, & - iLscale, & - iwp3, & - iwp3_zm, & - iwpthlp2, & - iwp2thlp, & - iwprtp2, & - iwp2rtp, & - iLscale_up, & - iLscale_down, & - itau_zt, & - iKh_zt - - use stats_variables, only: & - iwp2thvp, & ! Variable(s) - iwp2rcp, & - iwprtpthlp, & - isigma_sqd_w_zt, & - irho, & - irsat, & - irsati, & - iAKm, & - iLH_AKm, & - iradht - - use stats_variables, only: & - imixt_frac, & ! Variable(s) - iw1, & - iw2, & - ivarnce_w1, & - ivarnce_w2, & - ithl1, & - ithl2, & - ivarnce_thl1, & - ivarnce_thl2, & - irt1, & - irt2, & - ivarnce_rt1, & - ivarnce_rt2, & - irc1, & - irc2, & - irsl1, & - irsl2, & - icloud_frac1, & - icloud_frac2, & - is1, & - is2, & - istdev_s1, & - istdev_s2, & - irrtthl, & - is_mellor - - use stats_variables, only: & - iwp2_zt, & ! Variable(s) - ithlp2_zt, & - iwpthlp_zt, & - iwprtp_zt, & - irtp2_zt, & - irtpthlp_zt, & - iup2_zt, & - ivp2_zt, & - iupwp_zt, & - ivpwp_zt, & - iwp2, & - irtp2, & - ithlp2, & - irtpthlp, & - iwprtp, & - iwpthlp, & - iwp4, & - iwpthvp, & - irtpthvp, & - ithlpthvp, & - itau_zm, & - iKh_zm, & - iwprcp, & - ithlprcp, & - irtprcp, & - ircp2, & - iupwp, & - ivpwp, & - iup2, & - ivp2, & - irho_zm, & - isigma_sqd_w, & - irho_ds_zm, & - ithv_ds_zm, & - iem - - use stats_variables, only: & - ishear, & ! Variable(s) - iFrad, & - icc, & - iz_cloud_base, & - ilwp, & - ivwp, & - iswp, & - irwp, & - iiwp, & - ithlm_vert_avg, & - irtm_vert_avg, & - ium_vert_avg, & - ivm_vert_avg, & - iwp2_vert_avg, & - iup2_vert_avg, & - ivp2_vert_avg, & - irtp2_vert_avg, & - ithlp2_vert_avg - - use stats_variables, only: & - isclrm, & ! Variable(s) - isclrm_f, & - iedsclrm, & - iedsclrm_f, & - isclrprtp, & - isclrp2, & - isclrpthvp, & - isclrpthlp, & - isclrprcp, & - iwpsclrp, & - iwp2sclrp, & - iwpsclrp2, & - iwpsclrprtp, & - iwpsclrpthlp, & - iwpedsclrp - - use stats_variables, only: & - iAKstd, & ! Variable(s) - iAKstd_cld, & - iAKm_rcm, & - iAKm_rcc - - use stats_variables, only: & - iLH_rcm_avg, & - icloud_frac_zm, & - ircm_zm, & - irtm_zm, & - ithlm_zm - - use stats_variables, only: & - itp2_mellor_1, & ! Variables - itp2_mellor_2, & - isptp_mellor_1, & - isptp_mellor_2, & - icorr_st_mellor1, & - icorr_st_mellor2, & - iwp3_on_wp2, & - iwp3_on_wp2_zt, & - iSkw_velocity - - use stats_variables, only: & - ia3_coef, & ! Variables - ia3_coef_zt - - use grid_class, only: & - gr ! Variable - - use grid_class, only: & - zt2zm ! Procedure(s) - - use variables_diagnostic_module, only: & - hydromet, & - thvm, & ! Variable(s) - ug, & - vg, & - Lscale, & - wpthlp2, & - wp2thlp, & - wprtp2, & - wp2rtp, & - Lscale_up, & - Lscale_down, & - tau_zt, & - Kh_zt, & - wp2thvp, & - wp2rcp, & - wprtpthlp, & - sigma_sqd_w_zt, & - rsat, & - AKm, & - lh_AKm, & - radht - - use variables_diagnostic_module, only: & - wp2_zt, & ! Variable(s) - thlp2_zt, & - wpthlp_zt, & - wprtp_zt, & - rtp2_zt, & - rtpthlp_zt, & - up2_zt, & - vp2_zt, & - upwp_zt, & - vpwp_zt, & - wp4, & - rtpthvp, & - thlpthvp, & - wpthvp, & - tau_zm, & - Kh_zm, & - thlprcp, & - rtprcp, & - rcp2, & - em, & - Frad, & - sclrpthvp, & - sclrprcp, & - wp2sclrp, & - wpsclrp2, & - wpsclrprtp, & - wpsclrpthlp, & - wpedsclrp - - use variables_diagnostic_module, only: & - a3_coef, & ! Variable(s) - a3_coef_zt, & - AKstd, & - lh_rcm_avg, & - AKstd_cld, & - AKm_rcm, & - AKm_rcc, & - wp3_zm, & - wp3_on_wp2, & - wp3_on_wp2_zt, & - Skw_velocity - - use variables_diagnostic_module, only: & - sptp_mellor_1, sptp_mellor_2, & ! Covariance of s and t[(kg/kg)^2] - tp2_mellor_1, tp2_mellor_2, & ! Variance of t [(kg/kg)^2] - corr_st_mellor1, corr_st_mellor2 ! Correlation between s and t [-] - - use pdf_parameter_module, only: & - pdf_parameter ! Type - - use T_in_K_module, only: & - thlm2T_in_K ! Procedure - - use constants_clubb, only: & - rc_tol, & ! Constant(s) - w_tol_sqd - - use parameters_model, only: & - sclr_dim, & ! Variable(s) - edsclr_dim - - use stats_type, only: & - stat_update_var, & ! Procedure(s) - stat_update_var_pt - - use fill_holes, only: & - vertical_avg, & ! Procedure(s) - vertical_integral - - use interpolation, only: & - lin_int ! Procedure - - use array_index, only: & - iirsnowm, iiricem, iirrainm ! Variable(s) - - use saturation, only: & - sat_mixrat_ice ! Procedure - - use clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! Input Variable - real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & - um, & ! u wind [m/s] - vm, & ! v wind [m/s] - upwp, & ! vertical u momentum flux [m^2/s^2] - vpwp, & ! vertical v momentum flux [m^2/s^2] - up2, & ! u'^2 [m^2/s^2] - vp2, & ! v'^2 [m^2/s^2] - thlm, & ! liquid potential temperature [K] - rtm, & ! total water mixing ratio [kg/kg] - wprtp, & ! w'rt' [(kg/kg) m/s] - wpthlp, & ! w'thl' [m K /s] - wp2, & ! w'^2 [m^2/s^2] - wp3, & ! w'^3 [m^3/s^3] - rtp2, & ! rt'^2 [(kg/kg)^2] - thlp2, & ! thl'^2 [K^2] - rtpthlp ! rt'thl' [kg/kg K] - - real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & - p_in_Pa, & ! Pressure (Pa) on thermodynamic points [Pa] - exner, & ! Exner function = ( p / p0 ) ** kappa [-] - rho, & ! Density [kg/m^3] - rho_zm, & ! Density [kg/m^3] - rho_ds_zm, & ! Dry, static density (momentum levels) [kg/m^3] - rho_ds_zt, & ! Dry, static density (thermo. levs.) [kg/m^3] - thv_ds_zm, & ! Dry, base-state theta_v (momentum levs.) [K] - thv_ds_zt, & ! Dry, base-state theta_v (thermo. levs.) [K] - wm_zt, & ! w on thermodynamic levels [m/s] - wm_zm ! w on momentum levels [m/s] - - real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & - rcm_zm, & ! Total water mixing ratio [kg/kg] - rtm_zm, & ! Total water mixing ratio [kg/kg] - thlm_zm, & ! Liquid potential temperature [K] - rcm, & ! Cloud water mixing ratio [kg/kg] - wprcp, & ! w'rc' [(kg/kg) m/s] - cloud_frac, & ! Cloud fraction [-] - cloud_frac_zm, & ! Cloud fraction on zm levels [-] - rcm_in_layer, & ! Cloud water mixing ratio in cloud layer [kg/kg] - cloud_cover ! Cloud cover [-] - - real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & - sigma_sqd_w ! PDF width parameter (momentum levels) [-] - - type(pdf_parameter), dimension(gr%nz), intent(in) :: & - pdf_params ! PDF parameters [units vary] - - real( kind = core_rknd ), intent(in), dimension(gr%nz,sclr_dim) :: & - sclrm, & ! High-order passive scalar [units vary] - sclrp2, & ! High-order passive scalar variance [units^2] - sclrprtp, & ! High-order passive scalar covariance [units kg/kg] - sclrpthlp, & ! High-order passive scalar covariance [units K] - sclrm_forcing, & ! Large-scale forcing of scalar [units/s] - wpsclrp ! w'sclr' [units m/s] - - real( kind = core_rknd ), intent(in), dimension(gr%nz,edsclr_dim) :: & - edsclrm, & ! Eddy-diff passive scalar [units vary] - edsclrm_forcing ! Large-scale forcing of edscalar [units vary] - - ! Local Variables - - integer :: i, k - - real( kind = core_rknd ), dimension(gr%nz) :: & - T_in_K, & ! Absolute temperature [K] - rsati, & ! Saturation w.r.t ice [kg/kg] - shear, & ! Wind shear production term [m^2/s^3] - s_mellor ! Mellor's 's' [kg/kg] - - real( kind = core_rknd ) :: xtmp - - ! Sample fields - - if ( l_stats_samp ) then - - ! zt variables - - - if ( iT_in_K > 0 .or. irsati > 0 ) then - T_in_K = thlm2T_in_K( thlm, exner, rcm ) - else - T_in_K = -999._core_rknd - end if - - call stat_update_var( iT_in_K, T_in_K, zt ) - - call stat_update_var( ithlm, thlm, zt ) - call stat_update_var( ithvm, thvm, zt ) - call stat_update_var( irtm, rtm, zt ) - call stat_update_var( ircm, rcm, zt ) - call stat_update_var( ium, um, zt ) - call stat_update_var( ivm, vm, zt ) - call stat_update_var( iwm_zt, wm_zt, zt ) - call stat_update_var( iwm_zm, wm_zm, zm ) - call stat_update_var( iug, ug, zt ) - call stat_update_var( ivg, vg, zt ) - call stat_update_var( icloud_frac, cloud_frac, zt ) - call stat_update_var( ircm_in_layer, rcm_in_layer, zt ) - call stat_update_var( icloud_cover, cloud_cover, zt ) - call stat_update_var( ip_in_Pa, p_in_Pa, zt ) - call stat_update_var( iexner, exner, zt ) - call stat_update_var( irho_ds_zt, rho_ds_zt, zt ) - call stat_update_var( ithv_ds_zt, thv_ds_zt, zt ) - call stat_update_var( iLscale, Lscale, zt ) - call stat_update_var( iwp3, wp3, zt ) - call stat_update_var( iwpthlp2, wpthlp2, zt ) - call stat_update_var( iwp2thlp, wp2thlp, zt ) - call stat_update_var( iwprtp2, wprtp2, zt ) - call stat_update_var( iwp2rtp, wp2rtp, zt ) - call stat_update_var( iLscale_up, Lscale_up, zt ) - call stat_update_var( iLscale_down, Lscale_down, zt ) - call stat_update_var( itau_zt, tau_zt, zt ) - call stat_update_var( iKh_zt, Kh_zt, zt ) - call stat_update_var( iwp2thvp, wp2thvp, zt ) - call stat_update_var( iwp2rcp, wp2rcp, zt ) - call stat_update_var( iwprtpthlp, wprtpthlp, zt ) - call stat_update_var( isigma_sqd_w_zt, sigma_sqd_w_zt, zt ) - call stat_update_var( irho, rho, zt ) - call stat_update_var( irsat, rsat, zt ) - if ( irsati > 0 ) then - rsati = sat_mixrat_ice( p_in_Pa, T_in_K ) - call stat_update_var( irsati, rsati, zt ) - end if - - call stat_update_var( iAKm, AKm, zt ) - call stat_update_var( iLH_AKm, lh_AKm, zt) - call stat_update_var( iLH_rcm_avg, lh_rcm_avg, zt ) - call stat_update_var( iAKstd, AKstd, zt ) - call stat_update_var( iAKstd_cld, AKstd_cld, zt ) - - call stat_update_var( iAKm_rcm, AKm_rcm, zt) - call stat_update_var( iAKm_rcc, AKm_rcc, zt ) - - call stat_update_var( iradht, radht, zt ) - call stat_update_var( imixt_frac, pdf_params%mixt_frac, zt ) - call stat_update_var( iw1, pdf_params%w1, zt ) - call stat_update_var( iw2, pdf_params%w2, zt ) - call stat_update_var( ivarnce_w1, pdf_params%varnce_w1, zt ) - call stat_update_var( ivarnce_w2, pdf_params%varnce_w2, zt ) - call stat_update_var( ithl1, pdf_params%thl1, zt ) - call stat_update_var( ithl2, pdf_params%thl2, zt ) - call stat_update_var( ivarnce_thl1, pdf_params%varnce_thl1, zt ) - call stat_update_var( ivarnce_thl2, pdf_params%varnce_thl2, zt ) - call stat_update_var( irt1, pdf_params%rt1, zt ) - call stat_update_var( irt2, pdf_params%rt2, zt ) - call stat_update_var( ivarnce_rt1, pdf_params%varnce_rt1, zt ) - call stat_update_var( ivarnce_rt2, pdf_params%varnce_rt2, zt ) - call stat_update_var( irc1, pdf_params%rc1, zt ) - call stat_update_var( irc2, pdf_params%rc2, zt ) - call stat_update_var( irsl1, pdf_params%rsl1, zt ) - call stat_update_var( irsl2, pdf_params%rsl2, zt ) - call stat_update_var( icloud_frac1, pdf_params%cloud_frac1, zt ) - call stat_update_var( icloud_frac2, pdf_params%cloud_frac2, zt ) - call stat_update_var( is1, pdf_params%s1, zt ) - call stat_update_var( is2, pdf_params%s2, zt ) - call stat_update_var( istdev_s1, pdf_params%stdev_s1, zt ) - call stat_update_var( istdev_s2, pdf_params%stdev_s2, zt ) - call stat_update_var( irrtthl, pdf_params%rrtthl, zt ) - call stat_update_var( iwp2_zt, wp2_zt, zt ) - call stat_update_var( ithlp2_zt, thlp2_zt, zt ) - call stat_update_var( iwpthlp_zt, wpthlp_zt, zt ) - call stat_update_var( iwprtp_zt, wprtp_zt, zt ) - call stat_update_var( irtp2_zt, rtp2_zt, zt ) - call stat_update_var( irtpthlp_zt, rtpthlp_zt, zt ) - call stat_update_var( iup2_zt, up2_zt, zt ) - call stat_update_var( ivp2_zt, vp2_zt, zt ) - call stat_update_var( iupwp_zt, upwp_zt, zt ) - call stat_update_var( ivpwp_zt, vpwp_zt, zt ) - call stat_update_var( ia3_coef_zt, a3_coef_zt, zt ) - call stat_update_var( iwp3_on_wp2_zt, wp3_on_wp2_zt, zt ) - - if ( is_mellor > 0 ) then - ! Determine 's' from Mellor (1977) (extended liquid water) - s_mellor(:) = pdf_params%mixt_frac * pdf_params%s1 & - + (1.0_core_rknd-pdf_params%mixt_frac) * pdf_params%s2 - call stat_update_var( is_mellor, s_mellor, zt ) - end if - - if ( sclr_dim > 0 ) then - do i=1, sclr_dim - call stat_update_var( isclrm(i), sclrm(:,i), zt ) - call stat_update_var( isclrm_f(i), sclrm_forcing(:,i), zt ) - end do - end if - - if ( edsclr_dim > 0 ) then - do i=1, edsclr_dim - call stat_update_var( iedsclrm(i), edsclrm(:,i), zt ) - call stat_update_var( iedsclrm_f(i), edsclrm_forcing(:,i), zt ) - end do - end if - - ! zm variables - - call stat_update_var( iwp2, wp2, zm ) - call stat_update_var( iwp3_zm, wp3_zm, zm ) - call stat_update_var( irtp2, rtp2, zm ) - call stat_update_var( ithlp2, thlp2, zm ) - call stat_update_var( irtpthlp, rtpthlp, zm ) - call stat_update_var( iwprtp, wprtp, zm ) - call stat_update_var( iwpthlp, wpthlp, zm ) - call stat_update_var( iwp4, wp4, zm ) - call stat_update_var( iwpthvp, wpthvp, zm ) - call stat_update_var( irtpthvp, rtpthvp, zm ) - call stat_update_var( ithlpthvp, thlpthvp, zm ) - call stat_update_var( itau_zm, tau_zm, zm ) - call stat_update_var( iKh_zm, Kh_zm, zm ) - call stat_update_var( iwprcp, wprcp, zm ) - call stat_update_var( ithlprcp, thlprcp, zm ) - call stat_update_var( irtprcp, rtprcp, zm ) - call stat_update_var( ircp2, rcp2, zm ) - call stat_update_var( iupwp, upwp, zm ) - call stat_update_var( ivpwp, vpwp, zm ) - call stat_update_var( ivp2, vp2, zm ) - call stat_update_var( iup2, up2, zm ) - call stat_update_var( irho_zm, rho_zm, zm ) - call stat_update_var( isigma_sqd_w, sigma_sqd_w, zm ) - call stat_update_var( irho_ds_zm, rho_ds_zm, zm ) - call stat_update_var( ithv_ds_zm, thv_ds_zm, zm ) - call stat_update_var( iem, em, zm ) - call stat_update_var( iFrad, Frad, zm ) - - call stat_update_var( isptp_mellor_1, sptp_mellor_1, zm ) - call stat_update_var( isptp_mellor_2, sptp_mellor_2, zm ) - call stat_update_var( itp2_mellor_1, tp2_mellor_1, zm ) - call stat_update_var( itp2_mellor_2, tp2_mellor_2, zm ) - call stat_update_var( icorr_st_mellor1, corr_st_mellor1, zm ) - call stat_update_var( icorr_st_mellor2, corr_st_mellor2, zm ) - - call stat_update_var( iSkw_velocity, Skw_velocity, zm ) - call stat_update_var( ia3_coef, a3_coef, zm ) - call stat_update_var( iwp3_on_wp2, wp3_on_wp2, zm ) - - call stat_update_var( icloud_frac_zm, cloud_frac_zm, zm ) - call stat_update_var( ircm_zm, rcm_zm, zm ) - call stat_update_var( irtm_zm, rtm_zm, zm ) - call stat_update_var( ithlm_zm, thlm_zm, zm ) - - if ( sclr_dim > 0 ) then - do i=1, sclr_dim - call stat_update_var( isclrp2(i), sclrp2(:,i), zm ) - call stat_update_var( isclrprtp(i), sclrprtp(:,i), zm ) - call stat_update_var( isclrpthvp(i), sclrpthvp(:,i), zm ) - call stat_update_var( isclrpthlp(i), sclrpthlp(:,i), zm ) - call stat_update_var( isclrprcp(i), sclrprcp(:,i), zm ) - call stat_update_var( iwpsclrp(i), wpsclrp(:,i), zm ) - call stat_update_var( iwp2sclrp(i), wp2sclrp(:,i), zm ) - call stat_update_var( iwpsclrp2(i), wpsclrp2(:,i), zm ) - call stat_update_var( iwpsclrprtp(i), wpsclrprtp(:,i), zm ) - call stat_update_var( iwpsclrpthlp(i), wpsclrpthlp(:,i), zm ) - end do - end if - if ( edsclr_dim > 0 ) then - do i=1, edsclr_dim - call stat_update_var( iwpedsclrp(i), wpedsclrp(:,i), zm ) - end do - end if - - ! Calculate shear production - if ( ishear > 0 ) then - do k = 1, gr%nz-1, 1 - shear(k) = - upwp(k) * ( um(k+1) - um(k) ) * gr%invrs_dzm(k) & - - vpwp(k) * ( vm(k+1) - vm(k) ) * gr%invrs_dzm(k) - enddo - shear(gr%nz) = 0.0_core_rknd - endif - call stat_update_var( ishear, shear, zm ) - - ! sfc variables - - ! Cloud cover - call stat_update_var_pt( icc, 1, maxval( cloud_frac(1:gr%nz) ), sfc ) - - ! Cloud base - if ( iz_cloud_base > 0 ) then - - k = 1 - do while ( rcm(k) < rc_tol .and. k < gr%nz ) - k = k + 1 - enddo - - if ( k > 1 .AND. k < gr%nz) then - - ! Use linear interpolation to find the exact height of the - ! rc_tol kg/kg level. Brian. - call stat_update_var_pt( iz_cloud_base, 1, lin_int( rc_tol, rcm(k), & - rcm(k-1), gr%zt(k), gr%zt(k-1) ), sfc ) - - else - - ! Set the cloud base output to -10m, if it's clear. - call stat_update_var_pt( iz_cloud_base, 1, -10.0_core_rknd , sfc ) ! Known magic number - - endif - - endif - - ! Liquid Water Path - if ( ilwp > 0 ) then - - xtmp & - = vertical_integral & - ( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & - rcm(2:gr%nz), gr%invrs_dzt(2:gr%nz) ) - - call stat_update_var_pt( ilwp, 1, xtmp, sfc ) - - end if - - ! Vapor Water Path (Preciptable Water) - if ( ivwp > 0 ) then - - xtmp & - = vertical_integral & - ( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & - ( rtm(2:gr%nz) - rcm(2:gr%nz) ), gr%invrs_dzt(2:gr%nz) ) - - call stat_update_var_pt( ivwp, 1, xtmp, sfc ) - - end if - - ! Snow Water Path - if ( iswp > 0 .and. iirsnowm > 0 ) then - - ! Calculate snow water path - xtmp & - = vertical_integral & - ( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & - hydromet(2:gr%nz,iirsnowm), gr%invrs_dzt(2:gr%nz) ) - - call stat_update_var_pt( iswp, 1, xtmp, sfc ) - - end if - - ! Ice Water Path - if ( iiwp > 0 .and. iiricem > 0 ) then - - xtmp & - = vertical_integral & - ( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & - hydromet(2:gr%nz,iiricem), gr%invrs_dzt(2:gr%nz) ) - - call stat_update_var_pt( iiwp, 1, xtmp, sfc ) - - end if - - ! Rain Water Path - if ( irwp > 0 .and. iirrainm > 0 ) then - - xtmp & - = vertical_integral & - ( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & - hydromet(2:gr%nz,iirrainm), gr%invrs_dzt(2:gr%nz) ) - - call stat_update_var_pt( irwp, 1, xtmp, sfc ) - - end if - - ! Vertical average of thermodynamic level variables. - - ! Find the vertical average of thermodynamic level variables, averaged from - ! level 2 (the first thermodynamic level above model surface) through - ! level gr%nz (the top of the model). Use the vertical averaging function - ! found in fill_holes.F90. - - ! Vertical average of thlm. - call stat_update_var_pt( ithlm_vert_avg, 1, & - vertical_avg( (gr%nz-2+1), rho_ds_zt(2:gr%nz), & - thlm(2:gr%nz), gr%invrs_dzt(2:gr%nz) ), & - sfc ) - - ! Vertical average of rtm. - call stat_update_var_pt( irtm_vert_avg, 1, & - vertical_avg( (gr%nz-2+1), rho_ds_zt(2:gr%nz), & - rtm(2:gr%nz), gr%invrs_dzt(2:gr%nz) ), & - sfc ) - - ! Vertical average of um. - call stat_update_var_pt( ium_vert_avg, 1, & - vertical_avg( (gr%nz-2+1), rho_ds_zt(2:gr%nz), & - um(2:gr%nz), gr%invrs_dzt(2:gr%nz) ), & - sfc ) - - ! Vertical average of vm. - call stat_update_var_pt( ivm_vert_avg, 1, & - vertical_avg( (gr%nz-2+1), rho_ds_zt(2:gr%nz), & - vm(2:gr%nz), gr%invrs_dzt(2:gr%nz) ), & - sfc ) - - ! Vertical average of momentum level variables. - - ! Find the vertical average of momentum level variables, averaged over the - ! entire vertical profile (level 1 through level gr%nz). Use the vertical - ! averaging function found in fill_holes.F90. - - ! Vertical average of wp2. - call stat_update_var_pt( iwp2_vert_avg, 1, & - vertical_avg( (gr%nz-1+1), rho_ds_zm(1:gr%nz), & - wp2(1:gr%nz), gr%invrs_dzm(1:gr%nz) ), & - sfc ) - - ! Vertical average of up2. - call stat_update_var_pt( iup2_vert_avg, 1, & - vertical_avg( (gr%nz-1+1), rho_ds_zm(1:gr%nz), & - up2(1:gr%nz), gr%invrs_dzm(1:gr%nz) ), & - sfc ) - - ! Vertical average of vp2. - call stat_update_var_pt( ivp2_vert_avg, 1, & - vertical_avg( (gr%nz-1+1), rho_ds_zm(1:gr%nz), & - vp2(1:gr%nz), gr%invrs_dzm(1:gr%nz) ), & - sfc ) - - ! Vertical average of rtp2. - call stat_update_var_pt( irtp2_vert_avg, 1, & - vertical_avg( (gr%nz-1+1), rho_ds_zm(1:gr%nz), & - rtp2(1:gr%nz), gr%invrs_dzm(1:gr%nz) ), & - sfc ) - - ! Vertical average of thlp2. - call stat_update_var_pt( ithlp2_vert_avg, 1, & - vertical_avg( (gr%nz-1+1), rho_ds_zm(1:gr%nz), & - thlp2(1:gr%nz), gr%invrs_dzm(1:gr%nz) ), & - sfc ) - - - endif ! l_stats_samp - - - return - end subroutine stats_accumulate -!------------------------------------------------------------------------------ - subroutine stats_accumulate_hydromet( hydromet ) -! Description: -! Compute stats related the hydrometeors - -! References: -! None -!------------------------------------------------------------------------------ - use parameters_model, only: & - hydromet_dim ! Variable(s) - - use grid_class, only: & - gr ! Variable(s) - - use array_index, only: & - iirrainm, iirsnowm, iiricem, iirgraupelm, & ! Variable(s) - iiNrm, iiNsnowm, iiNim, iiNgraupelm, iiNcm - - use stats_variables, only: & - irrainm, & ! Variable(s) - irsnowm, & - iricem, & - irgraupelm, & - iNcm, & - iNim, & - iNrm, & - iNsnowm, & - iNgraupelm - - use stats_type, only: & - stat_update_var ! Procedure(s) - - use stats_variables, only: & - zt, & ! Variables - l_stats_samp - - use clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! Input Variables - real( kind = core_rknd ), dimension(gr%nz,hydromet_dim), intent(in) :: & - hydromet ! All hydrometeors except for rcm [units vary] - - if ( l_stats_samp ) then - - if ( iiNcm > 0 ) then - call stat_update_var( iNcm, hydromet(:,iiNcm), zt ) - end if - - if ( iirrainm > 0 ) then - call stat_update_var( irrainm, hydromet(:,iirrainm), zt ) - end if - - if ( iirsnowm > 0 ) then - call stat_update_var( irsnowm, hydromet(:,iirsnowm), zt ) - end if - - if ( iiricem > 0 ) then - call stat_update_var( iricem, hydromet(:,iiricem), zt ) - end if - - if ( iirgraupelm > 0 ) then - call stat_update_var( irgraupelm, & - hydromet(:,iirgraupelm), zt ) - end if - - if ( iiNim > 0 ) then - call stat_update_var( iNim, hydromet(:,iiNim), zt ) - end if - - if ( iiNrm > 0 ) then - call stat_update_var( iNrm, hydromet(:,iiNrm), zt ) - end if - - if ( iiNsnowm > 0 ) then - call stat_update_var( iNsnowm, hydromet(:,iiNsnowm), zt ) - end if - - if ( iiNgraupelm > 0 ) then - call stat_update_var( iNgraupelm, hydromet(:,iiNgraupelm), zt ) - end if - - end if ! l_stats_samp - - return - end subroutine stats_accumulate_hydromet -!------------------------------------------------------------------------------ - subroutine stats_accumulate_LH_tend( LH_hydromet_mc, LH_thlm_mc, LH_rvm_mc, LH_rcm_mc ) -! Description: -! Compute stats for the tendency of latin hypercube sample points. - -! References: -! None -!------------------------------------------------------------------------------ - use parameters_model, only: & - hydromet_dim ! Variable(s) - - use grid_class, only: & - gr ! Variable(s) - - use array_index, only: & - iirrainm, iirsnowm, iiricem, iirgraupelm, & ! Variable(s) - iiNrm, iiNsnowm, iiNim, iiNgraupelm, iiNcm - - use stats_variables, only: & - iLH_rrainm_mc, & ! Variable(s) - iLH_rsnowm_mc, & - iLH_ricem_mc, & - iLH_rgraupelm_mc, & - iLH_Ncm_mc, & - iLH_Nim_mc, & - iLH_Nrm_mc, & - iLH_Nsnowm_mc, & - iLH_Ngraupelm_mc, & - iLH_rcm_mc, & - iLH_rvm_mc, & - iLH_thlm_mc - - use stats_type, only: & - stat_update_var ! Procedure(s) - - use stats_variables, only: & - zt, & ! Variables - l_stats_samp - - use clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! Input Variables - real( kind = core_rknd ), dimension(gr%nz,hydromet_dim), intent(in) :: & - LH_hydromet_mc ! Tendency of hydrometeors except for rvm/rcm [units vary] - - real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & - LH_thlm_mc, & ! Tendency of liquid potential temperature [kg/kg/s] - LH_rcm_mc, & ! Tendency of cloud water [kg/kg/s] - LH_rvm_mc ! Tendency of vapor [kg/kg/s] - - if ( l_stats_samp ) then - - call stat_update_var( iLH_thlm_mc, LH_thlm_mc, zt ) - call stat_update_var( iLH_rcm_mc, LH_rcm_mc, zt ) - call stat_update_var( iLH_rvm_mc, LH_rvm_mc, zt ) - - if ( iiNcm > 0 ) then - call stat_update_var( iLH_Ncm_mc, LH_hydromet_mc(:,iiNcm), zt ) - end if - - if ( iirrainm > 0 ) then - call stat_update_var( iLH_rrainm_mc, LH_hydromet_mc(:,iirrainm), zt ) - end if - - if ( iirsnowm > 0 ) then - call stat_update_var( iLH_rsnowm_mc, LH_hydromet_mc(:,iirsnowm), zt ) - end if - - if ( iiricem > 0 ) then - call stat_update_var( iLH_ricem_mc, LH_hydromet_mc(:,iiricem), zt ) - end if - - if ( iirgraupelm > 0 ) then - call stat_update_var( iLH_rgraupelm_mc, LH_hydromet_mc(:,iirgraupelm), zt ) - end if - - if ( iiNim > 0 ) then - call stat_update_var( iLH_Nim_mc, LH_hydromet_mc(:,iiNim), zt ) - end if - - if ( iiNrm > 0 ) then - call stat_update_var( iLH_Nrm_mc, LH_hydromet_mc(:,iiNrm), zt ) - end if - - if ( iiNsnowm > 0 ) then - call stat_update_var( iLH_Nsnowm_mc, LH_hydromet_mc(:,iiNsnowm), zt ) - end if - - if ( iiNgraupelm > 0 ) then - call stat_update_var( iLH_Ngraupelm_mc, LH_hydromet_mc(:,iiNgraupelm), zt ) - end if - - end if ! l_stats_samp - - return - end subroutine stats_accumulate_LH_tend - - !----------------------------------------------------------------------- - subroutine stats_finalize( ) - - ! Description: - ! Close NetCDF files and deallocate scratch space and - ! stats file structures. - !----------------------------------------------------------------------- - - use stats_variables, only: & - zt, & ! Variable(s) - zm, & - rad_zt, & - rad_zm, & - sfc, & - l_netcdf, & - l_stats, & - l_output_rad_files - - use stats_variables, only: & - ztscr01, & ! Variable(s) - ztscr02, & - ztscr03, & - ztscr04, & - ztscr05, & - ztscr06, & - ztscr07, & - ztscr08, & - ztscr09, & - ztscr10, & - ztscr11, & - ztscr12, & - ztscr13, & - ztscr14, & - ztscr15, & - ztscr16, & - ztscr17, & - ztscr18, & - ztscr19, & - ztscr20, & - ztscr21 - - use stats_variables, only: & - zmscr01, & ! Variable(s) - zmscr02, & - zmscr03, & - zmscr04, & - zmscr05, & - zmscr06, & - zmscr07, & - zmscr08, & - zmscr09, & - zmscr10, & - zmscr11, & - zmscr12, & - zmscr13, & - zmscr14, & - zmscr15, & - zmscr16, & - zmscr17 - - !use stats_variables, only: & - ! radscr01, & ! Variable(s) - ! radscr02, & - ! radscr03, & - ! radscr04, & - ! radscr05, & - ! radscr06, & - ! radscr07, & - ! radscr08, & - ! radscr09, & - ! radscr10, & - ! radscr11, & - ! radscr12, & - ! radscr13, & - ! radscr14, & - ! radscr15, & - ! radscr16, & - ! radscr17 - - use stats_variables, only: & - isclrm, & - isclrm_f, & - iedsclrm, & - iedsclrm_f, & - isclrprtp, & - isclrp2, & - isclrpthvp, & - isclrpthlp, & - isclrprcp, & - iwpsclrp, & - iwp2sclrp, & - iwpsclrp2, & - iwpsclrprtp, & - iwpsclrpthlp, & - iwpedsclrp - -#ifdef NETCDF - use output_netcdf, only: & - close_netcdf ! Procedure -#endif - - implicit none - - if ( l_stats .and. l_netcdf ) then -#ifdef NETCDF - call close_netcdf( zt%f ) - call close_netcdf( zm%f ) - call close_netcdf( rad_zt%f ) - call close_netcdf( rad_zm%f ) - call close_netcdf( sfc%f ) -#else - stop "This program was not compiled with netCDF support" -#endif - end if - - if ( l_stats ) then - ! De-allocate all zt variables - deallocate( zt%z ) - - deallocate( zt%x ) - - deallocate( zt%n ) - deallocate( zt%l_in_update ) - - - deallocate( zt%f%var ) - deallocate( zt%f%z ) - deallocate( zt%f%rlat ) - deallocate( zt%f%rlon ) - - deallocate ( ztscr01 ) - deallocate ( ztscr02 ) - deallocate ( ztscr03 ) - deallocate ( ztscr04 ) - deallocate ( ztscr05 ) - deallocate ( ztscr06 ) - deallocate ( ztscr07 ) - deallocate ( ztscr08 ) - deallocate ( ztscr09 ) - deallocate ( ztscr10 ) - deallocate ( ztscr11 ) - deallocate ( ztscr12 ) - deallocate ( ztscr13 ) - deallocate ( ztscr14 ) - deallocate ( ztscr15 ) - deallocate ( ztscr16 ) - deallocate ( ztscr17 ) - deallocate ( ztscr18 ) - deallocate ( ztscr19 ) - deallocate ( ztscr20 ) - deallocate ( ztscr21 ) - - ! De-allocate all zm variables - deallocate( zm%z ) - - deallocate( zm%x ) - deallocate( zm%n ) - - deallocate( zm%f%var ) - deallocate( zm%f%z ) - deallocate( zm%f%rlat ) - deallocate( zm%f%rlon ) - deallocate( zm%l_in_update ) - - deallocate ( zmscr01 ) - deallocate ( zmscr02 ) - deallocate ( zmscr03 ) - deallocate ( zmscr04 ) - deallocate ( zmscr05 ) - deallocate ( zmscr06 ) - deallocate ( zmscr07 ) - deallocate ( zmscr08 ) - deallocate ( zmscr09 ) - deallocate ( zmscr10 ) - deallocate ( zmscr11 ) - deallocate ( zmscr12 ) - deallocate ( zmscr13 ) - deallocate ( zmscr14 ) - deallocate ( zmscr15 ) - deallocate ( zmscr16 ) - deallocate ( zmscr17 ) - - if (l_output_rad_files) then - ! De-allocate all rad_zt variables - deallocate( rad_zt%z ) - - deallocate( rad_zt%x ) - deallocate( rad_zt%n ) - - deallocate( rad_zt%f%var ) - deallocate( rad_zt%f%z ) - deallocate( rad_zt%f%rlat ) - deallocate( rad_zt%f%rlon ) - deallocate( rad_zt%l_in_update ) - - ! De-allocate all rad_zm variables - deallocate( rad_zm%z ) - - deallocate( rad_zm%x ) - deallocate( rad_zm%n ) - - deallocate( rad_zm%f%var ) - deallocate( rad_zm%f%z ) - deallocate( rad_zm%l_in_update ) - - !deallocate ( radscr01 ) - !deallocate ( radscr02 ) - !deallocate ( radscr03 ) - !deallocate ( radscr04 ) - !deallocate ( radscr05 ) - !deallocate ( radscr06 ) - !deallocate ( radscr07 ) - !deallocate ( radscr08 ) - !deallocate ( radscr09 ) - !deallocate ( radscr10 ) - !deallocate ( radscr11 ) - !deallocate ( radscr12 ) - !deallocate ( radscr13 ) - !deallocate ( radscr14 ) - !deallocate ( radscr15 ) - !deallocate ( radscr16 ) - !deallocate ( radscr17 ) - end if ! l_output_rad_files - - ! De-allocate all sfc variables - deallocate( sfc%z ) - - deallocate( sfc%x ) - deallocate( sfc%n ) - deallocate( sfc%l_in_update ) - - deallocate( sfc%f%var ) - deallocate( sfc%f%z ) - deallocate( sfc%f%rlat ) - deallocate( sfc%f%rlon ) - - ! De-allocate scalar indices - deallocate( isclrm ) - deallocate( isclrm_f ) - deallocate( iedsclrm ) - deallocate( iedsclrm_f ) - deallocate( isclrprtp ) - deallocate( isclrp2 ) - deallocate( isclrpthvp ) - deallocate( isclrpthlp ) - deallocate( isclrprcp ) - deallocate( iwpsclrp ) - deallocate( iwp2sclrp ) - deallocate( iwpsclrp2 ) - deallocate( iwpsclrprtp ) - deallocate( iwpsclrpthlp ) - deallocate( iwpedsclrp ) - - endif ! l_stats - - - return - end subroutine stats_finalize - -!=============================================================================== - -end module stats_subs diff --git a/models/atm/cam/src/physics/clubb/stats_type.F90 b/models/atm/cam/src/physics/clubb/stats_type.F90 index f0c62f58f07d..5bbcb74daa93 100644 --- a/models/atm/cam/src/physics/clubb/stats_type.F90 +++ b/models/atm/cam/src/physics/clubb/stats_type.F90 @@ -1,5 +1,5 @@ !----------------------------------------------------------------------- -! $Id: stats_type.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +! $Id: stats_type.F90 6952 2014-06-17 15:59:47Z schemena@uwm.edu $ !=============================================================================== module stats_type @@ -20,505 +20,43 @@ module stats_type private ! Set Default Scope - public :: stats, & - stat_assign, & - stat_update_var, & - stat_update_var_pt, & - stat_begin_update, & - stat_begin_update_pt, & - stat_end_update, & - stat_end_update_pt, & - stat_modify, & - stat_modify_pt + public :: stats ! Derived data types to store GrADS/netCDF statistics type stats ! Number of fields to sample - integer :: nn + integer :: num_output_fields ! Number of variables being output to disk (e.g. + ! cloud_frac, rain rate, etc.) - ! Vertical extent of variable - integer :: kk + integer :: & + ii, & ! Horizontal extent of the variables (Usually 1 for the single-column model) + jj, & ! Horizontal extent of the variables (Usually 1 for the single-column model) + kk ! Vertical extent of the variables (Usually gr%nz from grid_class) ! Vertical levels - real( kind = core_rknd ), pointer, dimension(:) :: z + real( kind = core_rknd ), pointer, dimension(:) :: z ! altitude [m] ! Array to store sampled fields - real(kind=stat_rknd), pointer, dimension(:,:,:,:) :: x + real(kind=stat_rknd), pointer, dimension(:,:,:,:) :: accum_field_values + ! The variable accum_field_values contains the cumulative sums + ! of accum_num_samples sample values of each + ! of the num_output_fields (e.g. the sum of the sampled rain rate values) - integer(kind=stat_nknd), pointer, dimension(:,:,:,:) :: n + integer(kind=stat_nknd), pointer, dimension(:,:,:,:) :: accum_num_samples + ! accum_num_samples is the number of samples for each of the num_output_fields fields + ! and each of the kk vertical levels ! Tracks if a field is in the process of an update logical, pointer, dimension(:,:,:,:) :: l_in_update ! Data for GrADS / netCDF output - type (stat_file) f + type (stat_file) :: file end type stats - contains - - !============================================================================= - subroutine stat_assign( var_index, var_name, & - var_description, var_units, grid_kind ) - - ! Description: - ! Assigns pointers for statistics variables in grid. - !----------------------------------------------------------------------- - - implicit none - - ! Input Variables - - integer,intent(in) :: var_index ! Variable index [#] - character(len = *), intent(in) :: var_name ! Variable name [] - character(len = *), intent(in) :: var_description ! Variable description [] - character(len = *), intent(in) :: var_units ! Variable units [] - - ! Output Variable - - ! Which grid the variable is located on (zt, zm, or sfc ) - type(stats), intent(inout) :: grid_kind - - grid_kind%f%var(var_index)%ptr => grid_kind%x(:,:,:,var_index) - grid_kind%f%var(var_index)%name = var_name - grid_kind%f%var(var_index)%description = var_description - grid_kind%f%var(var_index)%units = var_units - - !Example of the old format - !changed by Joshua Fasching 23 August 2007 - - !zt%f%var(ithlm)%ptr => zt%x(:,k) - !zt%f%var(ithlm)%name = "thlm" - !zt%f%var(ithlm)%description = "thetal (K)" - !zt%f%var(ithlm)%units = "K" - - return - - end subroutine stat_assign - - !============================================================================= - subroutine stat_update_var( var_index, value, grid_kind ) - - ! Description: - ! This updates the value of a statistics variable located at var_index - ! associated with grid type 'grid_kind' (zt, zm, or sfc). - ! - ! This subroutine is used when a statistical variable needs to be updated - ! only once during a model timestep. - ! - ! In regards to budget terms, this subroutine is used for variables that - ! are either completely implicit (e.g. wprtp_ma) or completely explicit - ! (e.g. wp2_pr3). For completely implicit terms, once the variable has been - ! solved for, the implicit contribution can be finalized. The finalized - ! implicit contribution is sent into stat_update_var_pt. For completely - ! explicit terms, the explicit contribution is sent into stat_update_var_pt - ! once it has been calculated. - !--------------------------------------------------------------------- - - use clubb_precision, only: & - stat_rknd ! Constant - - implicit none - - ! Input Variables(s) - - integer, intent(in) :: & - var_index ! The index at which the variable is stored [] - - ! Input/Output Variable(s) - type(stats), intent(inout) :: & - grid_kind ! Which grid the variable is located on (zt, zm, rad, or sfc ) - - ! Input Variable(s) NOTE: Due to the implicit none above, these must - ! be declared below to allow the use of grid_kind - - real( kind = core_rknd ), dimension(grid_kind%kk), intent(in) :: & - value ! Value of field being added to the statistic [Units Vary] - - integer :: k - - if ( var_index > 0 ) then - do k = 1, grid_kind%kk - grid_kind%x(1,1,k,var_index) = & - grid_kind%x(1,1,k,var_index) + real( value(k), kind=stat_rknd ) - grid_kind%n(1,1,k,var_index) = & - grid_kind%n(1,1,k,var_index) + 1 - end do - endif - - return - end subroutine stat_update_var - - !============================================================================= - subroutine stat_update_var_pt( var_index, grid_level, value, grid_kind ) - - ! Description: - ! This updates the value of a statistics variable located at var_index - ! associated with grid type 'grid_kind' at a specific grid_level. - ! - ! See the description of stat_update_var for more details. - !--------------------------------------------------------------------- - - use clubb_precision, only: & - stat_rknd ! Constant - - implicit none - - ! Input Variables(s) - - integer, intent(in) :: & - var_index, & ! The index at which the variable is stored [] - grid_level ! The level at which the variable is to be modified [] - - real( kind = core_rknd ), intent(in) :: & - value ! Value of field being added to the statistic [Units Vary] - - ! Input/Output Variable(s) - type(stats), intent(inout) :: & - grid_kind ! Which grid the variable is located on (zt, zm, rad, or sfc). - - if ( var_index > 0 ) then - - grid_kind%x(1,1,grid_level,var_index) = grid_kind%x(1,1,grid_level,var_index) & - + real( value, kind=stat_rknd ) - - grid_kind%n(1,1,grid_level,var_index) = grid_kind%n(1,1,grid_level,var_index) + 1 - - endif - - return - end subroutine stat_update_var_pt - - !============================================================================= - subroutine stat_begin_update( var_index, value, & - grid_kind ) - - ! Description: - ! This begins an update of the value of a statistics variable located at - ! var_index on the (zt, zm, or sfc) grid. It is used in conjunction with - ! subroutine stat_end_update. - ! - ! This subroutine is used when a statistical variable needs to be updated - ! more than one time during a model timestep. Commonly, this is used for - ! beginning a budget term calculation. - ! - ! In this type of stats calculation, we first subtract the field - ! (e.g. rtm / dt ) from the statistic, then update rtm by a term - ! (e.g. clip rtm), and then re-add the field (e.g. rtm / dt) to the - ! statistic. - ! - ! Example: - ! - ! call stat_begin_update( irtm_bt, real(rtm / dt), zt ) - ! - ! !!! Perform clipping of rtm !!! - ! - ! call stat_end_update( irtm_bt, real(rtm / dt), zt ) - ! - ! This subroutine is often used with stats budget terms for variables that - ! have both implicit and explicit components (e.g. wp3_ta). The explicit - ! component is sent into stat_begin_update_pt (with the sign reversed - ! because stat_begin_update_pt automatically subtracts the value sent into - ! it). Then, once the variable has been solved for, the implicit - ! statistical contribution can be finalized. The finalized implicit - ! component is sent into stat_end_update_pt. - !--------------------------------------------------------------------- - - use grid_class, only: gr ! Variable(s) - - implicit none - - ! Input Variables(s) - - integer, intent(in) :: & - var_index ! The index at which the variable is stored [] - - real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & - value ! Value of field being added to the statistic [Units Vary] - - ! Input/Output Variable(s) - type(stats), intent(inout) :: & - grid_kind ! Which grid the variable is located on (zt, zm, rad, or sfc). - - integer :: i - - do i = 1, gr%nz - - call stat_begin_update_pt & - ( var_index, i, value(i), grid_kind ) - - enddo - - return - end subroutine stat_begin_update - - !============================================================================= - subroutine stat_begin_update_pt & - ( var_index, grid_level, value, grid_kind ) - - ! Description: - ! This begins an update of the value of a statistics variable located at - ! var_index associated with the grid type (grid_kind) at a specific - ! grid_level. It is used in conjunction with subroutine stat_end_update_pt. - ! - ! Notes: - ! Commonly this is used for beginning a budget. See the description of - ! stat_begin_update for more details. - ! - ! References: - ! None - !--------------------------------------------------------------------- - - use error_code, only: clubb_debug ! Procedure(s) - - use clubb_precision, only: & - stat_rknd ! Constant - - implicit none - - ! Input Variables(s) - - integer, intent(in) :: & - var_index, & ! The index at which the variable is stored [] - grid_level ! The level at which the variable is to be modified [] - - real( kind = core_rknd ), intent(in) :: & - value ! Value of field being added to the statistic [Units Vary] - - ! Input/Output Variable(s) - type(stats), intent(inout) :: & - grid_kind ! Which grid the variable is located on (zt, zm, rad, or sfc). - - ! ---- Begin Code ---- - - if ( var_index > 0 ) then ! Are we storing this variable? - - if ( .not. grid_kind%l_in_update(1,1,grid_level,var_index) ) then ! Can we begin an update? - - grid_kind%x(1,1,grid_level, var_index) = & - grid_kind%x(1,1,grid_level, var_index) - real( value, kind=stat_rknd ) - - grid_kind%l_in_update(1,1,grid_level, var_index) = .true. ! Start Record - - else - - call clubb_debug( 1, & - "Beginning an update before finishing previous for variable: "// & - trim( grid_kind%f%var(var_index)%name ) ) - endif - - endif - - return - end subroutine stat_begin_update_pt - - !============================================================================= - subroutine stat_end_update( var_index, value, grid_kind ) - - ! Description: - ! This ends an update of the value of a statistics variable located at - ! var_index on the (zt, zm, or sfc) grid. It is used in conjunction with - ! subroutine stat_begin_update. - ! - ! This subroutine is used when a statistical variable needs to be updated - ! more than one time during a model timestep. Commonly, this is used for - ! finishing a budget term calculation. - ! - ! In this type of stats calculation, we first subtract the field - ! (e.g. rtm / dt ) from the statistic, then update rtm by a term - ! (e.g. clip rtm), and then re-add the field (e.g. rtm / dt) to the - ! statistic. - ! - ! Example: - ! - ! call stat_begin_update( irtm_bt, real(rtm / dt), zt ) - ! - ! !!! Perform clipping of rtm !!! - ! - ! call stat_end_update( irtm_bt, real(rtm / dt), zt ) - ! - ! This subroutine is often used with stats budget terms for variables that - ! have both implicit and explicit components (e.g. wp3_ta). The explicit - ! component is sent into stat_begin_update_pt (with the sign reversed - ! because stat_begin_update_pt automatically subtracts the value sent into - ! it). Then, once the variable has been solved for, the implicit - ! statistical contribution can be finalized. The finalized implicit - ! component is sent into stat_end_update_pt. - !--------------------------------------------------------------------- - - use grid_class, only: gr ! Variable(s) - - implicit none - - ! Input Variables(s) - - integer, intent(in) :: & - var_index ! The index at which the variable is stored [] - - real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & - value ! Value of field being added to the statistic [Units Vary] - - ! Input/Output Variable(s) - type(stats), intent(inout) :: & - grid_kind ! Which grid the variable is located on (zt, zm, rad, or sfc). - - integer :: i - - ! ---- Begin Code ---- - - do i = 1,gr%nz - call stat_end_update_pt & - ( var_index, i, value(i), grid_kind ) - enddo - - return - end subroutine stat_end_update - - !============================================================================= - subroutine stat_end_update_pt & - ( var_index, grid_level, value, grid_kind ) - - ! Description: - ! This ends an update of the value of a statistics variable located at - ! var_index associated with the grid type (grid_kind) at a specific - ! grid_level. It is used in conjunction with subroutine - ! stat_begin_update_pt. - ! - ! Commonly this is used for finishing a budget. See the description of - ! stat_end_update for more details. - !--------------------------------------------------------------------- - - use error_code, only: clubb_debug ! Procedure(s) - - implicit none - - ! Input Variables(s) - - integer, intent(in) :: & - var_index, & ! The index at which the variable is stored [] - grid_level ! The level at which the variable is to be modified [] - - real( kind = core_rknd ), intent(in) :: & - value ! Value of field being added to the statistic [Units Vary] - - ! Input/Output Variable(s) - type(stats), intent(inout) :: & - grid_kind ! Which grid the variable is located on (zt, zm, rad, or sfc). - - ! ---- Begin Code ---- - - if ( var_index > 0 ) then ! Are we storing this variable? - - if ( grid_kind%l_in_update(1,1,grid_level,var_index) ) then ! Can we end an update? - - call stat_update_var_pt & - ( var_index, grid_level, value, grid_kind ) - - grid_kind%l_in_update(1,1,grid_level,var_index) = .false. ! End Record - - else - - call clubb_debug( 1, "Ending before beginning update. For variable "// & - grid_kind%f%var(var_index)%name ) - - endif - - endif - - return - end subroutine stat_end_update_pt - - !============================================================================= - subroutine stat_modify( var_index, value, & - grid_kind ) - - ! Description: - ! This modifies the value of a statistics variable located at var_index on - ! the (zt, zm, or sfc) grid. It does not increment the sampling count. - ! - ! This subroutine is normally used when a statistical variable needs to be - ! updated more than twice during a model timestep. Commonly, this is used - ! if a budget term calculation needs an intermediate modification between - ! stat_begin_update and stat_end_update. - !--------------------------------------------------------------------- - - use grid_class, only: gr ! Variable(s) - - implicit none - - ! Input Variables(s) - - integer, intent(in) :: & - var_index ! The index at which the variable is stored [] - - real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & - value ! Value of field being added to the statistic [Units Vary] - - ! Input/Output Variable(s) - type(stats), intent(inout) :: & - grid_kind ! Which grid the variable is located on (zt, zm, rad, or sfc). - - integer :: i - - ! ---- Begin Code ---- - - do i = 1, gr%nz - - call stat_modify_pt( var_index, i, value(i), grid_kind ) - - enddo - - return - end subroutine stat_modify - - !============================================================================= - subroutine stat_modify_pt( var_index, grid_level, value, & - grid_kind ) - - ! Description: - ! This modifies the value of a statistics variable located at var_index on - ! the grid at a specific point. It does not increment the sampling count. - ! - ! Commonly this is used for intermediate updates to a budget. See the - ! description of stat_modify for more details. - !--------------------------------------------------------------------- - - use clubb_precision, only: & - stat_rknd ! Constant - - implicit none - - ! Input Variables(s) - - integer, intent(in) :: & - var_index ! The index at which the variable is stored [] - - - real( kind = core_rknd ), intent(in) :: & - value ! Value of field being added to the statistic [Units Vary] - - integer, intent(in) :: & - grid_level ! The level at which the variable is to be modified [] - - ! Input/Output Variable(s) - type(stats), intent(inout) :: & - grid_kind ! Which grid the variable is located on (zt, zm, rad, or sfc). - - ! ---- Begin Code ---- - - if ( var_index > 0 ) then - - grid_kind%x(1,1,grid_level,var_index ) & - = grid_kind%x(1,1,grid_level,var_index ) + real( value, kind=stat_rknd ) - - end if - - return - end subroutine stat_modify_pt +end module stats_type -!=============================================================================== -end module stats_type diff --git a/models/atm/cam/src/physics/clubb/stats_type_utilities.F90 b/models/atm/cam/src/physics/clubb/stats_type_utilities.F90 new file mode 100644 index 000000000000..2595f6d4b1ff --- /dev/null +++ b/models/atm/cam/src/physics/clubb/stats_type_utilities.F90 @@ -0,0 +1,525 @@ +!----------------------------------------------------------------------- +! $Id: stats_type_utilities.F90 7315 2014-09-30 20:49:54Z schemena@uwm.edu $ +!=============================================================================== +module stats_type_utilities + + ! Description: + ! Contains subroutines for interfacing with type, stats + !----------------------------------------------------------------------- + + use stats_type, only: & + stats ! type + + use clubb_precision, only: & + core_rknd + + implicit none + + private ! Set Default Scope + + public :: stat_assign, & + stat_update_var, & + stat_update_var_pt, & + stat_begin_update, & + stat_begin_update_pt, & + stat_end_update, & + stat_end_update_pt, & + stat_modify, & + stat_modify_pt + contains + + !============================================================================= + subroutine stat_assign( var_index, var_name, & + var_description, var_units, & + l_silhs, grid_kind ) + + ! Description: + ! Assigns pointers for statistics variables in grid. There is an + ! option to make the variable a SILHS variable (updated n_microphys_calls + ! times per timestep rather than just once). + + ! + ! References: + ! None + !----------------------------------------------------------------------- + + implicit none + + ! Input Variables + + integer,intent(in) :: var_index ! Variable index [#] + character(len = *), intent(in) :: var_name ! Variable name [] + character(len = *), intent(in) :: var_description ! Variable description [] + character(len = *), intent(in) :: var_units ! Variable units [] + + logical, intent(in) :: l_silhs ! SILHS variable [boolean] + + ! Input/Output Variable + + ! Which grid the variable is located on (e.g., zt, zm, sfc) + type(stats), intent(inout) :: grid_kind + + grid_kind%file%var(var_index)%ptr => grid_kind%accum_field_values(:,:,:,var_index) + grid_kind%file%var(var_index)%name = var_name + grid_kind%file%var(var_index)%description = var_description + grid_kind%file%var(var_index)%units = var_units + + grid_kind%file%var(var_index)%l_silhs = l_silhs + + !Example of the old format + !changed by Joshua Fasching 23 August 2007 + + !stats_zt%file%var(ithlm)%ptr => stats_zt%accum_field_values(:,k) + !stats_zt%file%var(ithlm)%name = "thlm" + !stats_zt%file%var(ithlm)%description = "thetal (K)" + !stats_zt%file%var(ithlm)%units = "K" + + return + + end subroutine stat_assign + + !============================================================================= + subroutine stat_update_var( var_index, value, grid_kind ) + + ! Description: + ! This updates the value of a statistics variable located at var_index + ! associated with grid type 'grid_kind' (zt, zm, or sfc). + ! + ! This subroutine is used when a statistical variable needs to be updated + ! only once during a model timestep. + ! + ! In regards to budget terms, this subroutine is used for variables that + ! are either completely implicit (e.g. wprtp_ma) or completely explicit + ! (e.g. wp2_pr3). For completely implicit terms, once the variable has been + ! solved for, the implicit contribution can be finalized. The finalized + ! implicit contribution is sent into stat_update_var_pt. For completely + ! explicit terms, the explicit contribution is sent into stat_update_var_pt + ! once it has been calculated. + !--------------------------------------------------------------------- + + use clubb_precision, only: & + stat_rknd ! Constant + + use stat_file_module, only: & + clubb_i, clubb_j ! Variable(s) + + implicit none + + ! Input Variables(s) + + integer, intent(in) :: & + var_index ! The index at which the variable is stored [] + + ! Input/Output Variable(s) + type(stats), intent(inout) :: & + grid_kind ! Which grid the variable is located on (zt, zm, rad, or sfc ) + + ! Input Variable(s) NOTE: Due to the implicit none above, these must + ! be declared below to allow the use of grid_kind + + real( kind = core_rknd ), dimension(grid_kind%kk), intent(in) :: & + value ! Value of field being added to the statistic [Units Vary] + + integer :: k + + if ( var_index > 0 ) then + do k = 1, grid_kind%kk + grid_kind%accum_field_values(clubb_i,clubb_j,k,var_index) = & + grid_kind%accum_field_values(clubb_i,clubb_j,k,var_index) + real( value(k), & + kind=stat_rknd ) + grid_kind%accum_num_samples(clubb_i,clubb_j,k,var_index) = & + grid_kind%accum_num_samples(clubb_i,clubb_j,k,var_index) + 1 + end do + endif + + return + end subroutine stat_update_var + + !============================================================================= + subroutine stat_update_var_pt( var_index, grid_level, value, grid_kind ) + + ! Description: + ! This updates the value of a statistics variable located at var_index + ! associated with grid type 'grid_kind' at a specific grid_level. + ! + ! See the description of stat_update_var for more details. + !--------------------------------------------------------------------- + + use clubb_precision, only: & + stat_rknd ! Constant + + use stat_file_module, only: & + clubb_i, clubb_j ! Variable(s) + + implicit none + + ! Input Variables(s) + + integer, intent(in) :: & + var_index, & ! The index at which the variable is stored [] + grid_level ! The level at which the variable is to be modified [] + + real( kind = core_rknd ), intent(in) :: & + value ! Value of field being added to the statistic [Units Vary] + + ! Input/Output Variable(s) + type(stats), intent(inout) :: & + grid_kind ! Which grid the variable is located on (zt, zm, rad, or sfc). + + if ( var_index > 0 ) then + + grid_kind%accum_field_values(clubb_i,clubb_j,grid_level,var_index) = & + grid_kind%accum_field_values(clubb_i,clubb_j,grid_level,var_index) + & + real( value, kind=stat_rknd ) + + grid_kind%accum_num_samples(clubb_i,clubb_j,grid_level,var_index) = & + grid_kind%accum_num_samples(clubb_i,clubb_j,grid_level,var_index) + 1 + + endif + + return + end subroutine stat_update_var_pt + + !============================================================================= + subroutine stat_begin_update( var_index, value, & + grid_kind ) + + ! Description: + ! This begins an update of the value of a statistics variable located at + ! var_index on the (zt, zm, or sfc) grid. It is used in conjunction with + ! subroutine stat_end_update. + ! + ! This subroutine is used when a statistical variable needs to be updated + ! more than one time during a model timestep. Commonly, this is used for + ! beginning a budget term calculation. + ! + ! In this type of stats calculation, we first subtract the field + ! (e.g. rtm / dt ) from the statistic, then update rtm by a term + ! (e.g. clip rtm), and then re-add the field (e.g. rtm / dt) to the + ! statistic. + ! + ! Example: + ! + ! call stat_begin_update( irtm_bt, real(rtm / dt), stats_zt ) + ! + ! !!! Perform clipping of rtm !!! + ! + ! call stat_end_update( irtm_bt, real(rtm / dt), stats_zt ) + ! + ! This subroutine is often used with stats budget terms for variables that + ! have both implicit and explicit components (e.g. wp3_ta). The explicit + ! component is sent into stat_begin_update_pt (with the sign reversed + ! because stat_begin_update_pt automatically subtracts the value sent into + ! it). Then, once the variable has been solved for, the implicit + ! statistical contribution can be finalized. The finalized implicit + ! component is sent into stat_end_update_pt. + !--------------------------------------------------------------------- + + use grid_class, only: gr ! Variable(s) + + implicit none + + ! Input Variables(s) + + integer, intent(in) :: & + var_index ! The index at which the variable is stored [] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + value ! Value of field being added to the statistic [Units Vary] + + ! Input/Output Variable(s) + type(stats), intent(inout) :: & + grid_kind ! Which grid the variable is located on (zt, zm, rad, or sfc). + + integer :: i + + do i = 1, gr%nz + + call stat_begin_update_pt & + ( var_index, i, value(i), grid_kind ) + + enddo + + return + end subroutine stat_begin_update + + !============================================================================= + subroutine stat_begin_update_pt & + ( var_index, grid_level, value, grid_kind ) + + ! Description: + ! This begins an update of the value of a statistics variable located at + ! var_index associated with the grid type (grid_kind) at a specific + ! grid_level. It is used in conjunction with subroutine stat_end_update_pt. + ! + ! Notes: + ! Commonly this is used for beginning a budget. See the description of + ! stat_begin_update for more details. + ! + ! References: + ! None + !--------------------------------------------------------------------- + + use error_code, only: clubb_debug ! Procedure(s) + + use clubb_precision, only: & + stat_rknd ! Constant + + use stat_file_module, only: & + clubb_i, clubb_j ! Variable(s) + + implicit none + + ! Input Variables(s) + + integer, intent(in) :: & + var_index, & ! The index at which the variable is stored [] + grid_level ! The level at which the variable is to be modified [] + + real( kind = core_rknd ), intent(in) :: & + value ! Value of field being added to the statistic [Units Vary] + + ! Input/Output Variable(s) + type(stats), intent(inout) :: & + grid_kind ! Which grid the variable is located on (zt, zm, rad, or sfc). + + ! ---- Begin Code ---- + + if ( var_index > 0 ) then ! Are we storing this variable? + + ! Can we begin an update? + if ( .not. grid_kind%l_in_update(clubb_i,clubb_j,grid_level,var_index) ) then + + grid_kind%accum_field_values(clubb_i,clubb_j,grid_level, var_index) = & + grid_kind%accum_field_values(clubb_i,clubb_j,grid_level, var_index) - & + real( value, kind=stat_rknd ) + + grid_kind%l_in_update(clubb_i,clubb_j,grid_level, var_index) = .true. ! Start Record + + else + + call clubb_debug( 1, & + "Beginning an update before finishing previous for variable: "// & + trim( grid_kind%file%var(var_index)%name ) ) + endif + + endif + + return + end subroutine stat_begin_update_pt + + !============================================================================= + subroutine stat_end_update( var_index, value, grid_kind ) + + ! Description: + ! This ends an update of the value of a statistics variable located at + ! var_index on the (zt, zm, or sfc) grid. It is used in conjunction with + ! subroutine stat_begin_update. + ! + ! This subroutine is used when a statistical variable needs to be updated + ! more than one time during a model timestep. Commonly, this is used for + ! finishing a budget term calculation. + ! + ! In this type of stats calculation, we first subtract the field + ! (e.g. rtm / dt ) from the statistic, then update rtm by a term + ! (e.g. clip rtm), and then re-add the field (e.g. rtm / dt) to the + ! statistic. + ! + ! Example: + ! + ! call stat_begin_update( irtm_bt, real(rtm / dt), stats_zt ) + ! + ! !!! Perform clipping of rtm !!! + ! + ! call stat_end_update( irtm_bt, real(rtm / dt), stats_zt ) + ! + ! This subroutine is often used with stats budget terms for variables that + ! have both implicit and explicit components (e.g. wp3_ta). The explicit + ! component is sent into stat_begin_update_pt (with the sign reversed + ! because stat_begin_update_pt automatically subtracts the value sent into + ! it). Then, once the variable has been solved for, the implicit + ! statistical contribution can be finalized. The finalized implicit + ! component is sent into stat_end_update_pt. + !--------------------------------------------------------------------- + + use grid_class, only: gr ! Variable(s) + + implicit none + + ! Input Variables(s) + + integer, intent(in) :: & + var_index ! The index at which the variable is stored [] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + value ! Value of field being added to the statistic [Units Vary] + + ! Input/Output Variable(s) + type(stats), intent(inout) :: & + grid_kind ! Which grid the variable is located on (zt, zm, rad, or sfc). + + integer :: k + + ! ---- Begin Code ---- + + do k = 1,gr%nz + call stat_end_update_pt & + ( var_index, k, value(k), grid_kind ) + enddo + + return + end subroutine stat_end_update + + !============================================================================= + subroutine stat_end_update_pt & + ( var_index, grid_level, value, grid_kind ) + + ! Description: + ! This ends an update of the value of a statistics variable located at + ! var_index associated with the grid type (grid_kind) at a specific + ! grid_level. It is used in conjunction with subroutine + ! stat_begin_update_pt. + ! + ! Commonly this is used for finishing a budget. See the description of + ! stat_end_update for more details. + !--------------------------------------------------------------------- + + use error_code, only: clubb_debug ! Procedure(s) + + use stat_file_module, only: & + clubb_i, clubb_j ! Variable(s) + + implicit none + + ! Input Variables(s) + + integer, intent(in) :: & + var_index, & ! The index at which the variable is stored [] + grid_level ! The level at which the variable is to be modified [] + + real( kind = core_rknd ), intent(in) :: & + value ! Value of field being added to the statistic [Units Vary] + + ! Input/Output Variable(s) + type(stats), intent(inout) :: & + grid_kind ! Which grid the variable is located on (zt, zm, rad, or sfc). + + ! ---- Begin Code ---- + + if ( var_index > 0 ) then ! Are we storing this variable? + + ! Can we end an update? + if ( grid_kind%l_in_update(clubb_i,clubb_j,grid_level,var_index) ) then + + call stat_update_var_pt & + ( var_index, grid_level, value, grid_kind ) + + grid_kind%l_in_update(clubb_i,clubb_j,grid_level,var_index) = .false. ! End Record + + else + + call clubb_debug( 1, "Ending before beginning update. For variable "// & + grid_kind%file%var(var_index)%name ) + + endif + + endif + + return + end subroutine stat_end_update_pt + + !============================================================================= + subroutine stat_modify( var_index, value, & + grid_kind ) + + ! Description: + ! This modifies the value of a statistics variable located at var_index on + ! the (zt, zm, or sfc) grid. It does not increment the sampling count. + ! + ! This subroutine is normally used when a statistical variable needs to be + ! updated more than twice during a model timestep. Commonly, this is used + ! if a budget term calculation needs an intermediate modification between + ! stat_begin_update and stat_end_update. + !--------------------------------------------------------------------- + + use grid_class, only: gr ! Variable(s) + + implicit none + + ! Input Variables(s) + + integer, intent(in) :: & + var_index ! The index at which the variable is stored [] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + value ! Value of field being added to the statistic [Units Vary] + + ! Input/Output Variable(s) + type(stats), intent(inout) :: & + grid_kind ! Which grid the variable is located on (zt, zm, rad, or sfc). + + integer :: k + + ! ---- Begin Code ---- + + do k = 1, gr%nz + + call stat_modify_pt( var_index, k, value(k), grid_kind ) + + enddo + + return + end subroutine stat_modify + + !============================================================================= + subroutine stat_modify_pt( var_index, grid_level, value, & + grid_kind ) + + ! Description: + ! This modifies the value of a statistics variable located at var_index on + ! the grid at a specific point. It does not increment the sampling count. + ! + ! Commonly this is used for intermediate updates to a budget. See the + ! description of stat_modify for more details. + !--------------------------------------------------------------------- + + use clubb_precision, only: & + stat_rknd ! Constant + + use stat_file_module, only: & + clubb_i, clubb_j ! Variable(s) + + implicit none + + ! Input Variables(s) + + integer, intent(in) :: & + var_index ! The index at which the variable is stored [] + + + real( kind = core_rknd ), intent(in) :: & + value ! Value of field being added to the statistic [Units Vary] + + integer, intent(in) :: & + grid_level ! The level at which the variable is to be modified [] + + ! Input/Output Variable(s) + type(stats), intent(inout) :: & + grid_kind ! Which grid the variable is located on (zt, zm, rad, or sfc). + + ! ---- Begin Code ---- + + if ( var_index > 0 ) then + + grid_kind%accum_field_values(clubb_i,clubb_j,grid_level,var_index ) & + = grid_kind%accum_field_values(clubb_i,clubb_j,grid_level,var_index ) + & + real( value, kind=stat_rknd ) + + end if + + return + end subroutine stat_modify_pt + +!=============================================================================== + +end module stats_type_utilities diff --git a/models/atm/cam/src/physics/clubb/stats_variables.F90 b/models/atm/cam/src/physics/clubb/stats_variables.F90 index 85ba4718c530..8914138c9173 100644 --- a/models/atm/cam/src/physics/clubb/stats_variables.F90 +++ b/models/atm/cam/src/physics/clubb/stats_variables.F90 @@ -1,5 +1,5 @@ !------------------------------------------------------------------------------- -! $Id: stats_variables.F90 5633 2012-01-19 01:00:48Z vondeyle@uwm.edu $ +! $Id: stats_variables.F90 7383 2014-11-13 17:43:38Z schemena@uwm.edu $ !------------------------------------------------------------------------------- ! Description: @@ -9,202 +9,321 @@ module stats_variables - use stats_type, only: & + use stats_type, only: & stats ! Type use clubb_precision, only: & - time_precision, & ! Variable - core_rknd + core_rknd ! Variable(s) implicit none private ! Set Default Scope ! Sampling and output frequencies - real(kind=time_precision), public :: & - stats_tsamp, & ! Sampling interval [s] - stats_tout ! Output interval [s] + real( kind = core_rknd ), public :: & + stats_tsamp = 0._core_rknd, & ! Sampling interval [s] + stats_tout = 0._core_rknd ! Output interval [s] !$omp threadprivate(stats_tsamp, stats_tout) - logical, public :: & - l_stats, & ! Main flag to turn statistics on/off - l_output_rad_files, & ! Flag to turn off radiation statistics output - l_netcdf, & ! Output to NetCDF format - l_grads ! Output to GrADS format + logical, public :: & + l_stats = .false., & ! Main flag to turn statistics on/off + l_output_rad_files = .false., & ! Flag to turn off radiation statistics output + l_netcdf = .false., & ! Output to NetCDF format + l_grads = .false., & ! Output to GrADS format + l_silhs_out = .false., & ! Output SILHS files (stats_lh_zt and stats_lh_sfc) + l_allow_small_stats_tout = .false. ! Do not stop if output timestep is too low for + ! requested format, e.g. l_grads = .true. and + ! stats_tout < 60.0 -!$omp threadprivate(l_stats, l_output_rad_files, l_netcdf, l_grads) +!$omp threadprivate(l_stats, l_output_rad_files, l_netcdf, l_grads, l_silhs_out, & +!$omp l_allow_small_stats_tout) logical, public :: & - l_stats_samp, & ! Sample flag for current time step - l_stats_last ! Last time step of output period + l_stats_samp = .false., & ! Sample flag for current time step + l_stats_last = .false. ! Last time step of output period !$omp threadprivate(l_stats_samp, l_stats_last) character(len=200), public :: & - fname_zt, & ! Name of the stats file for thermodynamic grid fields - fname_zm, & ! Name of the stats file for momentum grid fields - fname_rad_zt, & ! Name of the stats file for the zt radiation grid fields - fname_rad_zm, & ! Name of the stats file for the zm radiation grid fields - fname_sfc ! Name of the stats file for surface only fields - -!$omp threadprivate(fname_zt, fname_zm, fname_rad_zt, fname_rad_zm, fname_sfc) - -! Indices for statistics in zt file - - integer, public :: & - ithlm, & - ithvm, & - irtm, & - ircm, & - irvm, & - ium, & - ivm, & - iwm_zt, & - iwm_zm, & - ium_ref,& - ivm_ref, & - iug, & - ivg, & - icloud_frac, & - ircm_in_layer, & - ircm_in_cloud, & - icloud_cover, & - ip_in_Pa, & - iexner, & - irho_ds_zt, & - ithv_ds_zt, & - iLscale, & - iwp3, & - iwpthlp2, & - iwp2thlp, & - iwprtp2, & - iwp2rtp, & - iLscale_up, & - iLscale_down, & - itau_zt, & - iKh_zt, & - iwp2thvp, & - iwp2rcp, & - iwprtpthlp, & - isigma_sqd_w_zt, & - irho, & - irel_humidity - - integer, public :: & - iNcm, & ! Brian - iNcnm, & - iNcm_in_cloud, & - iNc_activated, & - isnowslope, & ! Adam Smith, 22 April 2008 - ised_rcm, & ! Brian - irsat, & ! Brian - irsati, & - irrainm, & ! Brian - im_vol_rad_rain, & ! Brian - im_vol_rad_cloud, & ! COAMPS only. dschanen 6 Dec 2006 - irain_rate_zt, & ! Brian - iAKm, & ! analytic Kessler. Vince Larson 22 May 2005 - iLH_AKm, & ! LH Kessler. Vince Larson 22 May 2005 - iradht, & ! Radiative heating. - iradht_LW, & ! " " Long-wave component - iradht_SW ! " " Short-wave component - - integer, public :: & - iAKstd, & - iAKstd_cld, & - iAKm_rcm, & - iAKm_rcc + fname_zt = '', & ! Name of the stats file for thermodynamic grid fields + fname_lh_zt = '', & ! Name of the stats file for LH variables on the stats_zt grid + fname_lh_sfc = '', & ! Name of the stats file for LH variables on the stats_zt grid + fname_zm = '', & ! Name of the stats file for momentum grid fields + fname_rad_zt = '', & ! Name of the stats file for the stats_zt radiation grid fields + fname_rad_zm = '', & ! Name of the stats file for the stats_zm radiation grid fields + fname_sfc = '' ! Name of the stats file for surface only fields +!$omp threadprivate(fname_zt, fname_lh_zt, fname_lh_sfc, fname_zm, fname_rad_zt, & +!$omp fname_rad_zm, fname_sfc) + +! Indices for statistics in stats_zt file + + integer, public :: & + ithlm = 0, & + ithvm = 0, & + irtm = 0, & + ircm = 0, & + irvm = 0, & + ium = 0, & + ivm = 0, & + iwm_zt = 0, & + iwm_zm = 0, & + ium_ref = 0,& + ivm_ref = 0, & + iug = 0, & + ivg = 0, & + icloud_frac = 0, & + iice_supersat_frac = 0, & + ircm_in_layer = 0, & + ircm_in_cloud = 0, & + icloud_cover = 0, & + ip_in_Pa = 0, & + iexner = 0, & + irho_ds_zt = 0, & + ithv_ds_zt = 0, & + iLscale = 0, & + iwp3 = 0, & + iwpthlp2 = 0, & + iwp2thlp = 0, & + iwprtp2 = 0, & + iwp2rtp = 0, & + iSkw_zt = 0 !$omp threadprivate(ithlm, ithvm, irtm, ircm, irvm, ium, ivm, ium_ref, ivm_ref, & -!$omp iwm_zt, iwm_zm, iug, ivg, icloud_frac, ircm_in_layer, ircm_in_cloud, icloud_cover, & +!$omp iwm_zt, iwm_zm, iug, ivg, icloud_frac, iice_supersat_frac, ircm_in_layer, & +!$omp ircm_in_cloud, icloud_cover, & !$omp ip_in_Pa, iexner, irho_ds_zt, ithv_ds_zt, iLscale, iwp3, & -!$omp iwpthlp2, iwp2thlp, iwprtp2, iwp2rtp, iLscale_up, iLscale_down, & -!$omp itau_zt, iKh_zt, iwp2thvp, iwp2rcp, iwprtpthlp, isigma_sqd_w_zt, & -!$omp irho, irel_humidity, iNcm, iNcnm, iNcm_in_cloud, iNc_activated, isnowslope, & -!$omp ised_rcm, irsat, irsati, irrainm, & -!$omp im_vol_rad_rain, im_vol_rad_cloud, & -!$omp irain_rate_zt, iAKm, iLH_AKm, & -!$omp iradht, iradht_LW, iradht_SW, & -!$omp iAKstd, iAKstd_cld, iAKm_rcm, iAKm_rcc) +!$omp iwpthlp2, iwp2thlp, iwprtp2, iwp2rtp, iSkw_zt, iSkw_zm ) + + integer, public :: & + iLscale_up = 0, & + iLscale_down = 0, & + iLscale_pert_1 = 0, & + iLscale_pert_2 = 0, & + itau_zt = 0, & + iKh_zt = 0, & + iwp2thvp = 0, & + iwp2rcp = 0, & + iwprtpthlp = 0, & + isigma_sqd_w_zt = 0, & + irho = 0 +!$omp threadprivate( iLscale_up, iLscale_down, & +!$omp iLscale_pert_1, iLscale_pert_2, & +!$omp itau_zt, iKh_zt, iwp2thvp, iwp2rcp, iwprtpthlp, isigma_sqd_w_zt, irho ) + + integer, dimension(:), allocatable, public :: & + icorr_w_hm_ov_adj, & + ihm1, & + ihm2 +!$omp threadprivate( icorr_w_hm_ov_adj, ihm1, ihm2 ) + + integer, public :: & + iLWP1 = 0, & + iLWP2 = 0, & + iprecip_frac = 0, & + iprecip_frac_1 = 0, & + iprecip_frac_2 = 0, & + iNcnm = 0 +!$omp threadprivate( iLWP1, iLWP2, iprecip_frac, & +!$omp iprecip_frac_1, iprecip_frac_2, iNcnm ) + + integer, dimension(:), allocatable, public :: & + imu_hm_1, & + imu_hm_2, & + imu_hm_1_n, & + imu_hm_2_n, & + isigma_hm_1, & + isigma_hm_2, & + isigma_hm_1_n, & + isigma_hm_2_n, & + icorr_w_hm_1, & + icorr_w_hm_2, & + icorr_chi_hm_1, & + icorr_chi_hm_2, & + icorr_eta_hm_1, & + icorr_eta_hm_2, & + icorr_Ncn_hm_1, & + icorr_Ncn_hm_2, & + icorr_w_hm_1_n, & + icorr_w_hm_2_n, & + icorr_chi_hm_1_n, & + icorr_chi_hm_2_n, & + icorr_eta_hm_1_n, & + icorr_eta_hm_2_n, & + icorr_Ncn_hm_1_n, & + icorr_Ncn_hm_2_n +!$omp threadprivate( imu_hm_1, imu_hm_2, imu_hm_1_n, imu_hm_2_n, & +!$omp isigma_hm_1, isigma_hm_2, isigma_hm_1_n, isigma_hm_2_n, & +!$omp icorr_w_hm_1, icorr_w_hm_2, icorr_chi_hm_1, icorr_chi_hm_2, & +!$omp icorr_eta_hm_1, icorr_eta_hm_2, icorr_Ncn_hm_1, icorr_Ncn_hm_2, & +!$omp icorr_w_hm_1_n, icorr_w_hm_2_n, icorr_chi_hm_1_n, icorr_chi_hm_2_n, & +!$omp icorr_eta_hm_1_n, icorr_eta_hm_2_n, icorr_Ncn_hm_1_n, icorr_Ncn_hm_2_n ) + + integer, dimension(:,:), allocatable, public :: & + icorr_hmx_hmy_1, & + icorr_hmx_hmy_2, & + icorr_hmx_hmy_1_n, & + icorr_hmx_hmy_2_n +!$omp threadprivate( icorr_hmx_hmy_1, icorr_hmx_hmy_2, & +!$omp icorr_hmx_hmy_1_n, icorr_hmx_hmy_2_n ) - ! Skewness functions on zt grid integer, public :: & - iC11_Skw_fnc + imu_Ncn_1 = 0, & + imu_Ncn_2 = 0, & + imu_Ncn_1_n = 0, & + imu_Ncn_2_n = 0, & + isigma_Ncn_1 = 0, & + isigma_Ncn_2 = 0, & + isigma_Ncn_1_n = 0, & + isigma_Ncn_2_n = 0 +!$omp threadprivate( imu_Ncn_1, imu_Ncn_2, imu_Ncn_1_n, imu_Ncn_2_n, & +!$omp isigma_Ncn_1, isigma_Ncn_2, isigma_Ncn_1_n, isigma_Ncn_2_n ) + + integer, public :: & + icorr_w_chi_1 = 0, & + icorr_w_chi_2 = 0, & + icorr_w_eta_1 = 0, & + icorr_w_eta_2 = 0, & + icorr_w_Ncn_1 = 0, & + icorr_w_Ncn_2 = 0, & + icorr_chi_eta_1_ca = 0, & + icorr_chi_eta_2_ca = 0, & + icorr_chi_Ncn_1 = 0, & + icorr_chi_Ncn_2 = 0, & + icorr_eta_Ncn_1 = 0, & + icorr_eta_Ncn_2 = 0 +!$omp threadprivate( icorr_w_chi_1, icorr_w_chi_2, icorr_w_eta_1, & +!$omp icorr_w_eta_2, icorr_w_Ncn_1, icorr_w_Ncn_2, icorr_chi_eta_1_ca, & +!$omp icorr_chi_eta_2_ca, icorr_chi_Ncn_1, icorr_chi_Ncn_2, icorr_eta_Ncn_1, & +!$omp icorr_eta_Ncn_2 ) + + integer, public :: & + icorr_w_Ncn_1_n = 0, & + icorr_w_Ncn_2_n = 0, & + icorr_chi_Ncn_1_n = 0, & + icorr_chi_Ncn_2_n = 0, & + icorr_eta_Ncn_1_n = 0, & + icorr_eta_Ncn_2_n = 0 +!$omp threadprivate( icorr_w_Ncn_1_n, icorr_w_Ncn_2_n, icorr_chi_Ncn_1_n, & +!$omp icorr_chi_Ncn_2_n, icorr_eta_Ncn_1_n, icorr_eta_Ncn_2_n ) + + integer, public :: & + iNcm = 0, & ! Brian + iNccnm = 0, & + iNc_in_cloud = 0, & + iNc_activated = 0, & + isnowslope = 0, & ! Adam Smith, 22 April 2008 + ised_rcm = 0, & ! Brian + irsat = 0, & ! Brian + irsati = 0, & + irrm = 0, & ! Brian + im_vol_rad_rain = 0, & ! Brian + im_vol_rad_cloud = 0, & ! COAMPS only. dschanen 6 Dec 2006 + iprecip_rate_zt = 0, & ! Brian + iAKm = 0, & ! analytic Kessler. Vince Larson 22 May 2005 + ilh_AKm = 0, & ! LH Kessler. Vince Larson 22 May 2005 + iradht = 0, & ! Radiative heating. + iradht_LW = 0, & ! " " Long-wave component + iradht_SW = 0, & ! " " Short-wave component + irel_humidity = 0 +!$omp threadprivate( iNcm, iNccnm, iNc_in_cloud, iNc_activated, isnowslope, & +!$omp ised_rcm, irsat, irsati, irrm, & +!$omp im_vol_rad_rain, im_vol_rad_cloud, & +!$omp iprecip_rate_zt, iAKm, ilh_AKm, & +!$omp iradht, iradht_LW, iradht_SW, & +!$omp irel_humidity ) + + integer, public :: & + iAKstd = 0, & + iAKstd_cld = 0, & + iAKm_rcm = 0, & + iAKm_rcc = 0 +!$omp threadprivate( iAKstd, iAKstd_cld, iAKm_rcm, iAKm_rcc ) + + + integer, public :: & + irfrzm = 0 +!$omp threadprivate(irfrzm) + + ! Skewness functions on stats_zt grid + integer, public :: & + iC11_Skw_fnc = 0 !$omp threadprivate(iC11_Skw_fnc) integer, public :: & - icloud_frac_zm, & - ircm_zm, & - irtm_zm, & - ithlm_zm + icloud_frac_zm = 0, & + iice_supersat_frac_zm = 0, & + ircm_zm = 0, & + irtm_zm = 0, & + ithlm_zm = 0 -!$omp threadprivate(icloud_frac_zm, ircm_zm, irtm_zm, ithlm_zm) +!$omp threadprivate(icloud_frac_zm, iice_supersat_frac_zm, ircm_zm, irtm_zm, ithlm_zm) integer, public :: & - iLH_rcm_avg + ilh_rcm_avg = 0, & + ik_lh_start = 0 -!$omp threadprivate(iLH_rcm_avg) +!$omp threadprivate(ilh_rcm_avg, ik_lh_start) integer, public :: & - iNrm, & ! Rain droplet number concentration - iNim, & ! Ice number concentration - iNsnowm, & ! Snow number concentration - iNgraupelm ! Graupel number concentration -!$omp threadprivate(iNrm, iNim, iNsnowm, iNgraupelm) + iNrm = 0, & ! Rain droplet number concentration + iNim = 0, & ! Ice number concentration + iNsm = 0, & ! Snow number concentration + iNgm = 0 ! Graupel number concentration +!$omp threadprivate(iNrm, iNim, iNsm, iNgm) integer, public :: & iT_in_K ! Absolute temperature !$omp threadprivate(iT_in_K) integer, public :: & - ieff_rad_cloud, & - ieff_rad_ice, & - ieff_rad_snow, & - ieff_rad_rain, & - ieff_rad_graupel + ieff_rad_cloud = 0, & + ieff_rad_ice = 0, & + ieff_rad_snow = 0, & + ieff_rad_rain = 0, & + ieff_rad_graupel = 0 !$omp threadprivate(ieff_rad_cloud, ieff_rad_ice, ieff_rad_snow) !$omp threadprivate(ieff_rad_rain, ieff_rad_graupel) integer, public :: & - irsnowm, & - irgraupelm, & - iricem, & - idiam, & ! Diameter of ice crystal [m] - imass_ice_cryst, & ! Mass of a single ice crystal [kg] - ircm_icedfs, & ! Change in liquid water due to ice [kg/kg/s] - iu_T_cm ! Fallspeed of ice crystal in cm/s [cm s^{-1}] + irsm = 0, & + irgm = 0, & + irim = 0, & + idiam = 0, & ! Diameter of ice crystal [m] + imass_ice_cryst = 0, & ! Mass of a single ice crystal [kg] + ircm_icedfs = 0, & ! Change in liquid water due to ice [kg/kg/s] + iu_T_cm = 0 ! Fallspeed of ice crystal in cm/s [cm s^{-1}] -!$omp threadprivate(irsnowm, irgraupelm, iricem, idiam) -!$omp threadprivate(imass_ice_cryst, ircm_icedfs, iu_T_cm) +!$omp threadprivate(irsm, irgm, irim, idiam, & +!$omp imass_ice_cryst, ircm_icedfs, iu_T_cm) ! thlm/rtm budget terms integer, public :: & - irtm_bt, & ! rtm total time tendency - irtm_ma, & ! rtm mean advect. term - irtm_ta, & ! rtm turb. advect. term - irtm_forcing, & ! rtm large scale forcing term - irtm_mc, & ! rtm change from microphysics - irtm_sdmp, & ! rtm change from sponge damping - irvm_mc, & ! rvm change from microphysics - ircm_mc, & ! rcm change from microphysics - ircm_sd_mg_morr, & ! rcm sedimentation tendency - irtm_mfl, & ! rtm change due to monotonic flux limiter - irtm_tacl, & ! rtm correction from turbulent advection (wprtp) clipping - irtm_cl, & ! rtm clipping term - irtm_pd, & ! thlm postive definite adj term - ithlm_bt, & ! thlm total time tendency - ithlm_ma, & ! thlm mean advect. term - ithlm_ta, & ! thlm turb. advect. term - ithlm_forcing, & ! thlm large scale forcing term - ithlm_sdmp, & ! thlm change from sponge damping - ithlm_mc, & ! thlm change from microphysics - ithlm_mfl, & ! thlm change due to monotonic flux limiter - ithlm_tacl, & ! thlm correction from turbulent advection (wpthlp) clipping - ithlm_cl ! thlm clipping term + irtm_bt = 0, & ! rtm total time tendency + irtm_ma = 0, & ! rtm mean advect. term + irtm_ta = 0, & ! rtm turb. advect. term + irtm_forcing = 0, & ! rtm large scale forcing term + irtm_mc = 0, & ! rtm change from microphysics + irtm_sdmp = 0, & ! rtm change from sponge damping + irvm_mc = 0, & ! rvm change from microphysics + ircm_mc = 0, & ! rcm change from microphysics + ircm_sd_mg_morr = 0, & ! rcm sedimentation tendency + irtm_mfl = 0, & ! rtm change due to monotonic flux limiter + irtm_tacl = 0, & ! rtm correction from turbulent advection (wprtp) clipping + irtm_cl = 0, & ! rtm clipping term + irtm_pd = 0, & ! thlm postive definite adj term + ithlm_bt = 0, & ! thlm total time tendency + ithlm_ma = 0, & ! thlm mean advect. term + ithlm_ta = 0, & ! thlm turb. advect. term + ithlm_forcing = 0, & ! thlm large scale forcing term + ithlm_sdmp = 0, & ! thlm change from sponge damping + ithlm_mc = 0, & ! thlm change from microphysics + ithlm_mfl = 0, & ! thlm change due to monotonic flux limiter + ithlm_tacl = 0, & ! thlm correction from turbulent advection (wpthlp) clipping + ithlm_cl = 0 ! thlm clipping term !$omp threadprivate(irtm_bt, irtm_ma, irtm_ta, irtm_forcing, & !$omp irtm_mc, irtm_sdmp, irtm_mfl, irtm_tacl, irtm_cl, irtm_pd, & @@ -214,26 +333,26 @@ module stats_variables !monatonic flux limiter diagnostic terms integer, public :: & - ithlm_mfl_min, & - ithlm_mfl_max, & - iwpthlp_entermfl, & - iwpthlp_exit_mfl, & - iwpthlp_mfl_min, & - iwpthlp_mfl_max, & - irtm_mfl_min, & - irtm_mfl_max, & - iwprtp_enter_mfl, & - iwprtp_exit_mfl, & - iwprtp_mfl_min, & - iwprtp_mfl_max, & - ithlm_enter_mfl, & - ithlm_exit_mfl, & - ithlm_old, & - ithlm_without_ta, & - irtm_enter_mfl, & - irtm_exit_mfl, & - irtm_old, & - irtm_without_ta + ithlm_mfl_min = 0, & + ithlm_mfl_max = 0, & + iwpthlp_entermfl = 0, & + iwpthlp_exit_mfl = 0, & + iwpthlp_mfl_min = 0, & + iwpthlp_mfl_max = 0, & + irtm_mfl_min = 0, & + irtm_mfl_max = 0, & + iwprtp_enter_mfl = 0, & + iwprtp_exit_mfl = 0, & + iwprtp_mfl_min = 0, & + iwprtp_mfl_max = 0, & + ithlm_enter_mfl = 0, & + ithlm_exit_mfl = 0, & + ithlm_old = 0, & + ithlm_without_ta = 0, & + irtm_enter_mfl = 0, & + irtm_exit_mfl = 0, & + irtm_old = 0, & + irtm_without_ta = 0 !$omp threadprivate(ithlm_mfl_min, ithlm_mfl_max, iwpthlp_entermfl) !$omp threadprivate(iwpthlp_exit_mfl, iwpthlp_mfl_min, iwpthlp_mfl_max) @@ -243,227 +362,296 @@ module stats_variables !$omp threadprivate(irtm_enter_mfl, irtm_exit_mfl, irtm_old, irtm_without_ta) integer, public :: & - iwp3_bt, & - iwp3_ma, & - iwp3_ta, & - iwp3_tp, & - iwp3_ac, & - iwp3_bp1, & - iwp3_bp2, & - iwp3_pr1, & - iwp3_pr2, & - iwp3_dp1, & - iwp3_4hd, & - iwp3_cl + iwp3_bt = 0, & + iwp3_ma = 0, & + iwp3_ta = 0, & + iwp3_tp = 0, & + iwp3_ac = 0, & + iwp3_bp1 = 0, & + iwp3_bp2 = 0, & + iwp3_pr1 = 0, & + iwp3_pr2 = 0, & + iwp3_dp1 = 0, & + iwp3_cl = 0 !$omp threadprivate(iwp3_bt, iwp3_ma, iwp3_ta, iwp3_tp, iwp3_ac, iwp3_bp1) -!$omp threadprivate(iwp3_bp2, iwp3_pr1, iwp3_pr2, iwp3_dp1, iwp3_4hd, iwp3_cl) +!$omp threadprivate(iwp3_bp2, iwp3_pr1, iwp3_pr2, iwp3_dp1, iwp3_cl) ! Rain mixing ratio budgets integer, public :: & - irrainm_bt, & - irrainm_ma, & - irrainm_sd, & - irrainm_sd_morr, & - irrainm_dff, & - irrainm_cond, & - irrainm_auto, & - irrainm_accr, & - irrainm_cond_adj, & - irrainm_src_adj, & - irrainm_mc, & - irrainm_cl - -!$omp threadprivate(irrainm_bt, irrainm_ma, irrainm_sd, irrainm_sd_morr, irrainm_dff) -!$omp threadprivate(irrainm_cond, irrainm_auto, irrainm_accr) -!$omp threadprivate(irrainm_cond_adj, irrainm_src_adj, irrainm_mc, irrainm_cl) - - integer, public :: & - iNrm_bt, & - iNrm_ma, & - iNrm_sd, & - iNrm_dff, & - iNrm_cond, & - iNrm_auto, & - iNrm_cond_adj, & - iNrm_src_adj, & - iNrm_mc, & - iNrm_cl - -!$omp threadprivate(iNrm_bt, iNrm_ma, iNrm_sd, iNrm_dff, iNrm_cond) -!$omp threadprivate(iNrm_auto, iNrm_cond_adj, iNrm_src_adj, iNrm_mc, iNrm_cl) + irrm_bt = 0, & + irrm_ma = 0, & + irrm_ta = 0, & + irrm_sd = 0, & + irrm_ts = 0, & + irrm_sd_morr = 0, & + irrm_cond = 0, & + irrm_auto = 0, & + irrm_accr = 0, & + irrm_cond_adj = 0, & + irrm_src_adj = 0, & + irrm_mc = 0, & + irrm_hf = 0, & + irrm_wvhf = 0, & + irrm_cl = 0 + +!$omp threadprivate(irrm_bt, irrm_ma, irrm_ta, irrm_sd) +!$omp threadprivate(irrm_ts, irrm_sd_morr) +!$omp threadprivate(irrm_cond, irrm_auto, irrm_accr) +!$omp threadprivate(irrm_cond_adj, irrm_src_adj ) +!$omp threadprivate(irrm_mc, irrm_hf, irrm_wvhf, irrm_cl) + + integer, public :: & + iNrm_bt = 0, & + iNrm_ma = 0, & + iNrm_ta = 0, & + iNrm_sd = 0, & + iNrm_ts = 0, & + iNrm_cond = 0, & + iNrm_auto = 0, & + iNrm_cond_adj = 0, & + iNrm_src_adj = 0, & + iNrm_mc = 0, & + iNrm_cl = 0 + +!$omp threadprivate(iNrm_bt, iNrm_ma, iNrm_ta, iNrm_sd, iNrm_ts, iNrm_cond) +!$omp threadprivate(iNrm_auto, iNrm_cond_adj, iNrm_src_adj ) +!$omp threadprivate(iNrm_mc, iNrm_cl) ! Snow/Ice/Graupel mixing ratio budgets integer, public :: & - irsnowm_bt, & - irsnowm_ma, & - irsnowm_sd, & - irsnowm_sd_morr, & - irsnowm_dff, & - irsnowm_mc, & - irsnowm_cl - -!$omp threadprivate(irsnowm_bt, irsnowm_ma, irsnowm_sd, irsnowm_sd_morr, irsnowm_dff) -!$omp threadprivate(irsnowm_mc, irsnowm_cl) + irsm_bt = 0, & + irsm_ma = 0, & + irsm_sd = 0, & + irsm_sd_morr = 0, & + irsm_ta = 0, & + irsm_mc = 0, & + irsm_hf = 0, & + irsm_wvhf = 0, & + irsm_cl = 0, & + irsm_sd_morr_int = 0 + +!$omp threadprivate(irsm_bt, irsm_ma, irsm_sd, irsm_sd_morr, irsm_ta) +!$omp threadprivate(irsm_mc, irsm_hf, irsm_wvhf, irsm_cl) +!$omp threadprivate(irsm_sd_morr_int) integer, public :: & - irgraupelm_bt, & - irgraupelm_ma, & - irgraupelm_sd, & - irgraupelm_sd_morr, & - irgraupelm_dff, & - irgraupelm_mc, & - irgraupelm_cl - -!$omp threadprivate(irgraupelm_bt, irgraupelm_ma, irgraupelm_sd, irgraupelm_sd_morr) -!$omp threadprivate(irgraupelm_dff, irgraupelm_mc, irgraupelm_cl) + irgm_bt = 0, & + irgm_ma = 0, & + irgm_sd = 0, & + irgm_sd_morr = 0, & + irgm_ta = 0, & + irgm_mc = 0, & + irgm_hf = 0, & + irgm_wvhf = 0, & + irgm_cl = 0 + +!$omp threadprivate(irgm_bt, irgm_ma, irgm_sd, irgm_sd_morr) +!$omp threadprivate(irgm_ta, irgm_mc) +!$omp threadprivate(irgm_hf, irgm_wvhf, irgm_cl) integer, public :: & - iricem_bt, & - iricem_ma, & - iricem_sd, & - iricem_sd_mg_morr, & - iricem_dff, & - iricem_mc, & - iricem_cl - -!$omp threadprivate(iricem_bt, iricem_ma, iricem_sd, iricem_sd_mg_morr, iricem_dff) -!$omp threadprivate(iricem_mc, iricem_cl) + irim_bt = 0, & + irim_ma = 0, & + irim_sd = 0, & + irim_sd_mg_morr = 0, & + irim_ta = 0, & + irim_mc = 0, & + irim_hf = 0, & + irim_wvhf = 0, & + irim_cl = 0 + +!$omp threadprivate(irim_bt, irim_ma, irim_sd, irim_sd_mg_morr, irim_ta) +!$omp threadprivate(irim_mc, irim_hf, irim_wvhf, irim_cl) integer, public :: & - iNsnowm_bt, & - iNsnowm_ma, & - iNsnowm_sd, & - iNsnowm_dff, & - iNsnowm_mc, & - iNsnowm_cl + iNsm_bt = 0, & + iNsm_ma = 0, & + iNsm_sd = 0, & + iNsm_ta = 0, & + iNsm_mc = 0, & + iNsm_cl = 0 -!$omp threadprivate(iNsnowm_bt, iNsnowm_ma, iNsnowm_sd, iNsnowm_dff, & -!$omp iNsnowm_mc, iNsnowm_cl) +!$omp threadprivate(iNsm_bt, iNsm_ma, iNsm_sd, iNsm_ta, & +!$omp iNsm_mc, iNsm_cl) integer, public :: & - iNgraupelm_bt, & - iNgraupelm_ma, & - iNgraupelm_sd, & - iNgraupelm_dff, & - iNgraupelm_mc, & - iNgraupelm_cl + iNgm_bt = 0, & + iNgm_ma = 0, & + iNgm_sd = 0, & + iNgm_ta = 0, & + iNgm_mc = 0, & + iNgm_cl = 0 -!$omp threadprivate(iNgraupelm_bt, iNgraupelm_ma, iNgraupelm_sd, & -!$omp iNgraupelm_dff, iNgraupelm_mc, iNgraupelm_cl) +!$omp threadprivate(iNgm_bt, iNgm_ma, iNgm_sd, & +!$omp iNgm_ta, iNgm_mc, iNgm_cl) integer, public :: & - iNim_bt, & - iNim_ma, & - iNim_sd, & - iNim_dff, & - iNim_mc, & - iNim_cl - -!$omp threadprivate(iNim_bt, iNim_ma, iNim_sd, iNim_dff, & + iNim_bt = 0, & + iNim_ma = 0, & + iNim_sd = 0, & + iNim_ta = 0, & + iNim_mc = 0, & + iNim_cl = 0 + +!$omp threadprivate(iNim_bt, iNim_ma, iNim_sd, iNim_ta, & !$omp iNim_mc, iNim_cl) integer, public :: & - iNcm_bt, & - iNcm_ma, & - iNcm_dff, & - iNcm_mc, & - iNcm_cl, & - iNcm_act - -!$omp threadprivate(iNcm_bt, iNcm_ma, iNcm_dff, & + iNcm_bt = 0, & + iNcm_ma = 0, & + iNcm_ta = 0, & + iNcm_mc = 0, & + iNcm_cl = 0, & + iNcm_act = 0 + +!$omp threadprivate(iNcm_bt, iNcm_ma, iNcm_ta, & !$omp iNcm_mc, iNcm_cl, iNcm_act) + ! Covariances between w, r_t, theta_l and KK microphysics tendencies. + ! Additionally, covariances between r_r and N_r and KK rain drop mean + ! volume radius. These are all calculated on thermodynamic grid levels. + integer, public :: & + iw_KK_evap_covar_zt = 0, & ! Covariance of w and KK evaporation tendency. + irt_KK_evap_covar_zt = 0, & ! Covariance of r_t and KK evaporation tendency. + ithl_KK_evap_covar_zt = 0, & ! Covariance of theta_l and KK evap. tendency. + iw_KK_auto_covar_zt = 0, & ! Covariance of w and KK autoconversion tendency. + irt_KK_auto_covar_zt = 0, & ! Covariance of r_t and KK autoconversion tendency. + ithl_KK_auto_covar_zt = 0, & ! Covariance of theta_l and KK autoconv. tendency. + iw_KK_accr_covar_zt = 0, & ! Covariance of w and KK accretion tendency. + irt_KK_accr_covar_zt = 0, & ! Covariance of r_t and KK accretion tendency. + ithl_KK_accr_covar_zt = 0, & ! Covariance of theta_l and KK accretion tendency. + irr_KK_mvr_covar_zt = 0, & ! Covariance of r_r and KK mean volume radius. + iNr_KK_mvr_covar_zt = 0, & ! Covariance of N_r and KK mean volume radius. + iKK_mvr_variance_zt = 0 ! Variance of KK rain drop mean volume radius. + +!$omp threadprivate( iw_KK_evap_covar_zt, irt_KK_evap_covar_zt, & +!$omp ithl_KK_evap_covar_zt, iw_KK_auto_covar_zt, irt_KK_auto_covar_zt, & +!$omp ithl_KK_auto_covar_zt, iw_KK_accr_covar_zt, irt_KK_accr_covar_zt, & +!$omp ithl_KK_accr_covar_zt, irr_KK_mvr_covar_zt, iNr_KK_mvr_covar_zt, & +!$omp iKK_mvr_variance_zt ) ! Wind budgets integer, public :: & - ivm_bt, & - ivm_ma, & - ivm_ta, & - ivm_gf, & - ivm_cf, & - ivm_f, & - ivm_sdmp, & - ivm_ndg + ivm_bt = 0, & + ivm_ma = 0, & + ivm_ta = 0, & + ivm_gf = 0, & + ivm_cf = 0, & + ivm_f = 0, & + ivm_sdmp = 0, & + ivm_ndg = 0 !$omp threadprivate(ivm_bt, ivm_ma, ivm_ta, ivm_gf, ivm_cf, ivm_f, ivm_sdmp, ivm_ndg) integer, public :: & - ium_bt, & - ium_ma, & - ium_ta, & - ium_gf, & - ium_cf, & - ium_f, & - ium_sdmp, & - ium_ndg + ium_bt = 0, & + ium_ma = 0, & + ium_ta = 0, & + ium_gf = 0, & + ium_cf = 0, & + ium_f = 0, & + ium_sdmp = 0, & + ium_ndg = 0 !$omp threadprivate(ium_bt, ium_ma, ium_ta, ium_gf, ium_cf, ium_f, ium_sdmp, ium_ndg) ! PDF parameters integer, public :: & - imixt_frac, & - iw1, & - iw2, & - ivarnce_w1, & - ivarnce_w2, & - ithl1, & - ithl2, & - ivarnce_thl1, & - ivarnce_thl2, & - irt1, & - irt2, & - ivarnce_rt1, & - ivarnce_rt2, & - irc1, & - irc2, & - irsl1, & - irsl2, & - icloud_frac1, & - icloud_frac2, & - is1, & - is2, & - istdev_s1, & - istdev_s2, & - irrtthl - -!$omp threadprivate(imixt_frac, iw1, iw2, ivarnce_w1, ivarnce_w2, ithl1, ithl2, ivarnce_thl1, & -!$omp ivarnce_thl2, irt1, irt2, ivarnce_rt1, ivarnce_rt2, irc1, irc2, & -!$omp irsl1, irsl2, icloud_frac1, icloud_frac2, is1, is2, istdev_s1, istdev_s2, & -!$omp irrtthl) - - integer, public :: & - iwp2_zt, & - ithlp2_zt, & - iwpthlp_zt, & - iwprtp_zt, & - irtp2_zt, & - irtpthlp_zt, & - iup2_zt, & - ivp2_zt, & - iupwp_zt, & - ivpwp_zt - -!$omp threadprivate(iwp2_zt, ithlp2_zt, iwpthlp_zt, iwprtp_zt, irtp2_zt, irtpthlp_zt, & -!$omp iup2_zt, ivp2_zt, iupwp_zt, ivpwp_zt) - - integer, public :: & - is_mellor -!$omp threadprivate(is_mellor) + imixt_frac = 0, & + iw_1 = 0, & + iw_2 = 0, & + ivarnce_w_1 = 0, & + ivarnce_w_2 = 0, & + ithl_1 = 0, & + ithl_2 = 0, & + ivarnce_thl_1 = 0, & + ivarnce_thl_2 = 0, & + irt_1 = 0, & + irt_2 = 0, & + ivarnce_rt_1 = 0, & + ivarnce_rt_2 = 0, & + irc_1 = 0, & + irc_2 = 0, & + irsatl_1 = 0, & + irsatl_2 = 0, & + icloud_frac_1 = 0, & + icloud_frac_2 = 0 +!$omp threadprivate(imixt_frac, iw_1, iw_2, ivarnce_w_1, ivarnce_w_2, ithl_1, ithl_2, & +!$omp ivarnce_thl_1, ivarnce_thl_2, irt_1, irt_2, ivarnce_rt_1, ivarnce_rt_2, irc_1, irc_2, & +!$omp irsatl_1, irsatl_2, icloud_frac_1, icloud_frac_2 ) - integer, target, allocatable, dimension(:), public :: & - isclrm, & ! Passive scalar mean (1) - isclrm_f ! Passive scalar forcing (1) + integer, public :: & + ichi_1 = 0, & + ichi_2 = 0, & + istdev_chi_1 = 0, & + istdev_chi_2 = 0, & + ichip2 = 0, & + istdev_eta_1 = 0, & + istdev_eta_2 = 0, & + icovar_chi_eta_1 = 0, & + icovar_chi_eta_2 = 0, & + icorr_chi_eta_1 = 0, & + icorr_chi_eta_2 = 0, & + irrtthl = 0, & + icrt_1 = 0, & + icrt_2 = 0, & + icthl_1 = 0, & + icthl_2 = 0 +!$omp threadprivate( ichi_1, ichi_2, istdev_chi_1, istdev_chi_2, ichip2, & +!$omp istdev_eta_1, istdev_eta_2, icovar_chi_eta_1, icovar_chi_eta_2, & +!$omp icorr_chi_eta_1, icorr_chi_eta_2, irrtthl, icrt_1, icrt_2, icthl_1, & +!$omp icthl_2 ) + + integer, public :: & + iwp2_zt = 0, & + ithlp2_zt = 0, & + iwpthlp_zt = 0, & + iwprtp_zt = 0, & + irtp2_zt = 0, & + irtpthlp_zt = 0, & + iup2_zt = 0, & + ivp2_zt = 0, & + iupwp_zt = 0, & + ivpwp_zt = 0 + +!$omp threadprivate( iwp2_zt, ithlp2_zt, iwpthlp_zt, iwprtp_zt, irtp2_zt, & +!$omp irtpthlp_zt, iup2_zt, ivp2_zt, iupwp_zt, ivpwp_zt ) + + integer, dimension(:), allocatable, public :: & + iwp2hmp + +!$omp threadprivate( iwp2hmp ) + + integer, dimension(:), allocatable, public :: & + ihydrometp2, & + iwphydrometp, & + irtphmp, & + ithlphmp + +!$omp threadprivate( ihydrometp2, iwphydrometp, irtphmp, ithlphmp ) + + integer, dimension(:), allocatable, public :: & + ihmp2_zt + +!$omp threadprivate( ihmp2_zt ) + + integer, public :: & + ichi = 0 +!$omp threadprivate(ichi) + integer, target, allocatable, dimension(:), public :: & + isclrm, & ! Passive scalar mean (1) + isclrm_f ! Passive scalar forcing (1) !$omp threadprivate(isclrm, isclrm_f) ! Used to calculate clear-sky radiative fluxes. integer, public :: & - ifulwcl, ifdlwcl, ifdswcl, ifuswcl -!$omp threadprivate(ifulwcl, ifdlwcl, ifdswcl, ifuswcl) + ifulwcl = 0, ifdlwcl = 0, ifdswcl = 0, ifuswcl = 0 +!$omp threadprivate(ifulwcl, ifdlwcl, ifdswcl, ifuswcl) integer, target, allocatable, dimension(:), public :: & iedsclrm, & ! Eddy-diff. scalar term (1) @@ -472,278 +660,466 @@ module stats_variables !$omp threadprivate(iedsclrm, iedsclrm_f) integer, public :: & - iLH_thlm_mc, & ! Latin hypercube estimate of thlm_mc - iLH_rvm_mc, & ! Latin hypercube estimate of rvm_mc - iLH_rcm_mc, & ! Latin hypercube estimate of rcm_mc - iLH_Ncm_mc, & ! Latin hypercube estimate of Ncm_mc - iLH_rrainm_mc, & ! Latin hypercube estimate of rrainm_mc - iLH_Nrm_mc, & ! Latin hypercube estimate of Nrm_mc - iLH_rsnowm_mc, & ! Latin hypercube estimate of rsnowm_mc - iLH_Nsnowm_mc, & ! Latin hypercube estimate of Nsnowm_mc - iLH_rgraupelm_mc, & ! Latin hypercube estimate of rgraupelm_mc - iLH_Ngraupelm_mc, & ! Latin hypercube estimate of Ngraupelm_mc - iLH_ricem_mc, & ! Latin hypercube estimate of ricem_mc - iLH_Nim_mc ! Latin hypercube estimate of Nim_mc -!$omp threadprivate( iLH_thlm_mc, iLH_rvm_mc, iLH_rcm_mc, iLH_Ncm_mc, & -!$omp iLH_rrainm_mc, iLH_Nrm_mc, iLH_rsnowm_mc, iLH_Nsnowm_mc, & -!$omp iLH_rgraupelm_mc, iLH_Ngraupelm_mc, iLH_ricem_mc, iLH_Nim_mc ) - - integer, public :: & - iLH_Vrr, & ! Latin hypercube estimate of rrainm sedimentation velocity - iLH_VNr ! Latin hypercube estimate of Nrm sedimentation velocity -!$omp threadprivate(iLH_Vrr, iLH_VNr) - - integer, public :: & - iLH_rrainm, & - iLH_Nrm, & - iLH_ricem, & - iLH_Nim, & - iLH_rsnowm, & - iLH_Nsnowm, & - iLH_rgraupelm, & - iLH_Ngraupelm, & - iLH_thlm, & - iLH_rcm, & - iLH_Ncm, & - iLH_rvm, & - iLH_wm, & - iLH_cloud_frac - -!$omp threadprivate(iLH_rrainm, iLH_Nrm, iLH_ricem, iLH_Nim, iLH_rsnowm, iLH_Nsnowm, & -!$omp iLH_rgraupelm, iLH_Ngraupelm, & -!$omp iLH_thlm, iLH_rcm, iLH_Ncm, iLH_rvm, iLH_wm, iLH_cloud_frac ) - - integer, public :: & - iLH_wp2_zt, & - iLH_Nrp2_zt, & - iLH_Ncp2_zt, & - iLH_rcp2_zt, & - iLH_rtp2_zt, & - iLH_thlp2_zt, & - iLH_rrainp2_zt - -!$omp threadprivate(iLH_wp2_zt, iLH_Nrp2_zt, iLH_Ncp2_zt, iLH_rcp2_zt, iLH_rtp2_zt, & -!$omp iLH_thlp2_zt, iLH_rrainp2_zt) - - integer, public :: & - itp2_mellor_1, & - itp2_mellor_2, & - isptp_mellor_1, & - isptp_mellor_2, & - icorr_st_mellor1, & - icorr_st_mellor2 - -!$omp threadprivate(itp2_mellor_1, itp2_mellor_2, isptp_mellor_1, & -!$omp isptp_mellor_2, icorr_st_mellor1, icorr_st_mellor2) - - ! Indices for statistics in zm file - integer, public :: & - iwp2, & - irtp2, & - ithlp2, & - irtpthlp, & - iwprtp, & - iwpthlp, & - iwp4, & - iwpthvp, & - irtpthvp, & - ithlpthvp, & - itau_zm, & - iKh_zm, & - iwprcp, & - ithlprcp, & - irtprcp, & - ircp2, & - iupwp, & - ivpwp, & - irho_zm, & - isigma_sqd_w, & - irho_ds_zm, & - ithv_ds_zm, & - iem, & - ishear, & ! Brian - imean_w_up, & - imean_w_down, & - iFrad, & - iFrad_LW, & ! Brian - iFrad_SW, & ! Brian - iFrad_LW_up, & - iFrad_SW_up, & - iFrad_LW_down, & - iFrad_SW_down, & - iFprec, & ! Brian - iFcsed ! Brian + ilh_thlm_mc = 0, & ! Latin hypercube estimate of thlm_mc + ilh_rvm_mc = 0, & ! Latin hypercube estimate of rvm_mc + ilh_rcm_mc = 0, & ! Latin hypercube estimate of rcm_mc + ilh_Ncm_mc = 0, & ! Latin hypercube estimate of Ncm_mc + ilh_rrm_mc = 0, & ! Latin hypercube estimate of rrm_mc + ilh_Nrm_mc = 0, & ! Latin hypercube estimate of Nrm_mc + ilh_rsm_mc = 0, & ! Latin hypercube estimate of rsm_mc + ilh_Nsm_mc = 0, & ! Latin hypercube estimate of Nsm_mc + ilh_rgm_mc = 0, & ! Latin hypercube estimate of rgm_mc + ilh_Ngm_mc = 0, & ! Latin hypercube estimate of Ngm_mc + ilh_rim_mc = 0, & ! Latin hypercube estimate of rim_mc + ilh_Nim_mc = 0 ! Latin hypercube estimate of Nim_mc +!$omp threadprivate( ilh_thlm_mc, ilh_rvm_mc, ilh_rcm_mc, ilh_Ncm_mc, & +!$omp ilh_rrm_mc, ilh_Nrm_mc, ilh_rsm_mc, ilh_Nsm_mc, & +!$omp ilh_rgm_mc, ilh_Ngm_mc, ilh_rim_mc, ilh_Nim_mc ) + integer, public :: & + ilh_rrm_auto = 0, & ! Latin hypercube estimate of autoconversion + ilh_rrm_accr = 0, & ! Latin hypercube estimate of accretion + ilh_rrm_evap = 0, & ! Latin hypercube estimate of evaporation + ilh_Nrm_auto = 0, & ! Latin hypercube estimate of Nrm autoconversion + ilh_Nrm_cond = 0, & ! Latin hypercube estimate of Nrm evaporation + ilh_m_vol_rad_rain = 0 + +!$omp threadprivate( ilh_rrm_auto, ilh_rrm_accr, ilh_rrm_evap, & +!$omp ilh_Nrm_auto, ilh_Nrm_cond, & +!$omp ilh_m_vol_rad_rain ) + + integer, public :: & + ilh_rrm_src_adj = 0, & ! Latin hypercube estimate of source adjustment (KK only!) + ilh_rrm_cond_adj = 0, & ! Latin hypercube estimate of evap adjustment (KK only!) + ilh_Nrm_src_adj = 0, & ! Latin hypercube estimate of Nrm source adjustmet (KK only!) + ilh_Nrm_cond_adj = 0 ! Latin hypercube estimate of Nrm evap adjustment (KK only!) +!$omp threadprivate( ilh_rrm_src_adj, ilh_rrm_cond_adj, ilh_Nrm_src_adj, & +!$omp ilh_Nrm_cond_adj ) + + integer, public :: & + ilh_Vrr = 0, & ! Latin hypercube estimate of rrm sedimentation velocity + ilh_VNr = 0 ! Latin hypercube estimate of Nrm sedimentation velocity +!$omp threadprivate(ilh_Vrr, ilh_VNr) + + integer, public :: & + ilh_rrm = 0, & + ilh_Nrm = 0, & + ilh_rim = 0, & + ilh_Nim = 0, & + ilh_rsm = 0, & + ilh_Nsm = 0, & + ilh_rgm = 0, & + ilh_Ngm = 0, & + ilh_thlm = 0, & + ilh_rcm = 0, & + ilh_Ncm = 0, & + ilh_Ncnm = 0, & + ilh_rvm = 0, & + ilh_wm = 0, & + ilh_cloud_frac = 0, & + ilh_chi = 0, & + ilh_eta = 0, & + ilh_precip_frac = 0, & + ilh_mixt_frac = 0 + +!$omp threadprivate(ilh_rrm, ilh_Nrm, ilh_rim, ilh_Nim, ilh_rsm, ilh_Nsm, & +!$omp ilh_rgm, ilh_Ngm, & +!$omp ilh_thlm, ilh_rcm, ilh_Ncm, ilh_Ncnm, ilh_rvm, ilh_wm, ilh_cloud_frac, & +!$omp ilh_chi, ilh_eta, ilh_precip_frac, ilh_mixt_frac ) + + integer, public :: & + ilh_cloud_frac_unweighted = 0, & + ilh_precip_frac_unweighted = 0, & + ilh_mixt_frac_unweighted = 0 + +!$omp threadprivate( ilh_cloud_frac_unweighted, ilh_precip_frac_unweighted, & +!$omp ilh_mixt_frac_unweighted ) + + integer, public :: & + ilh_wp2_zt = 0, & + ilh_Nrp2_zt = 0, & + ilh_Ncnp2_zt = 0, & + ilh_Ncp2_zt = 0, & + ilh_rcp2_zt = 0, & + ilh_rtp2_zt = 0, & + ilh_thlp2_zt = 0, & + ilh_rrp2_zt = 0, & + ilh_chip2 = 0 ! Eric Raut +!$omp threadprivate( ilh_wp2_zt, ilh_Nrp2_zt, ilh_Ncnp2_zt, ilh_Ncp2_zt, & +!$omp ilh_rcp2_zt, ilh_rtp2_zt, ilh_thlp2_zt, ilh_rrp2_zt, ilh_chip2 ) + + + ! Indices for Morrison budgets + integer, public :: & + iPSMLT = 0, & + iEVPMS = 0, & + iPRACS = 0, & + iEVPMG = 0, & + iPRACG = 0, & + iPGMLT = 0, & + iMNUCCC = 0, & + iPSACWS = 0, & + iPSACWI = 0, & + iQMULTS = 0, & + iQMULTG = 0, & + iPSACWG = 0, & + iPGSACW = 0, & + iPRD = 0, & + iPRCI = 0, & + iPRAI = 0, & + iQMULTR = 0, & + iQMULTRG = 0, & + iMNUCCD = 0, & + iPRACI = 0, & + iPRACIS = 0, & + iEPRD = 0, & + iMNUCCR = 0, & + iPIACR = 0, & + iPIACRS = 0, & + iPGRACS = 0, & + iPRDS = 0, & + iEPRDS = 0, & + iPSACR = 0, & + iPRDG = 0, & + iEPRDG = 0 + +!$omp threadprivate( iPSMLT, iEVPMS, iPRACS, iEVPMG, iPRACG, iPGMLT, iMNUCCC, iPSACWS, iPSACWI, & +!$omp iQMULTS, iQMULTG, iPSACWG, iPGSACW, iPRD, iPRCI, iPRAI, iQMULTR, & +!$omp iQMULTRG, iMNUCCD, iPRACI, iPRACIS, iEPRD, iMNUCCR, iPIACR, iPIACRS, & +!$omp iPGRACS, iPRDS, iEPRDS, iPSACR, iPRDG, iEPRDG ) + + ! More indices for Morrison budgets!! + integer, public :: & + iNGSTEN = 0, & + iNRSTEN = 0, & + iNISTEN = 0, & + iNSSTEN = 0, & + iNCSTEN = 0, & + iNPRC1 = 0, & + iNRAGG = 0, & + iNPRACG = 0, & + iNSUBR = 0, & + iNSMLTR = 0, & + iNGMLTR = 0, & + iNPRACS = 0, & + iNNUCCR = 0, & + iNIACR = 0, & + iNIACRS = 0, & + iNGRACS = 0, & + iNSMLTS = 0, & + iNSAGG = 0, & + iNPRCI = 0, & + iNSCNG = 0, & + iNSUBS = 0, & + iPRC = 0, & + iPRA = 0, & + iPRE = 0 + +!$omp threadprivate( iNGSTEN, iNRSTEN, iNISTEN, iNSSTEN, iNCSTEN, iNPRC1, iNRAGG, & +!$omp iNPRACG, iNSUBR, iNSMLTR, iNGMLTR, iNPRACS, iNNUCCR, iNIACR, & +!$omp iNIACRS, iNGRACS, iNSMLTS, iNSAGG, iNPRCI, iNSCNG, iNSUBS, iPRC, iPRA, iPRE ) + + ! More indices for Morrison budgets!! + integer, public :: & + iPCC = 0, & + iNNUCCC = 0, & + iNPSACWS = 0, & + iNPRA = 0, & + iNPRC = 0, & + iNPSACWI = 0, & + iNPSACWG = 0, & + iNPRAI = 0, & + iNMULTS = 0, & + iNMULTG = 0, & + iNMULTR = 0, & + iNMULTRG = 0, & + iNNUCCD = 0, & + iNSUBI = 0, & + iNGMLTG = 0, & + iNSUBG = 0, & + iNACT = 0 + + integer, public :: & + iSIZEFIX_NR = 0, & + iSIZEFIX_NC = 0, & + iSIZEFIX_NI = 0, & + iSIZEFIX_NS = 0, & + iSIZEFIX_NG = 0, & + iNEGFIX_NR = 0, & + iNEGFIX_NC = 0, & + iNEGFIX_NI = 0, & + iNEGFIX_NS = 0, & + iNEGFIX_NG = 0, & + iNIM_MORR_CL = 0, & + iQC_INST = 0, & + iQR_INST = 0, & + iQI_INST = 0, & + iQS_INST = 0, & + iQG_INST = 0, & + iNC_INST = 0, & + iNR_INST = 0, & + iNI_INST = 0, & + iNS_INST = 0, & + iNG_INST = 0, & + iT_in_K_mc = 0, & + ihl_on_Cp_residual = 0, & + iqto_residual = 0 + +!$omp threadprivate(iPCC, iNNUCCC, iNPSACWS, iNPRA, iNPRC, iNPSACWI, iNPSACWG, iNPRAI, & +!$omp iNMULTS, iNMULTG, iNMULTR, iNMULTRG, iNNUCCD, iNSUBI, iNGMLTG, iNSUBG, iNACT, & +!$omp iSIZEFIX_NR, iSIZEFIX_NC, iSIZEFIX_NI, iSIZEFIX_NS, iSIZEFIX_NG, iNEGFIX_NR, & +!$omp iNEGFIX_NC, iNEGFIX_NI, iNEGFIX_NS, iNEGFIX_NG, iNIM_MORR_CL, iQC_INST, iQR_INST, & +!$omp iQI_INST, iQS_INST, iQG_INST, iNC_INST, iNR_INST, iNI_INST, iNS_INST, & +!$omp iNG_INST, iT_in_K_mc, ihl_on_Cp_residual, iqto_residual ) + + ! Indices for statistics in stats_zm file + integer, public :: & + iwp2 = 0, & + irtp2 = 0, & + ithlp2 = 0, & + irtpthlp = 0, & + iwprtp = 0, & + iwpthlp = 0, & + iwp4 = 0, & + iwpthvp = 0, & + irtpthvp = 0, & + ithlpthvp = 0, & + itau_zm = 0, & + iKh_zm = 0, & + iwprcp = 0, & + irc_coef = 0, & + ithlprcp = 0, & + irtprcp = 0, & + ircp2 = 0, & + iupwp = 0, & + ivpwp = 0, & + iSkw_zm = 0 + + integer, public :: & + irho_zm = 0, & + isigma_sqd_w = 0, & + irho_ds_zm = 0, & + ithv_ds_zm = 0, & + iem = 0, & + ishear = 0, & ! Brian + imean_w_up = 0, & + imean_w_down = 0, & + iFrad = 0, & + iFrad_LW = 0, & ! Brian + iFrad_SW = 0, & ! Brian + iFrad_LW_up = 0, & + iFrad_SW_up = 0, & + iFrad_LW_down = 0, & + iFrad_SW_down = 0, & + iFprec = 0, & ! Brian + iFcsed = 0 ! Brian + + ! Stability correction applied to Kh_N2_zm (diffusion on rtm and thlm) + integer, public :: & + istability_correction = 0 ! schemena + +!$omp threadprivate(istability_correction) !$omp threadprivate(iwp2, irtp2, ithlp2, irtpthlp, iwprtp, iwpthlp) !$omp threadprivate(iwp4, iwpthvp, irtpthvp, ithlpthvp, itau_zm, iKh_zm) -!$omp threadprivate(iwprcp, ithlprcp, irtprcp, ircp2, iupwp, ivpwp) +!$omp threadprivate(iwprcp, irc_coef, ithlprcp, irtprcp, ircp2, iupwp, ivpwp) !$omp threadprivate(irho_zm, isigma_sqd_w, irho_ds_zm, ithv_ds_zm, iem, ishear) !$omp threadprivate(imean_w_up, imean_w_down) !$omp threadprivate(iFrad, iFrad_LW, iFrad_SW, iFrad_SW_up, iFrad_SW_down) !$omp threadprivate(iFrad_LW_up, iFrad_LW_down, iFprec, iFcsed) - ! Skewness Functions on zm grid + integer, dimension(:), allocatable, public :: & + iK_hm +!$omp threadprivate(iK_hm) + + ! Skewness Functions on stats_zm grid integer, public :: & - igamma_Skw_fnc, & - iC6rt_Skw_fnc, & - iC6thl_Skw_fnc, & - iC7_Skw_fnc, & - iC1_Skw_fnc + igamma_Skw_fnc = 0, & + iC6rt_Skw_fnc = 0, & + iC6thl_Skw_fnc = 0, & + iC7_Skw_fnc = 0, & + iC1_Skw_fnc = 0 !$omp threadprivate(igamma_Skw_fnc, iC6rt_Skw_fnc, iC6thl_Skw_fnc) !$omp threadprivate(iC7_Skw_fnc, iC1_Skw_fnc) + ! Covariance of w and cloud droplet concentration, < w'N_c' > + integer, public :: & + iwpNcp = 0 + +!$omp threadprivate( iwpNcp ) + ! Sedimentation velocities integer, public :: & - iVNr, & - iVrr, & - iVNc, & - iVrc, & - iVNsnow, & - iVrsnow, & - iVNice, & - iVrice, & - iVrgraupel - -!$omp threadprivate(iVNr, iVrr, iVNc, iVrc, iVNsnow, iVrsnow, iVNice, iVrice, iVrgraupel) - - integer, public :: & - iwp2_bt, & - iwp2_ma, & - iwp2_ta, & - iwp2_ac, & - iwp2_bp, & - iwp2_pr1, & - iwp2_pr2, & - iwp2_pr3, & - iwp2_dp1, & - iwp2_dp2, & - iwp2_4hd, & - iwp2_pd, & - iwp2_cl, & - iwp2_sf + iVNr = 0, & + iVrr = 0, & + iVNc = 0, & + iVrc = 0, & + iVNs = 0, & + iVrs = 0, & + iVNi = 0, & + iVri = 0, & + iVrg = 0 + +!$omp threadprivate(iVNr, iVrr, iVNc, iVrc, iVNs, iVrs, iVNi, iVri, iVrg) + + ! Covariance of sedimentation velocity and hydrometeor, . + integer, public :: & + iVrrprrp = 0, & + iVNrpNrp = 0, & + iVrrprrp_expcalc = 0, & + iVNrpNrp_expcalc = 0 + +!$omp threadprivate(iVrrprrp, iVNrpNrp, iVrrprrp_expcalc, iVNrpNrp_expcalc) + + integer, public :: & + iwp2_bt = 0, & + iwp2_ma = 0, & + iwp2_ta = 0, & + iwp2_ac = 0, & + iwp2_bp = 0, & + iwp2_pr1 = 0, & + iwp2_pr2 = 0, & + iwp2_pr3 = 0, & + iwp2_dp1 = 0, & + iwp2_dp2 = 0, & + iwp2_pd = 0, & + iwp2_cl = 0, & + iwp2_sf = 0 !$omp threadprivate(iwp2_bt, iwp2_ma, iwp2_ta, iwp2_ac, iwp2_bp) !$omp threadprivate(iwp2_pr1, iwp2_pr2, iwp2_pr3) -!$omp threadprivate(iwp2_dp1, iwp2_dp2, iwp2_4hd) +!$omp threadprivate(iwp2_dp1, iwp2_dp2) !$omp threadprivate(iwp2_pd, iwp2_cl, iwp2_sf) integer, public :: & - iwprtp_bt, & - iwprtp_ma, & - iwprtp_ta, & - iwprtp_tp, & - iwprtp_ac, & - iwprtp_bp, & - iwprtp_pr1, & - iwprtp_pr2, & - iwprtp_pr3, & - iwprtp_dp1, & - iwprtp_mfl, & - iwprtp_cl, & - iwprtp_sicl, & - iwprtp_pd + iwprtp_bt = 0, & + iwprtp_ma = 0, & + iwprtp_ta = 0, & + iwprtp_tp = 0, & + iwprtp_ac = 0, & + iwprtp_bp = 0, & + iwprtp_pr1 = 0, & + iwprtp_pr2 = 0, & + iwprtp_pr3 = 0, & + iwprtp_dp1 = 0, & + iwprtp_mfl = 0, & + iwprtp_cl = 0, & + iwprtp_sicl = 0, & + iwprtp_pd = 0, & + iwprtp_forcing = 0, & + iwprtp_mc = 0 !$omp threadprivate(iwprtp_bt, iwprtp_ma, iwprtp_ta, iwprtp_tp) !$omp threadprivate(iwprtp_ac, iwprtp_bp, iwprtp_pr1, iwprtp_pr2) !$omp threadprivate(iwprtp_pr3, iwprtp_dp1, iwprtp_mfl, iwprtp_cl) -!$omp threadprivate(iwprtp_sicl, iwprtp_pd) - - integer, public :: & - iwpthlp_bt, & - iwpthlp_ma, & - iwpthlp_ta, & - iwpthlp_tp, & - iwpthlp_ac, & - iwpthlp_bp, & - iwpthlp_pr1, & - iwpthlp_pr2, & - iwpthlp_pr3, & - iwpthlp_dp1, & - iwpthlp_mfl, & - iwpthlp_cl, & - iwpthlp_sicl +!$omp threadprivate(iwprtp_sicl, iwprtp_pd, iwprtp_forcing, iwprtp_mc) + + integer, public :: & + iwpthlp_bt = 0, & + iwpthlp_ma = 0, & + iwpthlp_ta = 0, & + iwpthlp_tp = 0, & + iwpthlp_ac = 0, & + iwpthlp_bp = 0, & + iwpthlp_pr1 = 0, & + iwpthlp_pr2 = 0, & + iwpthlp_pr3 = 0, & + iwpthlp_dp1 = 0, & + iwpthlp_mfl = 0, & + iwpthlp_cl = 0, & + iwpthlp_sicl = 0, & + iwpthlp_forcing = 0, & + iwpthlp_mc = 0 !$omp threadprivate(iwpthlp_bt, iwpthlp_ma, iwpthlp_ta, iwpthlp_tp) !$omp threadprivate(iwpthlp_ac, iwpthlp_bp, iwpthlp_pr1, iwpthlp_pr2) !$omp threadprivate(iwpthlp_pr3, iwpthlp_dp1, iwpthlp_mfl, iwpthlp_cl) -!$omp threadprivate(iwpthlp_sicl) +!$omp threadprivate(iwpthlp_sicl, iwpthlp_forcing, iwpthlp_mc) ! Dr. Golaz's new variance budget terms ! qt was changed to rt to avoid confusion integer, public :: & - irtp2_bt, & - irtp2_ma, & - irtp2_ta, & - irtp2_tp, & - irtp2_dp1, & - irtp2_dp2, & - irtp2_pd, & - irtp2_cl, & - irtp2_sf + irtp2_bt = 0, & + irtp2_ma = 0, & + irtp2_ta = 0, & + irtp2_tp = 0, & + irtp2_dp1 = 0, & + irtp2_dp2 = 0, & + irtp2_pd = 0, & + irtp2_cl = 0, & + irtp2_sf = 0, & + irtp2_forcing = 0, & + irtp2_mc = 0 -!$omp threadprivate(irtp2_bt, irtp2_ma, irtp2_ta, irtp2_tp) -!$omp threadprivate(irtp2_dp1, irtp2_dp2, irtp2_pd, irtp2_cl,irtp2_sf) - - integer, public :: & - ithlp2_bt, & - ithlp2_ma, & - ithlp2_ta, & - ithlp2_tp, & - ithlp2_dp1, & - ithlp2_dp2, & - ithlp2_pd, & - ithlp2_cl, & - ithlp2_sf - -!$omp threadprivate(ithlp2_bt, ithlp2_ma, ithlp2_ta, ithlp2_tp) -!$omp threadprivate(ithlp2_dp1, ithlp2_dp2, ithlp2_pd, ithlp2_cl, ithlp2_sf) - - integer, public :: & - irtpthlp_bt, & - irtpthlp_ma, & - irtpthlp_ta, & - irtpthlp_tp1, & - irtpthlp_tp2, & - irtpthlp_dp1, & - irtpthlp_dp2, & - irtpthlp_cl, & - irtpthlp_sf +!$omp threadprivate(irtp2_bt, irtp2_ma, irtp2_ta, irtp2_tp, irtp2_dp1) +!$omp threadprivate(irtp2_dp2, irtp2_pd, irtp2_cl, irtp2_sf, irtp2_forcing) +!$omp threadprivate(irtp2_mc) + + integer, public :: & + ithlp2_bt = 0, & + ithlp2_ma = 0, & + ithlp2_ta = 0, & + ithlp2_tp = 0, & + ithlp2_dp1 = 0, & + ithlp2_dp2 = 0, & + ithlp2_pd = 0, & + ithlp2_cl = 0, & + ithlp2_sf = 0, & + ithlp2_forcing = 0, & + ithlp2_mc = 0 + +!$omp threadprivate(ithlp2_bt, ithlp2_ma, ithlp2_ta, ithlp2_tp, ithlp2_dp1) +!$omp threadprivate(ithlp2_dp2, ithlp2_pd, ithlp2_cl, ithlp2_sf) +!$omp threadprivate(ithlp2_forcing, ithlp2_mc) + + integer, public :: & + irtpthlp_bt = 0, & + irtpthlp_ma = 0, & + irtpthlp_ta = 0, & + irtpthlp_tp1 = 0, & + irtpthlp_tp2 = 0, & + irtpthlp_dp1 = 0, & + irtpthlp_dp2 = 0, & + irtpthlp_cl = 0, & + irtpthlp_sf = 0, & + irtpthlp_forcing = 0, & + irtpthlp_mc = 0 !$omp threadprivate(irtpthlp_bt, irtpthlp_ma, irtpthlp_ta) !$omp threadprivate(irtpthlp_tp1, irtpthlp_tp2, irtpthlp_dp1) -!$omp threadprivate(irtpthlp_dp2, irtpthlp_cl, irtpthlp_sf) +!$omp threadprivate(irtpthlp_dp2, irtpthlp_cl, irtpthlp_sf, irtpthlp_forcing) +!$omp threadprivate(irtpthlp_mc) integer, public :: & - iup2, & - ivp2 + iup2 = 0, & + ivp2 = 0 !$omp threadprivate(iup2, ivp2) integer, public :: & - iup2_bt, & - iup2_ta, & - iup2_tp, & - iup2_ma, & - iup2_dp1, & - iup2_dp2, & - iup2_pr1, & - iup2_pr2, & - iup2_pd, & - iup2_cl, & - iup2_sf, & - ivp2_bt, & - ivp2_ta, & - ivp2_tp, & - ivp2_ma, & - ivp2_dp1, & - ivp2_dp2, & - ivp2_pr1, & - ivp2_pr2, & - ivp2_pd, & - ivp2_cl, & - ivp2_sf + iup2_bt = 0, & + iup2_ta = 0, & + iup2_tp = 0, & + iup2_ma = 0, & + iup2_dp1 = 0, & + iup2_dp2 = 0, & + iup2_pr1 = 0, & + iup2_pr2 = 0, & + iup2_pd = 0, & + iup2_cl = 0, & + iup2_sf = 0, & + ivp2_bt = 0, & + ivp2_ta = 0, & + ivp2_tp = 0, & + ivp2_ma = 0, & + ivp2_dp1 = 0, & + ivp2_dp2 = 0, & + ivp2_pr1 = 0, & + ivp2_pr2 = 0, & + ivp2_pd = 0, & + ivp2_cl = 0, & + ivp2_sf = 0 !$omp threadprivate(iup2_bt, iup2_ta, iup2_tp, iup2_ma, iup2_dp1) !$omp threadprivate(iup2_dp2, iup2_pr1, iup2_pr2, iup2_cl, iup2_sf) @@ -772,122 +1148,154 @@ module stats_variables integer, target, allocatable, dimension(:), public :: & iwpedsclrp ! eddy sclr'(1)w' -!$omp threadprivate(iwpedsclrp) - ! Indices for statistics in rad_zt file - integer, public :: & - iT_in_K_rad, & - ircil_rad, & - io3l_rad, & - irsnowm_rad, & - ircm_in_cloud_rad, & - icloud_frac_rad, & - iradht_rad, & - iradht_LW_rad, & - iradht_SW_rad - -!$omp threadprivate(iT_in_K_rad, ircil_rad, io3l_rad) -!$omp threadprivate(irsnowm_rad, ircm_in_cloud_rad, icloud_frac_rad) -!$omp threadprivate(iradht_rad, iradht_LW_rad, iradht_SW_rad) +!$omp threadprivate(iwpedsclrp) - ! Indices for statistics in rad_zm file + ! Indices for statistics in stats_rad_zt file integer, public :: & - iFrad_LW_rad, & - iFrad_SW_rad, & - iFrad_SW_up_rad, & - iFrad_LW_up_rad, & - iFrad_SW_down_rad, & - iFrad_LW_down_rad + iT_in_K_rad = 0, & + ircil_rad = 0, & + io3l_rad = 0, & + irsm_rad = 0, & + ircm_in_cloud_rad = 0, & + icloud_frac_rad = 0, & + iice_supersat_frac_rad = 0, & + iradht_rad = 0, & + iradht_LW_rad = 0, & + iradht_SW_rad = 0, & + ip_in_mb_rad = 0, & + isp_humidity_rad = 0 + +!$omp threadprivate( iT_in_K_rad, ircil_rad, io3l_rad, & +!$omp irsm_rad, ircm_in_cloud_rad, icloud_frac_rad, & +!$omp iice_supersat_frac_rad, & +!$omp iradht_rad, iradht_LW_rad, iradht_SW_rad, & +!$omp ip_in_mb_rad, isp_humidity_rad ) + + ! Indices for statistics in stats_rad_zm file + integer, public :: & + iFrad_LW_rad = 0, & + iFrad_SW_rad = 0, & + iFrad_SW_up_rad = 0, & + iFrad_LW_up_rad = 0, & + iFrad_SW_down_rad = 0, & + iFrad_LW_down_rad = 0 !$omp threadprivate(iFrad_LW_rad, iFrad_SW_rad, iFrad_SW_up_rad) !$omp threadprivate(iFrad_LW_up_rad, iFrad_SW_down_rad, iFrad_LW_down_rad) - ! Indices for statistics in sfc file - - integer, public :: & - iustar, & - isoil_heat_flux,& - iveg_T_in_K,& - isfc_soil_T_in_K, & - ideep_soil_T_in_K,& - ilh, & - ish, & - icc, & - ilwp, & - ivwp, & ! nielsenb - iiwp, & ! nielsenb - iswp, & ! nielsenb - irwp, & - iz_cloud_base, & - iz_inversion, & - irain_rate_sfc, & ! Brian - irain_flux_sfc, & ! Brian - irrainm_sfc, & ! Brian - iwpthlp_sfc, & - iwprtp_sfc, & - iupwp_sfc, & - ivpwp_sfc, & - ithlm_vert_avg, & - irtm_vert_avg, & - ium_vert_avg, & - ivm_vert_avg, & - iwp2_vert_avg, & ! nielsenb - iup2_vert_avg, & - ivp2_vert_avg, & - irtp2_vert_avg, & - ithlp2_vert_avg, & - iT_sfc ! kcwhite - - integer, public :: & - iwp23_matrix_condt_num, & - irtm_matrix_condt_num, & - ithlm_matrix_condt_num, & - irtp2_matrix_condt_num, & - ithlp2_matrix_condt_num, & - irtpthlp_matrix_condt_num, & - iup2_vp2_matrix_condt_num, & - iwindm_matrix_condt_num + ! Indices for statistics in stats_sfc file integer, public :: & - imorr_rain_rate, & - imorr_snow_rate - + iustar = 0, & + isoil_heat_flux = 0,& + iveg_T_in_K = 0,& + isfc_soil_T_in_K = 0, & + ideep_soil_T_in_K = 0,& + ilh = 0, & + ish = 0, & + icc = 0, & + ilwp = 0, & + ivwp = 0, & ! nielsenb + iiwp = 0, & ! nielsenb + iswp = 0, & ! nielsenb + irwp = 0, & + iz_cloud_base = 0, & + iz_inversion = 0, & + iprecip_rate_sfc = 0, & ! Brian + irain_flux_sfc = 0, & ! Brian + irrm_sfc = 0, & ! Brian + iwpthlp_sfc = 0 !$omp threadprivate(iustar, isoil_heat_flux, iveg_T_in_K, isfc_soil_T_in_K, ideep_soil_T_in_K, & !$omp ilh, ish, icc, ilwp, ivwp, iiwp, iswp, irwp, iz_cloud_base, iz_inversion, & -!$omp irain_rate_sfc, irain_flux_sfc, irrainm_sfc, & -!$omp iwpthlp_sfc, iwprtp_sfc, iupwp_sfc, ivpwp_sfc, & +!$omp iprecip_rate_sfc, irain_flux_sfc, irrm_sfc, & +!$omp iwpthlp_sfc ) + + integer, public :: & + iwprtp_sfc = 0, & + iupwp_sfc = 0, & + ivpwp_sfc = 0, & + ithlm_vert_avg = 0, & + irtm_vert_avg = 0, & + ium_vert_avg = 0, & + ivm_vert_avg = 0, & + iwp2_vert_avg = 0, & ! nielsenb + iup2_vert_avg = 0, & + ivp2_vert_avg = 0, & + irtp2_vert_avg = 0, & + ithlp2_vert_avg = 0, & + iT_sfc ! kcwhite +!$omp threadprivate(iwprtp_sfc, iupwp_sfc, ivpwp_sfc, & !$omp ithlm_vert_avg, irtm_vert_avg, ium_vert_avg, ivm_vert_avg, & -!$omp iwp2_vert_avg, iup2_vert_avg, ivp2_vert_avg, irtp2_vert_avg, ithlp2_vert_avg, iT_sfc, & -!$omp iwp23_matrix_condt_num, irtm_matrix_condt_num, ithlm_matrix_condt_num, & +!$omp iwp2_vert_avg, iup2_vert_avg, ivp2_vert_avg, irtp2_vert_avg, ithlp2_vert_avg, iT_sfc) + + integer, public :: & + iwp23_matrix_condt_num = 0, & + irtm_matrix_condt_num = 0, & + ithlm_matrix_condt_num = 0, & + irtp2_matrix_condt_num = 0, & + ithlp2_matrix_condt_num = 0, & + irtpthlp_matrix_condt_num = 0, & + iup2_vp2_matrix_condt_num = 0, & + iwindm_matrix_condt_num = 0 +!$omp threadprivate(iwp23_matrix_condt_num, irtm_matrix_condt_num, ithlm_matrix_condt_num, & !$omp irtp2_matrix_condt_num, ithlp2_matrix_condt_num, irtpthlp_matrix_condt_num, & -!$omp iup2_vp2_matrix_condt_num, iwindm_matrix_condt_num, & -!$omp imorr_rain_rate, imorr_snow_rate) +!$omp iup2_vp2_matrix_condt_num, iwindm_matrix_condt_num) + + integer, public :: & + imorr_snow_rate = 0 + +!$omp threadprivate( imorr_snow_rate) integer, public :: & - irtm_spur_src, & - ithlm_spur_src -!$omp threadprivate( irtm_spur_src, ithlm_spur_src) + irtm_spur_src = 0, & + ithlm_spur_src = 0 + +!$omp threadprivate(irtm_spur_src, ithlm_spur_src) integer, public :: & - iSkw_velocity, & ! Skewness velocity - iwp3_zm, & - ia3_coef, & - ia3_coef_zt + iSkw_velocity = 0, & ! Skewness velocity + iwp3_zm = 0, & + ia3_coef = 0, & + ia3_coef_zt = 0 !$omp threadprivate(iSkw_velocity, iwp3_zm, ia3_coef, ia3_coef_zt) integer, public :: & - iwp3_on_wp2, & ! w'^3 / w'^2 [m/s] - iwp3_on_wp2_zt ! w'^3 / w'^2 [m/s] + iwp3_on_wp2 = 0, & ! w'^3 / w'^2 [m/s] + iwp3_on_wp2_zt = 0 ! w'^3 / w'^2 [m/s] !$omp threadprivate(iwp3_on_wp2, iwp3_on_wp2_zt) + integer, public :: & + ilh_morr_snow_rate = 0 +!$omp threadprivate( ilh_morr_snow_rate ) + + integer, public :: & + ilh_vwp = 0, & + ilh_lwp = 0 +!$omp threadprivate( ilh_vwp, ilh_lwp ) + + + integer, public :: & + icloud_frac_refined = 0, & + ircm_refined = 0 +!$omp threadprivate( icloud_frac_refined, ircm_refined ) + + integer, public :: & + irtp2_from_chi = 0 + +!$omp threadprivate( irtp2_from_chi ) + ! Variables that contains all the statistics - type (stats), target, public :: zt, & ! zt grid - zm, & ! zm grid - rad_zt, & ! rad_zt grid - rad_zm, & ! rad_zm grid - sfc ! sfc + type (stats), target, public :: stats_zt, & ! stats_zt grid + stats_zm, & ! stats_zm grid + stats_lh_zt, & ! stats_lh_zt grid + stats_lh_sfc, & ! stats_lh_sfc grid + stats_rad_zt, & ! stats_rad_zt grid + stats_rad_zm, & ! stats_rad_zm grid + stats_sfc ! stats_sfc -!$omp threadprivate(zt, zm, rad_zt, rad_zm, sfc) +!$omp threadprivate(stats_zt, stats_zm, stats_lh_zt, stats_lh_sfc) +!$omp threadprivate(stats_rad_zt, stats_rad_zm, stats_sfc) ! Scratch space @@ -900,11 +1308,11 @@ module stats_variables ztscr16, ztscr17, ztscr18, & ztscr19, ztscr20, ztscr21 -!$omp threadprivate(ztscr01, ztscr02, ztscr03, ztscr04, ztscr05) -!$omp threadprivate(ztscr06, ztscr07, ztscr08, ztscr09, ztscr10) -!$omp threadprivate(ztscr11, ztscr12, ztscr13, ztscr14, ztscr15) -!$omp threadprivate(ztscr16, ztscr17, ztscr18, ztscr19, ztscr20) -!$omp threadprivate(ztscr21) +!$omp threadprivate(ztscr01, ztscr02, ztscr03, ztscr04, ztscr05) +!$omp threadprivate(ztscr06, ztscr07, ztscr08, ztscr09, ztscr10) +!$omp threadprivate(ztscr11, ztscr12, ztscr13, ztscr14, ztscr15) +!$omp threadprivate(ztscr16, ztscr17, ztscr18, ztscr19, ztscr20) +!$omp threadprivate(ztscr21) real( kind = core_rknd ), dimension(:), allocatable, public :: & zmscr01, zmscr02, zmscr03, & @@ -919,17 +1327,4 @@ module stats_variables !$omp threadprivate(zmscr11, zmscr12, zmscr13, zmscr14, zmscr15) !$omp threadprivate(zmscr16, zmscr17) - real( kind = core_rknd ), dimension(:), allocatable, public :: & - radscr01, radscr02, radscr03, & - radscr04, radscr05, radscr06, & - radscr07, radscr08, radscr09, & - radscr10, radscr11, radscr12, & - radscr13, radscr14, radscr15, & - radscr16, radscr17 - -!$omp threadprivate(radscr01, radscr02, radscr03, radscr04, radscr05) -!$omp threadprivate(radscr06, radscr07, radscr08, radscr09, radscr10) -!$omp threadprivate(radscr11, radscr12, radscr13, radscr14, radscr15) -!$omp threadprivate(radscr16, radscr17) - end module stats_variables diff --git a/models/atm/cam/src/physics/clubb/stats_zm.F90 b/models/atm/cam/src/physics/clubb/stats_zm.F90 deleted file mode 100644 index 72121646e24e..000000000000 --- a/models/atm/cam/src/physics/clubb/stats_zm.F90 +++ /dev/null @@ -1,1618 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: stats_zm.F90 5633 2012-01-19 01:00:48Z vondeyle@uwm.edu $ -module stats_zm - - implicit none - - private ! Default Scope - - public :: stats_init_zm - - ! Constant parameters - integer, parameter, public :: nvarmax_zm = 250 ! Maximum variables allowed - - contains - -!----------------------------------------------------------------------- - subroutine stats_init_zm( vars_zm, l_error ) - -! Description: -! Initializes array indices for zm - -! Note: -! All code that is within subroutine stats_init_zm, including variable -! allocation code, is not called if l_stats is false. This subroutine is -! called only when l_stats is true. - -!----------------------------------------------------------------------- - - use constants_clubb, only: & - fstderr ! Constant(s) - - use stats_variables, only: & - zm, & - iwp2, & - irtp2, & - ithlp2, & - irtpthlp, & - iwprtp, & - iwpthlp, & - iwp3_zm, & - iwp4, & - iwpthvp, & - irtpthvp, & - ithlpthvp, & - itau_zm, & - iKh_zm, & - iwprcp, & - ithlprcp, & - irtprcp, & - ircp2, & - iupwp, & - ivpwp, & - irho_zm, & - isigma_sqd_w, & - irho_ds_zm, & - ithv_ds_zm, & - iem, & - ishear, & - imean_w_up, & - imean_w_down, & - iFrad, & - iFrad_LW, & - iFrad_SW, & - iFrad_LW_up, & - iFrad_SW_up, & - iFrad_LW_down, & - iFrad_SW_down, & - iFprec, & - iFcsed - - use stats_variables, only: & - iup2, & - ivp2, & - iup2_bt, & - iup2_ta, & - iup2_tp, & - iup2_ma, & - iup2_dp1, & - iup2_dp2, & - iup2_pr1, & - iup2_pr2, & - iup2_cl, & - iup2_pd, & - iup2_sf, & - ivp2_bt, & - ivp2_ta, & - ivp2_tp, & - ivp2_ma, & - ivp2_dp1, & - ivp2_dp2, & - ivp2_pr1, & - ivp2_pr2, & - ivp2_cl, & - ivp2_pd, & - ivp2_sf, & - iVNr, & - iVrr, & - iVNc, & - iVrc, & - iVNice, & - iVrice, & - iVNsnow, & - iVrsnow, & - iVrgraupel - - use stats_variables, only: & - iwp2_bt, & - iwp2_ma, & - iwp2_ta, & - iwp2_ac, & - iwp2_bp, & - iwp2_pr1, & - iwp2_pr2, & - iwp2_pr3, & - iwp2_dp1, & - iwp2_dp2, & - iwp2_4hd, & - iwp2_cl, & - iwp2_pd, & - iwp2_sf - - use stats_variables, only: & - iwprtp_bt, & - iwprtp_ma, & - iwprtp_ta, & - iwprtp_tp, & - iwprtp_ac, & - iwprtp_bp, & - iwprtp_pr1, & - iwprtp_pr2, & - iwprtp_pr3, & - iwprtp_dp1, & - iwprtp_mfl, & - iwprtp_cl, & - iwprtp_sicl, & - iwprtp_pd, & - iwpthlp_bt, & - iwpthlp_ma, & - iwpthlp_ta, & - iwpthlp_tp, & - iwpthlp_ac, & - iwpthlp_bp, & - iwpthlp_pr1, & - iwpthlp_pr2, & - iwpthlp_pr3, & - iwpthlp_dp1, & - iwpthlp_mfl, & - iwpthlp_cl, & - iwpthlp_sicl - - use stats_variables, only: & - irtp2_bt, & - irtp2_ma, & - irtp2_ta, & - irtp2_tp, & - irtp2_dp1, & - irtp2_dp2, & - irtp2_cl, & - irtp2_pd, & - irtp2_sf, & - ithlp2_bt, & - ithlp2_ma, & - ithlp2_ta, & - ithlp2_tp, & - ithlp2_dp1, & - ithlp2_dp2, & - ithlp2_cl, & - ithlp2_pd, & - ithlp2_sf, & - irtpthlp_bt, & - irtpthlp_ma, & - irtpthlp_ta, & - irtpthlp_tp1, & - irtpthlp_tp2, & - irtpthlp_dp1, & - irtpthlp_dp2, & - irtpthlp_cl, & - irtpthlp_sf - - use stats_variables, only: & - iwpthlp_entermfl, & ! Variable(s) - iwpthlp_exit_mfl, & - iwpthlp_mfl_min, & - iwpthlp_mfl_max, & - iwprtp_enter_mfl, & - iwprtp_exit_mfl, & - iwprtp_mfl_min, & - iwprtp_mfl_max - - use stats_variables, only: & - iwm_zm, & ! Variable - icloud_frac_zm, & - ircm_zm, & - irtm_zm, & - ithlm_zm - - use stats_variables, only: & - isclrprtp, & - isclrp2, & - isclrpthvp, & - isclrpthlp, & - isclrprcp, & - iwpsclrp, & - iwp2sclrp, & - iwpsclrp2, & - iwpsclrprtp, & - iwpsclrpthlp, & - iwpedsclrp - - use stats_variables, only: & - ia3_coef, & - iwp3_on_wp2, & - itp2_mellor_1, & - itp2_mellor_2, & - isptp_mellor_1, & - isptp_mellor_2, & - icorr_st_mellor1, & - icorr_st_mellor2, & - iSkw_velocity, & - igamma_Skw_fnc, & - iC6rt_Skw_fnc, & - iC6thl_Skw_fnc, & - iC7_Skw_fnc, & - iC1_Skw_fnc - - use stats_type, only: & - stat_assign ! Procedure - - use parameters_model, only: & - sclr_dim, & - edsclr_dim - -! use error_code, only: & -! clubb_at_least_debug_level ! Function - - implicit none - - ! Input Variable - ! zm variable names - - character(len= * ), dimension(nvarmax_zm), intent(in) :: vars_zm - - ! Output Variable - logical, intent(inout) :: l_error - - ! Local Varables - integer :: i,j, k - - logical :: l_found - - character(len=50) :: sclr_idx - -! Default initialization for array indices for zm - - iwp2 = 0 - irtp2 = 0 - ithlp2 = 0 - irtpthlp = 0 - iwprtp = 0 - iwpthlp = 0 - iwp3_zm = 0 - iwp4 = 0 - iwpthvp = 0 - irtpthvp = 0 - ithlpthvp = 0 - itau_zm = 0 - iKh_zm = 0 - iwprcp = 0 - ithlprcp = 0 - irtprcp = 0 - ircp2 = 0 - iupwp = 0 - ivpwp = 0 - irho_zm = 0 - isigma_sqd_w = 0 - irho_ds_zm = 0 - ithv_ds_zm = 0 - iem = 0 - ishear = 0 ! Brian - imean_w_up = 0 - imean_w_down = 0 - iFrad = 0 - iFrad_LW = 0 ! Brian - iFrad_SW = 0 ! Brian - iFrad_LW_up = 0 ! Brian - iFrad_SW_up = 0 ! Brian - iFrad_LW_down = 0 ! Brian - iFrad_SW_down = 0 ! Brian - iFprec = 0 ! Brian - iFcsed = 0 ! Brian - - - iup2 = 0 - ivp2 = 0 - - iup2_bt = 0 - iup2_ta = 0 - iup2_tp = 0 - iup2_ma = 0 - iup2_dp1 = 0 - iup2_dp2 = 0 - iup2_pr1 = 0 - iup2_pr2 = 0 - iup2_cl = 0 - iup2_sf = 0 - - ivp2_bt = 0 - ivp2_ta = 0 - ivp2_tp = 0 - ivp2_ma = 0 - ivp2_dp1 = 0 - ivp2_dp2 = 0 - ivp2_pr1 = 0 - ivp2_pr2 = 0 - ivp2_cl = 0 - ivp2_sf = 0 - - ! Sedimentation velocities - iVNr = 0 - iVrr = 0 - iVNc = 0 - iVrc = 0 - iVNice = 0 - iVrice = 0 - iVrgraupel = 0 - iVNsnow = 0 - iVrsnow = 0 - - ! Vertical velocity budgets - iwp2_bt = 0 - iwp2_ma = 0 - iwp2_ta = 0 - iwp2_ac = 0 - iwp2_bp = 0 - iwp2_pr1 = 0 - iwp2_pr2 = 0 - iwp2_pr3 = 0 - iwp2_dp1 = 0 - iwp2_dp2 = 0 - iwp2_4hd = 0 - iwp2_cl = 0 - iwp2_pd = 0 - iwp2_sf = 0 - - ! Flux budgets - iwprtp_bt = 0 - iwprtp_ma = 0 - iwprtp_ta = 0 - iwprtp_tp = 0 - iwprtp_ac = 0 - iwprtp_bp = 0 - iwprtp_pr1 = 0 - iwprtp_pr2 = 0 - iwprtp_pr3 = 0 - iwprtp_dp1 = 0 - iwprtp_mfl = 0 - iwprtp_cl = 0 - iwprtp_sicl = 0 - iwprtp_pd = 0 - - iwpthlp_bt = 0 - iwpthlp_ma = 0 - iwpthlp_ta = 0 - iwpthlp_tp = 0 - iwpthlp_ac = 0 - iwpthlp_bp = 0 - iwpthlp_pr1 = 0 - iwpthlp_pr2 = 0 - iwpthlp_pr3 = 0 - iwpthlp_dp1 = 0 - iwpthlp_mfl = 0 - iwpthlp_cl = 0 - iwpthlp_sicl = 0 - - ! Variance budgets - irtp2_bt = 0 - irtp2_ma = 0 - irtp2_ta = 0 - irtp2_tp = 0 - irtp2_dp1 = 0 - irtp2_dp2 = 0 - irtp2_cl = 0 - irtp2_pd = 0 - irtp2_sf = 0 - - ithlp2_bt = 0 - ithlp2_ma = 0 - ithlp2_ta = 0 - ithlp2_tp = 0 - ithlp2_dp1 = 0 - ithlp2_dp2 = 0 - ithlp2_cl = 0 - ithlp2_pd = 0 - ithlp2_sf = 0 - - irtpthlp_bt = 0 - irtpthlp_ma = 0 - irtpthlp_ta = 0 - irtpthlp_tp1 = 0 - irtpthlp_tp2 = 0 - irtpthlp_dp1 = 0 - irtpthlp_dp2 = 0 - irtpthlp_cl = 0 - irtpthlp_sf = 0 - - !Monatonic flux limiter diagnostic output - iwpthlp_mfl_min = 0 - iwpthlp_mfl_max = 0 - iwpthlp_entermfl = 0 - iwpthlp_exit_mfl = 0 - iwprtp_mfl_min = 0 - iwprtp_mfl_max = 0 - iwprtp_enter_mfl = 0 - iwprtp_exit_mfl = 0 - - ! Diagnostics for s and t Mellor - itp2_mellor_1 = 0 - itp2_mellor_2 = 0 - isptp_mellor_1 = 0 - isptp_mellor_2 = 0 - - icorr_st_mellor1 = 0 - icorr_st_mellor2 = 0 - - ! Skewness velocity - iSkw_velocity = 0 - - ! Skewness function - igamma_Skw_fnc = 0 - iC6rt_Skw_fnc = 0 - iC6thl_Skw_fnc = 0 - iC7_Skw_fnc = 0 - iC1_Skw_fnc = 0 - - ia3_coef = 0 - iwp3_on_wp2 = 0 - - allocate(isclrprtp(1:sclr_dim)) - allocate(isclrp2(1:sclr_dim)) - allocate(isclrpthvp(1:sclr_dim)) - allocate(isclrpthlp(1:sclr_dim)) - allocate(isclrprcp(1:sclr_dim)) - allocate(iwpsclrp(1:sclr_dim)) - allocate(iwp2sclrp(1:sclr_dim)) - allocate(iwpsclrp2(1:sclr_dim)) - allocate(iwpsclrprtp(1:sclr_dim)) - allocate(iwpsclrpthlp(1:sclr_dim)) - - allocate(iwpedsclrp(1:edsclr_dim)) - -! Assign pointers for statistics variables zm - - isclrprtp = 0 - isclrp2 = 0 - isclrpthvp = 0 - isclrpthlp = 0 - isclrprcp = 0 - iwpsclrp = 0 - iwp2sclrp = 0 - iwpsclrp2 = 0 - iwpsclrprtp = 0 - iwpsclrpthlp = 0 - - iwpedsclrp = 0 - -! Assign pointers for statistics variables zm - - k = 1 - do i=1,zm%nn - - select case ( trim(vars_zm(i)) ) - - case ('wp2') - iwp2 = k - call stat_assign(iwp2,"wp2", & - "w'^2, Variance of vertical air velocity [m^2/s^2]","m^2/s^2",zm) - k = k + 1 - - case ('rtp2') - irtp2 = k - call stat_assign(irtp2,"rtp2", & - "rt'^2, Variance of rt [(kg/kg)^2]","(kg/kg)^2",zm) - k = k + 1 - - case ('thlp2') - ithlp2 = k - call stat_assign(ithlp2,"thlp2", & - "thl'^2, Variance of thl [K^2]","K^2",zm) - k = k + 1 - - case ('rtpthlp') - irtpthlp = k - call stat_assign(irtpthlp,"rtpthlp", & - "rt'thl', Covariance of rt and thl [(kg K)/kg]","(kg K)/kg",zm) - k = k + 1 - - case ('wprtp') - iwprtp = k - - call stat_assign(iwprtp,"wprtp", & - "w'rt', Vertical turbulent flux of rt [(kg/kg) m/s]","(m kg)/(s kg)",zm) - k = k + 1 - - case ('wpthlp') - iwpthlp = k - - call stat_assign(iwpthlp,"wpthlp", & - "w'thl', Vertical turbulent flux of thl [K m/s]","(m K)/s",zm) - k = k + 1 - - case ('wp3_zm') - iwp3_zm = k - call stat_assign( iwp3_zm, "wp3_zm", & - "w'^3 interpolated to moment. levels [m^3/s^3]", "(m^3)/(s^3)", zm ) - k = k + 1 - - case ('wp4') - iwp4 = k - call stat_assign(iwp4,"wp4", & - "w'^4 [m^4/s^4]","(m^4)/(s^4)",zm) - k = k + 1 - - case ('wpthvp') - iwpthvp = k - call stat_assign(iwpthvp,"wpthvp", & - "Buoyancy flux [K m/s]","K m/s",zm) - k = k + 1 - - case ('rtpthvp') - irtpthvp = k - call stat_assign(irtpthvp,"rtpthvp", & - "rt'thv' [(kg/kg) K]","(kg/kg) K",zm) - k = k + 1 - - case ('thlpthvp') - ithlpthvp = k - call stat_assign(ithlpthvp,"thlpthvp", & - "thl'thv' [K^2]","K^2",zm) - k = k + 1 - - case ('tau_zm') - itau_zm = k - - call stat_assign(itau_zm,"tau_zm", & - "Time-scale tau on momentum levels [s]","s",zm) - k = k + 1 - - case ('Kh_zm') - iKh_zm = k - - call stat_assign(iKh_zm,"Kh_zm", & - "Eddy diffusivity on momentum levels [m^2/s]","m^2/s",zm) - k = k + 1 - - case ('wprcp') - iwprcp = k - call stat_assign(iwprcp,"wprcp", & - "w' rc' [(m/s) (kg/kg)]","(m/s) (kg/kg)",zm) - k = k + 1 - - case ('thlprcp') - ithlprcp = k - call stat_assign(ithlprcp,"thlprcp", & - "thl' rc' [K (kg/kg)]","K (kg/kg)",zm) - k = k + 1 - - case ('rtprcp') - irtprcp = k - - call stat_assign(irtprcp,"rtprcp", & - "rt'rc' [(kg^2)/(kg^2)]","(kg^2)/(kg^2)",zm) - k = k + 1 - - case ('rcp2') - ircp2 = k - call stat_assign(ircp2,"rcp2", & - "rc'^2 [(kg^2)/(kg^2)]","(kg^2)/(kg^2)",zm) - k = k + 1 - case ('upwp') - iupwp = k - call stat_assign(iupwp,"upwp", & - "u'w', Vertical east-west momentum flux [m^2/s^2]","m^2/s^2",zm) - k = k + 1 - case ('vpwp') - ivpwp = k - call stat_assign(ivpwp,"vpwp", & - "v'w', Vertical north-south momentum flux [m^2/s^2]","m^2/s^2",zm) - k = k + 1 - case ('rho_zm') - irho_zm = k - call stat_assign(irho_zm,"rho_zm", & - "Density on momentum levels [kg/m^3]","kg m^{-3}",zm) - k = k + 1 - case ('sigma_sqd_w') - isigma_sqd_w = k - call stat_assign(isigma_sqd_w,"sigma_sqd_w", & - "Nondimensionalized w variance of Gaussian component [-]","-",zm) - k = k + 1 - case ('rho_ds_zm') - irho_ds_zm = k - call stat_assign(irho_ds_zm,"rho_ds_zm", & - "Dry, static, base-state density [kg/m^3]","kg m^{-3}",zm) - k = k + 1 - case ('thv_ds_zm') - ithv_ds_zm = k - call stat_assign(ithv_ds_zm,"thv_ds_zm", & - "Dry, base-state theta_v [K]","K",zm) - k = k + 1 - case ('em') - iem = k - call stat_assign(iem,"em", & - "Turbulent kinetic energy, usu. 0.5*(u'^2+v'^2+w'^2) [m^2/s^2]","m^2/s^2",zm) - k = k + 1 - case ('shear') ! Brian - ishear = k - call stat_assign(ishear,"shear", & - "Wind shear production term [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - case ('mean_w_up') - imean_w_up = k - call stat_assign(imean_w_up, "mean_w_up", & - "Mean w >= w_ref [m/s]", "m/s", zm) - k = k + 1 - case ('mean_w_down') - imean_w_down = k - call stat_assign(imean_w_down, "mean_w_down", & - "Mean w <= w_ref [m/s]", "m/s", zm) - k = k + 1 - case ('Frad') - iFrad = k - call stat_assign(iFrad,"Frad", & - "Total (sw+lw) net (up+down) radiative flux [W/m^2]","W/m^2",zm) - k = k + 1 - case ('Frad_LW') ! Brian - iFrad_LW = k - call stat_assign(iFrad_LW,"Frad_LW", & - "Net long-wave radiative flux [W/m^2]","W/m^2",zm) - k = k + 1 - case ('Frad_SW') ! Brian - iFrad_SW = k - - call stat_assign(iFrad_SW,"Frad_SW", & - "Net short-wave radiative flux [W/m^2]","W/m^2",zm) - k = k + 1 - - case ('Frad_LW_up') ! Brian - iFrad_LW_up = k - call stat_assign(iFrad_LW_up,"Frad_LW_up", & - "Long-wave upwelling radiative flux [W/m^2]","W/m^2",zm) - k = k + 1 - case ('Frad_SW_up') ! Brian - iFrad_SW_up = k - - call stat_assign(iFrad_SW_up,"Frad_SW_up", & - "Short-wave upwelling radiative flux [W/m^2]","W/m^2",zm) - k = k + 1 - - case ('Frad_LW_down') ! Brian - iFrad_LW_down = k - call stat_assign(iFrad_LW_down,"Frad_LW_down", & - "Long-wave downwelling radiative flux [W/m^2]", "W/m^2", zm ) - k = k + 1 - case ('Frad_SW_down') ! Brian - iFrad_SW_down = k - - call stat_assign(iFrad_SW_down,"Frad_SW_down", & - "Short-wave downwelling radiative flux [W/m^2]", "W/m^2", zm ) - k = k + 1 - - - case ('Fprec') ! Brian - iFprec = k - - call stat_assign(iFprec,"Fprec", & - "Rain flux [W/m^2]","W/m^2",zm) - k = k + 1 - - case ('Fcsed') ! Brian - iFcsed = k - - call stat_assign(iFcsed,"Fcsed", & - "cloud water sedimentation flux [kg/(s*m^2)]", & - "kg/(s*m^2)",zm) - k = k + 1 - - case ('VNr') - iVNr = k - - call stat_assign(iVNr,"VNr", & - "rrainm concentration fallspeed [m/s]","m/s",zm) - k = k + 1 - - case ('Vrr') - iVrr = k - - call stat_assign(iVrr,"Vrr", & - "rrainm mixing ratio fallspeed [m/s]","m/s",zm) - k = k + 1 - - case ('VNc') - iVNc = k - - call stat_assign(iVNc,"VNc", & - "Nrm concentration fallspeed [m/s]","m/s",zm) - k = k + 1 - - case ('Vrc') - iVrc = k - - call stat_assign(iVrc,"Vrc", & - "Nrm mixing ratio fallspeed [m/s]","m/s",zm) - k = k + 1 - - case ('VNsnow') - iVNsnow = k - - call stat_assign(iVNsnow,"VNsnow", & - "Snow concentration fallspeed [m/s]","m/s",zm) - k = k + 1 - - case ('Vrsnow') - iVrsnow = k - - call stat_assign(iVrsnow,"Vrsnow", & - "Snow mixing ratio fallspeed [m/s]","m/s",zm) - k = k + 1 - - case ('Vrgraupel') - iVrgraupel = k - - call stat_assign(iVrgraupel,"Vrgraupel", & - "Graupel sedimentation velocity [m/s]","m/s",zm) - k = k + 1 - - case ('VNice') - iVNice = k - - call stat_assign(iVNice,"VNice", & - "Cloud ice concentration fallspeed [m/s]","m/s",zm) - k = k + 1 - - case ('Vrice') - iVrice = k - - call stat_assign(iVrice,"Vrice", & - "Cloud ice mixing ratio fallspeed [m/s]","m/s",zm) - k = k + 1 - - case ('wp2_bt') - iwp2_bt = k - - call stat_assign(iwp2_bt,"wp2_bt", & - "wp2 budget: wp2 time tendency [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('wp2_ma') - iwp2_ma = k - - call stat_assign(iwp2_ma,"wp2_ma", & - "wp2 budget: wp2 vertical mean advection [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('wp2_ta') - iwp2_ta = k - - call stat_assign(iwp2_ta,"wp2_ta", & - "wp2 budget: wp2 turbulent advection [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('wp2_ac') - iwp2_ac = k - - call stat_assign(iwp2_ac,"wp2_ac", & - "wp2 budget: wp2 accumulation term [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('wp2_bp') - iwp2_bp = k - - call stat_assign(iwp2_bp,"wp2_bp", & - "wp2 budget: wp2 buoyancy production [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('wp2_pr1') - iwp2_pr1 = k - - call stat_assign(iwp2_pr1,"wp2_pr1", & - "wp2 budget: wp2 pressure term 1 [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('wp2_pr2') - iwp2_pr2 = k - call stat_assign(iwp2_pr2,"wp2_pr2", & - "wp2 budget: wp2 pressure term 2 [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('wp2_pr3') - iwp2_pr3 = k - call stat_assign(iwp2_pr3,"wp2_pr3", & - "wp2 budget: wp2 pressure term 3 [m^2/s^3]","m^2/s^3",zm) - - k = k + 1 - - case ('wp2_dp1') - iwp2_dp1 = k - call stat_assign(iwp2_dp1,"wp2_dp1", & - "wp2 budget: wp2 dissipation term 1 [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('wp2_dp2') - iwp2_dp2 = k - call stat_assign(iwp2_dp2,"wp2_dp2", & - "wp2 budget: wp2 dissipation term 2 [m^2/s^3]","m^2/s^3",zm) - - k = k + 1 - - case ('wp2_4hd') - iwp2_4hd = k - call stat_assign(iwp2_4hd,"wp2_4hd", & - "wp2 budget: wp2 4th-order hyper-diffusion [m^2/s^3]","m^2/s^3",zm) - - k = k + 1 - - case ('wp2_cl') - iwp2_cl = k - - call stat_assign(iwp2_cl,"wp2_cl", & - "wp2 budget: wp2 clipping term [m^2/s^3]","m^2/s^3",zm) - - k = k + 1 - - case ('wp2_pd') - iwp2_pd = k - - call stat_assign(iwp2_pd,"wp2_pd", & - "wp2 budget: wp2 positive definite adjustment [m^2/s^3]","m2/s3",zm) - - k = k + 1 - - case ('wp2_sf') - iwp2_sf = k - - call stat_assign( iwp2_sf, "wp2_sf", & - "wp2 budget: wp2 surface variance [m^2/s^3]","m2/s3",zm) - - k = k + 1 - - case ('wprtp_bt') - iwprtp_bt = k - call stat_assign(iwprtp_bt,"wprtp_bt", & - "wprtp budget: wprtp time tendency [(m kg)/(s^2 kg)]","(m kg)/(s^2 kg)",zm) - k = k + 1 - - case ('wprtp_ma') - iwprtp_ma = k - - call stat_assign(iwprtp_ma,"wprtp_ma", & - "wprtp budget: wprtp mean advection [(m kg)/(s^2 kg)]","(m kg)/(s^2 kg)",zm) - k = k + 1 - - case ('wprtp_ta') - iwprtp_ta = k - - call stat_assign(iwprtp_ta,"wprtp_ta", & - "wprtp budget: wprtp turbulent advection [(m kg)/(s^2 kg)]","(m kg)/(s^2 kg)",zm) - k = k + 1 - - case ('wprtp_tp') - iwprtp_tp = k - - call stat_assign(iwprtp_tp,"wprtp_tp", & - "wprtp budget: wprtp turbulent production [(m kg)/(s^2 kg)]","(m kg)/(s^2 kg)",zm) - k = k + 1 - - case ('wprtp_ac') - iwprtp_ac = k - - call stat_assign(iwprtp_ac,"wprtp_ac", & - "wprtp budget: wprtp accumulation term [(m kg)/(s^2 kg)]","(m kg)/(s^2 kg)",zm) - k = k + 1 - - case ('wprtp_bp') - iwprtp_bp = k - - call stat_assign(iwprtp_bp,"wprtp_bp", & - "wprtp budget: wprtp buoyancy production [(m kg)/(s^2 kg)]","(m kg)/(s^2 kg)",zm) - k = k + 1 - - case ('wprtp_pr1') - iwprtp_pr1 = k - - call stat_assign(iwprtp_pr1,"wprtp_pr1", & - "wprtp budget: wprtp pressure term 1 [(m kg)/(s^2 kg)]","(m kg)/(s^2 kg)",zm) - k = k + 1 - - case ('wprtp_pr2') - iwprtp_pr2 = k - - call stat_assign(iwprtp_pr2,"wprtp_pr2", & - "wprtp budget: wprtp pressure term 2 [(m kg)/(s^2 kg)]","(m kg)/(s^2 kg)",zm) - k = k + 1 - - case ('wprtp_pr3') - iwprtp_pr3 = k - - call stat_assign(iwprtp_pr3,"wprtp_pr3", & - "wprtp budget: wprtp pressure term 3 [(m kg)/(s^2 kg)]","(m kg)/(s^2 kg)",zm) - k = k + 1 - - case ('wprtp_dp1') - iwprtp_dp1 = k - - call stat_assign(iwprtp_dp1,"wprtp_dp1", & - "wprtp budget: wprtp dissipation term 1 [(m kg)/(s^2 kg)]","(m kg)/(s^2 kg)",zm) - k = k + 1 - - case ('wprtp_mfl') - iwprtp_mfl = k - - call stat_assign(iwprtp_mfl,"wprtp_mfl", & - "wprtp budget: wprtp monotonic flux limiter [(m kg)/(s^2 kg)]","(m kg)/(s^2 kg)",zm) - k = k + 1 - - case ('wprtp_cl') - iwprtp_cl = k - - call stat_assign(iwprtp_cl,"wprtp_cl", & - "wprtp budget: wprtp clipping term [(m kg)/(s^2 kg)]","(m kg)/(s^2 kg)",zm) - k = k + 1 - - case ('wprtp_sicl') - iwprtp_sicl = k - - call stat_assign(iwprtp_sicl,"wprtp_sicl", & - "wprtp budget: wprtp semi-implicit clipping term [(m kg)/(s^2 kg)]", & - "(m kg)/(s^2 kg)",zm) - k = k + 1 - - case ('wprtp_pd') - iwprtp_pd = k - - call stat_assign(iwprtp_pd,"wprtp_pd", & - "wprtp budget: wprtp flux corrected trans. term [(m kg)/(s^2 kg)]", & - "(m kg)/(s^2 kg)",zm) - k = k + 1 - - case ('wpthlp_bt') - iwpthlp_bt = k - - call stat_assign(iwpthlp_bt,"wpthlp_bt", & - "wpthlp budget: [(m K)/s^2]","(m K)/s^2",zm) - k = k + 1 - - case ('wpthlp_ma') - iwpthlp_ma = k - call stat_assign(iwpthlp_ma,"wpthlp_ma", & - "wpthlp budget: wpthlp mean advection [(m K)/s^2]","(m K)/s^2",zm) - - k = k + 1 - - case ('wpthlp_ta') - iwpthlp_ta = k - call stat_assign(iwpthlp_ta,"wpthlp_ta", & - "wpthlp budget: wpthlp turbulent advection [(m K)/s^2]","(m K)/s^2",zm) - - k = k + 1 - - case ('wpthlp_tp') - iwpthlp_tp = k - call stat_assign(iwpthlp_tp,"wpthlp_tp", & - "wpthlp budget: wpthlp turbulent production [(m K)/s^2]","(m K)/s^2",zm) - - k = k + 1 - - case ('wpthlp_ac') - iwpthlp_ac = k - call stat_assign(iwpthlp_ac,"wpthlp_ac", & - "wpthlp budget: wpthlp accumulation term [(m K)/s^2]","(m K)/s^2",zm) - - k = k + 1 - - case ('wpthlp_bp') - iwpthlp_bp = k - call stat_assign(iwpthlp_bp,"wpthlp_bp", & - "wpthlp budget: wpthlp buoyancy production [(m K)/s^2]","(m K)/s^2",zm) - k = k + 1 - - case ('wpthlp_pr1') - iwpthlp_pr1 = k - - call stat_assign(iwpthlp_pr1,"wpthlp_pr1", & - "wpthlp budget: wpthlp pressure term 1 [(m K)/s^2]","(m K)/s^2",zm) - k = k + 1 - - case ('wpthlp_pr2') - iwpthlp_pr2 = k - - call stat_assign(iwpthlp_pr2,"wpthlp_pr2", & - "wpthlp budget: wpthlp pressure term 2 [(m K)/s^2]","(m K)/s^2",zm) - k = k + 1 - - case ('wpthlp_pr3') - iwpthlp_pr3 = k - call stat_assign(iwpthlp_pr3,"wpthlp_pr3", & - "wpthlp budget: wpthlp pressure term 3 [(m K)/s^2]","(m K)/s^2",zm) - k = k + 1 - - case ('wpthlp_dp1') - iwpthlp_dp1 = k - call stat_assign(iwpthlp_dp1,"wpthlp_dp1", & - "wpthlp budget: wpthlp dissipation term 1 [(m K)/s^2]","(m K)/s^2",zm) - k = k + 1 - - case ('wpthlp_mfl') - iwpthlp_mfl = k - call stat_assign(iwpthlp_mfl,"wpthlp_mfl", & - "wpthlp budget: wpthlp monotonic flux limiter [(m K)/s^2]","(m K)/s^2",zm) - k = k + 1 - - case ('wpthlp_cl') - iwpthlp_cl = k - call stat_assign(iwpthlp_cl,"wpthlp_cl", & - "wpthlp budget: wpthlp clipping term [(m K)/s^2]","(m K)/s^2",zm) - k = k + 1 - - case ('wpthlp_sicl') - iwpthlp_sicl = k - call stat_assign(iwpthlp_sicl,"wpthlp_sicl", & - "wpthlp budget: wpthlp semi-implicit clipping term [(m K)/s^2]","(m K)/s^2",zm) - k = k + 1 - - ! Variance budgets - case ('rtp2_bt') - irtp2_bt = k - call stat_assign(irtp2_bt,"rtp2_bt", & - "rtp2 budget: rtp2 time tendency [(kg^2)/(kg^2 s)]","(kg^2)/(kg^2 s)",zm) - k = k + 1 - case ('rtp2_ma') - irtp2_ma = k - call stat_assign(irtp2_ma,"rtp2_ma", & - "rtp2 budget: rtp2 mean advection [(kg^2)/(kg^2 s)]","(kg^2)/(kg^2 s)",zm) - k = k + 1 - case ('rtp2_ta') - irtp2_ta = k - call stat_assign(irtp2_ta,"rtp2_ta", & - "rtp2 budget: rtp2 turbulent advection [(kg^2)/(kg^2 s)]","(kg^2)/(kg^2 s)",zm) - k = k + 1 - case ('rtp2_tp') - irtp2_tp = k - call stat_assign(irtp2_tp,"rtp2_tp", & - "rtp2 budget: rtp2 turbulent production [(kg^2)/(kg^2 s)]","(kg^2)/(kg^2 s)",zm) - k = k + 1 - case ('rtp2_dp1') - irtp2_dp1 = k - call stat_assign(irtp2_dp1,"rtp2_dp1", & - "rtp2 budget: rtp2 dissipation term 1 [(kg^2)/(kg^2 s)]","(kg^2)/(kg^2 s)",zm) - k = k + 1 - case ('rtp2_dp2') - irtp2_dp2 = k - call stat_assign(irtp2_dp2,"rtp2_dp2", & - "rtp2 budget: rtp2 dissipation term 2 [(kg^2)/(kg^2 s)]","(kg^2)/(kg^2 s)",zm) - k = k + 1 - case ('rtp2_cl') - irtp2_cl = k - call stat_assign(irtp2_cl,"rtp2_cl", & - "rtp2 budget: rtp2 clipping term [(kg^2)/(kg^2 s)]","(kg^2)/(kg^2 s)",zm) - k = k + 1 - - case ('rtp2_pd') - irtp2_pd = k - call stat_assign( irtp2_pd, "rtp2_pd", & - "rtp2 budget: rtp2 positive definite adjustment [(kg^2)/(kg^2 s)]", & - "(kg^2)/(kg^2 s)", zm ) - k = k + 1 - - case ('rtp2_sf') - irtp2_sf = k - call stat_assign( irtp2_sf, "rtp2_sf", & - "rtp2 budget: rtp2 surface variance [(kg^2)/(kg^2 s)]", & - "(kg^2)/(kg^2 s)", zm ) - k = k + 1 - - case ('thlp2_bt') - ithlp2_bt = k - call stat_assign(ithlp2_bt,"thlp2_bt", & - "thlp2 budget: thlp2 time tendency [(K^2)/s]","(K^2)/s",zm) - k = k + 1 - case ('thlp2_ma') - ithlp2_ma = k - call stat_assign(ithlp2_ma,"thlp2_ma", & - "thlp2 budget: thlp2 mean advection [(K^2)/s]","(K^2)/s",zm) - k = k + 1 - case ('thlp2_ta') - ithlp2_ta = k - call stat_assign(ithlp2_ta,"thlp2_ta", & - "thlp2 budget: thlp2 turbulent advection [(K^2)/s]","(K^2)/s",zm) - k = k + 1 - case ('thlp2_tp') - ithlp2_tp = k - call stat_assign(ithlp2_tp,"thlp2_tp", & - "thlp2 budget: thlp2 turbulent production [(K^2)/s]","(K^2)/s",zm) - k = k + 1 - case ('thlp2_dp1') - ithlp2_dp1 = k - call stat_assign(ithlp2_dp1,"thlp2_dp1", & - "thlp2 budget: thlp2 dissipation term 1 [(K^2)/s]","(K^2)/s",zm) - k = k + 1 - case ('thlp2_dp2') - ithlp2_dp2 = k - call stat_assign(ithlp2_dp2,"thlp2_dp2", & - "thlp2 budget: thlp2 dissipation term 2 [(K^2)/s]","(K^2)/s",zm) - k = k + 1 - case ('thlp2_cl') - ithlp2_cl = k - call stat_assign(ithlp2_cl,"thlp2_cl", & - "thlp2 budget: thlp2 clipping term [(K^2)/s]","(K^2)/s",zm) - k = k + 1 - - case ('thlp2_pd') - ithlp2_pd = k - call stat_assign( ithlp2_pd, "thlp2_pd", & - "thlp2 budget: thlp2 positive definite adjustment [(K^2)/s]", "m^2/s^2", zm ) - k = k + 1 - - case ('thlp2_sf') - ithlp2_sf = k - call stat_assign( ithlp2_sf, "thlp2_sf", & - "thlp2 budget: thlp2 surface variance [(K^2)/s]", "m^2/s^2", zm ) - k = k + 1 - - case ('rtpthlp_bt') - irtpthlp_bt = k - call stat_assign(irtpthlp_bt,"rtpthlp_bt", & - "rtpthlp budget: rtpthlp time tendency [(kg K)/(kg s)]","(kg K)/(kg s)",zm) - k = k + 1 - case ('rtpthlp_ma') - irtpthlp_ma = k - call stat_assign(irtpthlp_ma,"rtpthlp_ma", & - "rtpthlp budget: rtpthlp mean advection [(kg K)/(kg s)]","(kg K)/(kg s)",zm) - k = k + 1 - case ('rtpthlp_ta') - irtpthlp_ta = k - call stat_assign(irtpthlp_ta,"rtpthlp_ta", & - "rtpthlp budget: rtpthlp turbulent advection [](kg K)/(kg s)","(kg K)/(kg s)",zm) - k = k + 1 - case ('rtpthlp_tp1') - irtpthlp_tp1 = k - call stat_assign(irtpthlp_tp1,"rtpthlp_tp1", & - "rtpthlp budget: rtpthlp turbulent production 1 [(kg K)/(kg s)]","(kg K)/(kg s)",zm) - k = k + 1 - case ('rtpthlp_tp2') - irtpthlp_tp2 = k - call stat_assign(irtpthlp_tp2,"rtpthlp_tp2", & - "rtpthlp budget: rtpthlp turbulent production 2 [(kg K)/(kg s)]","(kg K)/(kg s)",zm) - k = k + 1 - case ('rtpthlp_dp1') - irtpthlp_dp1 = k - call stat_assign(irtpthlp_dp1,"rtpthlp_dp1", & - "rtpthlp budget: rtpthlp dissipation term 1 [(kg K)/(kg s)]","(kg K)/(kg s)",zm) - k = k + 1 - case ('rtpthlp_dp2') - irtpthlp_dp2 = k - call stat_assign(irtpthlp_dp2,"rtpthlp_dp2", & - "rtpthlp budget: rtpthlp dissipation term 2 [(kg K)/(kg s)]","(kg K)/(kg s)",zm) - k = k + 1 - case ('rtpthlp_cl') - irtpthlp_cl = k - call stat_assign(irtpthlp_cl,"rtpthlp_cl", & - "rtpthlp budget: rtpthlp clipping term [(kg K)/(kg s)]","(kg K)/(kg s)",zm) - k = k + 1 - case ('rtpthlp_sf') - irtpthlp_sf = k - call stat_assign(irtpthlp_sf,"rtpthlp_sf", & - "rtpthlp budget: rtpthlp surface variance [(kg K)/(kg s)]","(kg K)/(kg s)",zm) - k = k + 1 - - case ('up2') - iup2 = k - call stat_assign(iup2,"up2", & - "u'^2 (momentum levels) [m^2/s^2]","m^2/s^2",zm) - k = k + 1 - - case ('vp2') - ivp2 = k - call stat_assign(ivp2,"vp2", & - "v'^2 (momentum levels) [m^2/s^2]","m^2/s^2",zm) - k = k + 1 - - case ('up2_bt') - iup2_bt = k - call stat_assign(iup2_bt,"up2_bt", & - "up2 budget: up2 time tendency [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('up2_ma') - iup2_ma = k - call stat_assign(iup2_ma,"up2_ma", & - "up2 budget: up2 mean advection [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('up2_ta') - iup2_ta = k - call stat_assign(iup2_ta,"up2_ta", & - "up2 budget: up2 turbulent advection [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('up2_tp') - iup2_tp = k - call stat_assign(iup2_tp,"up2_tp", & - "up2 budget: up2 turbulent production [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('up2_dp1') - iup2_dp1 = k - call stat_assign(iup2_dp1,"up2_dp1", & - "up2 budget: up2 dissipation term 1 [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('up2_dp2') - iup2_dp2 = k - call stat_assign(iup2_dp2,"up2_dp2", & - "up2 budget: up2 dissipation term 2 [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('up2_pr1') - iup2_pr1 = k - call stat_assign(iup2_pr1,"up2_pr1", & - "up2 budget: up2 pressure term 1 [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('up2_pr2') - iup2_pr2 = k - call stat_assign(iup2_pr2,"up2_pr2", & - "up2 budget: up2 pressure term 2 [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('up2_cl') - iup2_cl = k - call stat_assign(iup2_cl,"up2_cl", & - "up2 budget: up2 clipping [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('up2_pd') - iup2_pd = k - call stat_assign( iup2_pd, "up2_pd", & - "up2 budget: up2 positive definite adjustment [m^2/s^3]", "m^2/s^3", zm ) - k = k + 1 - - case ('up2_sf') - iup2_sf = k - call stat_assign(iup2_sf,"up2_sf", & - "up2 budget: up2 surface variance [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('vp2_bt') - ivp2_bt = k - call stat_assign(ivp2_bt,"vp2_bt", & - "vp2 budget: vp2 time tendency [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('vp2_ma') - ivp2_ma = k - call stat_assign(ivp2_ma,"vp2_ma", & - "vp2 budget: vp2 mean advection [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('vp2_ta') - ivp2_ta = k - call stat_assign(ivp2_ta,"vp2_ta", & - "vp2 budget: vp2 turbulent advection [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('vp2_tp') - ivp2_tp = k - call stat_assign(ivp2_tp,"vp2_tp", & - "vp2 budget: vp2 turbulent production [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('vp2_dp1') - ivp2_dp1 = k - call stat_assign(ivp2_dp1,"vp2_dp1", & - "vp2 budget: vp2 dissipation term 1 [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('vp2_dp2') - ivp2_dp2 = k - call stat_assign(ivp2_dp2,"vp2_dp2", & - "vp2 budget: vp2 dissipation term 2 [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('vp2_pr1') - ivp2_pr1 = k - call stat_assign(ivp2_pr1,"vp2_pr1", & - "vp2 budget: vp2 pressure term 1 [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('vp2_pr2') - ivp2_pr2 = k - call stat_assign(ivp2_pr2,"vp2_pr2", & - "vp2 budget: vp2 pressure term 2 [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('vp2_cl') - ivp2_cl = k - call stat_assign(ivp2_cl,"vp2_cl", & - "vp2 budget: vp2 clipping [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('vp2_pd') - ivp2_pd = k - call stat_assign( ivp2_pd, "vp2_pd", & - "vp2 budget: vp2 positive definite adjustment [m^2/s^3]", "m^2/s^3", zm ) - k = k + 1 - - case ('vp2_sf') - ivp2_sf = k - call stat_assign( ivp2_sf, "vp2_sf", & - "vp2 budget: vp2 surface variance [m^2/s^3]", "m^2/s^3", zm ) - k = k + 1 - - case ('wpthlp_entermfl') - iwpthlp_entermfl = k - call stat_assign( iwpthlp_entermfl, "wpthlp_entermfl", & - "Wpthlp entering flux limiter [(m K)/s]", "(m K)/s", zm ) - k = k + 1 - - case ('wpthlp_exit_mfl') - iwpthlp_exit_mfl = k - call stat_assign( iwpthlp_exit_mfl, "wpthlp_exit_mfl", & - "Wpthlp exiting flux limiter [](m K)/s", "(m K)/s", zm ) - k = k + 1 - - case ('wpthlp_mfl_min') - iwpthlp_mfl_min = k - call stat_assign( iwpthlp_mfl_min, "wpthlp_mfl_min", & - "Minimum allowable wpthlp [(m K)/s]", "(m K)/s", zm ) - k = k + 1 - - case ('wpthlp_mfl_max') - iwpthlp_mfl_max = k - call stat_assign( iwpthlp_mfl_max, "wpthlp_mfl_max", & - "Maximum allowable wpthlp ((m K)/s) [(m K)/s]", "(m K)/s", zm ) - k = k + 1 - - case ('wprtp_mfl_min') - iwprtp_mfl_min = k - call stat_assign( iwprtp_mfl_min, "wprtp_mfl_min", & - "Minimum allowable wprtp [(m kg)/(s kg)]", "(m kg)/(s kg)", zm ) - k = k + 1 - - case ('wprtp_mfl_max') - iwprtp_mfl_max = k - call stat_assign( iwprtp_mfl_max, "wprtp_mfl_max", & - "Maximum allowable wprtp [(m kg)/(s kg)]", "(m kg)/(s kg)", zm ) - k = k + 1 - - case ('wprtp_enter_mfl') - iwprtp_enter_mfl = k - call stat_assign( iwprtp_enter_mfl, "wprtp_enter_mfl", & - "Wprtp entering flux limiter [(m kg)/(s kg)]", "(m kg)/(s kg)", zm ) - k = k + 1 - - case ('wprtp_exit_mfl') - iwprtp_exit_mfl = k - call stat_assign( iwprtp_exit_mfl, "wprtp_exit_mfl", & - "Wprtp exiting flux limiter [(m kg)/(s kg)]", "(m kg)/(s kg)", zm ) - k = k + 1 - - case ('wm_zm') - iwm_zm = k - call stat_assign( iwm_zm, "wm_zm", & - "Vertical (w) wind [m/s]", "m/s", zm ) - k = k + 1 - - case ('cloud_frac_zm') - icloud_frac_zm = k - call stat_assign( icloud_frac_zm, "cloud_frac_zm", & - "Cloud fraction", "count", zm ) - k = k + 1 - - case ('rcm_zm') - ircm_zm = k - call stat_assign( ircm_zm, "rcm_zm", & - "Total water mixing ratio [kg/kg]", "kg/kg", zm ) - k = k + 1 - - case ('rtm_zm') - irtm_zm = k - call stat_assign( irtm_zm, "rtm_zm", & - "Total water mixing ratio [kg/kg]", "kg/kg", zm ) - k = k + 1 - - case ('thlm_zm') - ithlm_zm = k - call stat_assign( ithlm_zm, "thlm_zm", & - "Liquid potential temperature [K]", "K", zm ) - k = k + 1 - - case ( 'tp2_mellor_1' ) - itp2_mellor_1 = k - call stat_assign( itp2_mellor_1, "tp2_mellor_1", & - "Variance of t_mellor_1 [kg^2/kg^2]", "kg^2/kg^2", zm ) - k = k + 1 - - case ( 'tp2_mellor_2' ) - itp2_mellor_2 = k - call stat_assign( itp2_mellor_2, "tp2_mellor_2", & - "Variance of t_mellor_2 [kg^2/kg^2]", "kg^2/kg^2", zm ) - k = k + 1 - - case ( 'sptp_mellor_1' ) - isptp_mellor_1 = k - call stat_assign( isptp_mellor_1, "sptp_mellor_1", & - "Covariance between s_mellor_1 and t_mellor_1 [kg^2/kg^2]", "kg^2/kg^2", zm ) - k = k + 1 - - case ( 'sptp_mellor_2' ) - isptp_mellor_2 = k - call stat_assign( isptp_mellor_2, "sptp_mellor_2", & - "Covariance between s_mellor_2 and t_mellor_2 [kg^2/kg^2]", "kg^2/kg^2", zm ) - k = k + 1 - - case ( 'corr_st_mellor1' ) - icorr_st_mellor1 = k - call stat_assign( icorr_st_mellor1, "corr_st_mellor1", & - "Correlation between s_mellor_1 and t_mellor_1 [-]", "count", zm ) - k = k + 1 - - case ( 'corr_st_mellor2' ) - icorr_st_mellor2 = k - call stat_assign( icorr_st_mellor2, "corr_st_mellor2", & - "Correlation between s_mellor_2 and t_mellor_2 [-]", "count", zm ) - k = k + 1 - - case ( 'Skw_velocity' ) - iSkw_velocity = k - call stat_assign( iSkw_velocity, "Skw_velocity", & - "Skewness velocity [m/s]", "m/s", zm ) - k = k + 1 - - case ( 'gamma_Skw_fnc' ) - igamma_Skw_fnc = k - call stat_assign( igamma_Skw_fnc, "gamma_Skw_fnc", & - "Gamma as a function of skewness [-]", "count", zm ) - k = k + 1 - - case ( 'C6rt_Skw_fnc' ) - iC6rt_Skw_fnc = k - call stat_assign( iC6rt_Skw_fnc, "C6rt_Skw_fnc", & - "C_6rt parameter with Sk_w applied [-]", "count", zm ) - k = k + 1 - - case ( 'C6thl_Skw_fnc' ) - iC6thl_Skw_fnc = k - call stat_assign( iC6thl_Skw_fnc, "C6thl_Skw_fnc", & - "C_6thl parameter with Sk_w applied [-]", "count", zm ) - k = k + 1 - - case ( 'C7_Skw_fnc' ) - iC7_Skw_fnc = k - call stat_assign( iC7_Skw_fnc, "C7_Skw_fnc", & - "C_7 parameter with Sk_w applied [-]", "count", zm ) - k = k + 1 - - case ( 'C1_Skw_fnc' ) - iC1_Skw_fnc = k - call stat_assign( iC1_Skw_fnc, "C1_Skw_fnc", & - "C_1 parameter with Sk_w applied [-]", "count", zm ) - k = k + 1 - - case ( 'a3_coef' ) - ia3_coef = k - call stat_assign( ia3_coef, "a3_coef", & - "Quantity in formula 25 from Equations for CLUBB [-]", "count", zm ) - k = k + 1 - - case ( 'wp3_on_wp2' ) - iwp3_on_wp2 = k - call stat_assign( iwp3_on_wp2, "wp3_on_wp2", & - "Smoothed version of wp3 / wp2 [m/s]", "m/s", zm ) - k = k + 1 - - case default - l_found = .false. - - j = 1 - - do while( j <= sclr_dim .and. .not. l_found ) - write( sclr_idx, * ) j - sclr_idx = adjustl(sclr_idx) - - if( trim(vars_zm(i)) == 'sclr'//trim(sclr_idx)//'prtp'.and. .not. l_found ) then - isclrprtp(j) = k - - call stat_assign(isclrprtp(j),"sclr"//trim(sclr_idx)//"prtp", & - "scalar("//trim(sclr_idx)//")'rt'","unknown",zm) - k = k + 1 - l_found = .true. - end if - if( trim(vars_zm(i)) == 'sclr'//trim(sclr_idx)//'p2'.and. .not. l_found ) then - isclrp2(j) = k - call stat_assign(isclrp2(j) ,"sclr"//trim(sclr_idx)//"p2", & - "scalar("//trim(sclr_idx)//")'^2'","unknown",zm) - k = k + 1 - l_found = .true. - end if - if( trim(vars_zm(i)) == 'sclr'//trim(sclr_idx)//'pthvp'.and. .not. l_found ) then - isclrpthvp(j) = k - call stat_assign(isclrpthvp(j),"sclr"//trim(sclr_idx)//"pthvp", & - "scalar("//trim(sclr_idx)//")'th_v'","unknown",zm) - k = k + 1 - l_found = .true. - end if - if( trim(vars_zm(i)) == 'sclr'//trim(sclr_idx)//'pthlp'.and. .not. l_found ) then - isclrpthlp(j) = k - - call stat_assign(isclrpthlp(j),"sclr"//trim(sclr_idx)//"pthlp", & - "scalar("//trim(sclr_idx)//")'th_l'","unknown",zm) - k = k + 1 - l_found = .true. - end if - if( trim(vars_zm(i)) == 'sclr'//trim(sclr_idx)//'prcp'.and. .not. l_found ) then - - isclrprcp(j) = k - - call stat_assign(isclrprcp(j),"sclr"//trim(sclr_idx)//"prcp", & - "scalar("//trim(sclr_idx)//")'rc'","unknown",zm) - k = k + 1 - l_found = .true. - end if - if( trim(vars_zm(i)) == 'wpsclr'//trim(sclr_idx)//'p'.and. .not. l_found ) then - iwpsclrp(j) = k - - call stat_assign(iwpsclrp(j),"wpsclr"//trim(sclr_idx)//"p", & - "'w'scalar("//trim(sclr_idx)//")","unknown",zm) - k = k + 1 - l_found = .true. - end if - if( trim(vars_zm(i)) == 'wpsclr'//trim(sclr_idx)//'p2'.and. .not. l_found ) then - - iwpsclrp2(j) = k - - call stat_assign(iwpsclrp2(j),"wpsclr"//trim(sclr_idx)//"p2", & - "'w'scalar("//trim(sclr_idx)//")'^2'","unknown",zm) - k = k + 1 - l_found = .true. - end if - if( trim(vars_zm(i)) == 'wp2sclr'//trim(sclr_idx)//'p'.and. .not. l_found ) then - - iwp2sclrp(j) = k - - call stat_assign(iwp2sclrp(j) ,"wp2sclr"//trim(sclr_idx)//"p", & - "'w'^2 scalar("//trim(sclr_idx)//")","unknown",zm) - k = k + 1 - l_found = .true. - end if - if( trim(vars_zm(i)) == 'wpsclr'//trim(sclr_idx)//'prtp'.and. .not. l_found ) then - iwpsclrprtp(j) = k - - call stat_assign( iwpsclrprtp(j),"wpsclr"//trim(sclr_idx)//"prtp", & - "'w' scalar("//trim(sclr_idx)//")'rt'","unknown",zm ) - k = k + 1 - l_found = .true. - end if - if( trim(vars_zm(i)) == 'wpsclr'//trim(sclr_idx)//'pthlp'.and. .not. l_found ) then - iwpsclrpthlp(j) = k - - call stat_assign(iwpsclrpthlp(j),"wpsclr"//trim(sclr_idx)//"pthlp", & - "'w' scalar("//trim(sclr_idx)//")'th_l'","unknown",zm) - k = k + 1 - l_found = .true. - end if - j = j + 1 - end do - - j = 1 - - do while( j <= edsclr_dim .and. .not. l_found ) - - write( sclr_idx, * ) j - sclr_idx = adjustl(sclr_idx) - - if( trim(vars_zm(i)) == 'wpedsclr'//trim(sclr_idx)//'p'.and. .not. l_found ) then - iwpedsclrp(j) = k - - call stat_assign(iwpedsclrp(j),"wpedsclr"//trim(sclr_idx)//"p", & - "eddy scalar("//trim(sclr_idx)//")'w'","unknown",zm) - k = k + 1 - l_found = .true. - end if - - j = j + 1 - - end do - - if( .not. l_found ) then - write(fstderr,*) 'Error: unrecognized variable in vars_zm: ', trim(vars_zm(i)) - l_error = .true. ! This will stop the run. - end if - end select - - end do - -! Non-interative diagnostics (zm) -! iwp4, ircp2 - -! if ( .not. clubb_at_least_debug_level( 1 ) ) then -! if ( iwp4 + ircp2 + ishear > 0 ) then -! write(fstderr,'(a)') & -! "Warning: at debug level 0. Non-interactive diagnostics will not be computed, " -! write(fstderr,'(a)') "but some appear in the stats_zm namelist variable." -! end if -! end if - - return - end subroutine stats_init_zm - -end module stats_zm diff --git a/models/atm/cam/src/physics/clubb/stats_zm_module.F90 b/models/atm/cam/src/physics/clubb/stats_zm_module.F90 new file mode 100644 index 000000000000..a54cd92642a0 --- /dev/null +++ b/models/atm/cam/src/physics/clubb/stats_zm_module.F90 @@ -0,0 +1,1950 @@ +!----------------------------------------------------------------------- +! $Id: stats_zm_module.F90 7377 2014-11-11 02:43:45Z bmg2@uwm.edu $ +!=============================================================================== +module stats_zm_module + + implicit none + + private ! Default Scope + + public :: stats_init_zm + + ! Constant parameters + integer, parameter, public :: nvarmax_zm = 250 ! Maximum variables allowed + + contains + +!----------------------------------------------------------------------- + subroutine stats_init_zm( vars_zm, l_error ) + +! Description: +! Initializes array indices for stats_zm + +! Note: +! All code that is within subroutine stats_init_zm, including variable +! allocation code, is not called if l_stats is false. This subroutine is +! called only when l_stats is true. + +!----------------------------------------------------------------------- + + use constants_clubb, only: & + fstderr ! Constant(s) + + use stats_variables, only: & + stats_zm, & + iwp2, & + irtp2, & + ithlp2, & + irtpthlp, & + iwprtp, & + iwpthlp, & + iwp3_zm, & + iwp4, & + iwpthvp, & + irtpthvp, & + ithlpthvp, & + itau_zm, & + iKh_zm, & + iK_hm, & + iwprcp, & + irc_coef, & + ithlprcp, & + irtprcp, & + ircp2, & + iSkw_zm + + use stats_variables, only: & + iupwp, & + ivpwp, & + irho_zm, & + isigma_sqd_w, & + irho_ds_zm, & + ithv_ds_zm, & + iem, & + ishear, & + imean_w_up, & + imean_w_down, & + iFrad, & + iFrad_LW, & + iFrad_SW, & + iFrad_LW_up, & + iFrad_SW_up, & + iFrad_LW_down, & + iFrad_SW_down, & + iFprec, & + iFcsed, & + istability_correction + + use stats_variables, only: & + iup2, & + ivp2, & + iup2_bt, & + iup2_ta, & + iup2_tp, & + iup2_ma, & + iup2_dp1, & + iup2_dp2, & + iup2_pr1, & + iup2_pr2, & + iup2_cl, & + iup2_pd, & + iup2_sf, & + ivp2_bt, & + ivp2_ta, & + ivp2_tp, & + ivp2_ma, & + ivp2_dp1, & + ivp2_dp2, & + ivp2_pr1, & + ivp2_pr2, & + ivp2_cl, & + ivp2_pd, & + ivp2_sf + + use stats_variables, only: & + iwpNcp + + use stats_variables, only: & + iVNr, & + iVrr, & + iVNc, & + iVrc, & + iVNi, & + iVri, & + iVNs, & + iVrs, & + iVrg, & + iVrrprrp, & + iVNrpNrp, & + iVrrprrp_expcalc, & + iVNrpNrp_expcalc + + use stats_variables, only: & + iwp2_bt, & + iwp2_ma, & + iwp2_ta, & + iwp2_ac, & + iwp2_bp, & + iwp2_pr1, & + iwp2_pr2, & + iwp2_pr3, & + iwp2_dp1, & + iwp2_dp2, & + iwp2_cl, & + iwp2_pd, & + iwp2_sf + + use stats_variables, only: & + iwprtp_bt, & + iwprtp_ma, & + iwprtp_ta, & + iwprtp_tp, & + iwprtp_ac, & + iwprtp_bp, & + iwprtp_pr1, & + iwprtp_pr2, & + iwprtp_pr3, & + iwprtp_dp1, & + iwprtp_mfl, & + iwprtp_cl, & + iwprtp_sicl, & + iwprtp_pd, & + iwprtp_forcing, & + iwprtp_mc, & + iwpthlp_bt, & + iwpthlp_ma, & + iwpthlp_ta + + use stats_variables, only: & + iwpthlp_tp, & + iwpthlp_ac, & + iwpthlp_bp, & + iwpthlp_pr1, & + iwpthlp_pr2, & + iwpthlp_pr3, & + iwpthlp_dp1, & + iwpthlp_mfl, & + iwpthlp_cl, & + iwpthlp_sicl, & + iwpthlp_forcing, & + iwpthlp_mc + + use stats_variables, only: & + irtp2_bt, & + irtp2_ma, & + irtp2_ta, & + irtp2_tp, & + irtp2_dp1, & + irtp2_dp2, & + irtp2_cl, & + irtp2_pd, & + irtp2_sf, & + irtp2_forcing, & + irtp2_mc, & + ithlp2_bt, & + ithlp2_ma, & + ithlp2_ta, & + ithlp2_tp, & + ithlp2_dp1, & + ithlp2_dp2, & + ithlp2_cl, & + ithlp2_pd + + use stats_variables, only: & + ithlp2_sf, & + ithlp2_forcing, & + ithlp2_mc, & + irtpthlp_bt, & + irtpthlp_ma, & + irtpthlp_ta, & + irtpthlp_tp1, & + irtpthlp_tp2, & + irtpthlp_dp1, & + irtpthlp_dp2, & + irtpthlp_cl, & + irtpthlp_sf, & + irtpthlp_forcing, & + irtpthlp_mc + + use stats_variables, only: & + iwpthlp_entermfl, & ! Variable(s) + iwpthlp_exit_mfl, & + iwpthlp_mfl_min, & + iwpthlp_mfl_max, & + iwprtp_enter_mfl, & + iwprtp_exit_mfl, & + iwprtp_mfl_min, & + iwprtp_mfl_max + + use stats_variables, only: & + iwm_zm, & ! Variable + icloud_frac_zm, & + iice_supersat_frac_zm, & + ircm_zm, & + irtm_zm, & + ithlm_zm + + use stats_variables, only: & + isclrprtp, & + isclrp2, & + isclrpthvp, & + isclrpthlp, & + isclrprcp, & + iwpsclrp, & + iwp2sclrp, & + iwpsclrp2, & + iwpsclrprtp, & + iwpsclrpthlp, & + iwpedsclrp + + use stats_variables, only: & + ia3_coef, & + iwp3_on_wp2, & + iSkw_velocity, & + igamma_Skw_fnc, & + iC6rt_Skw_fnc, & + iC6thl_Skw_fnc, & + iC7_Skw_fnc, & + iC1_Skw_fnc, & + ihydrometp2, & + iwphydrometp, & + irtphmp, & + ithlphmp + + use stats_variables, only: & + irtp2_from_chi + + use stats_type_utilities, only: & + stat_assign ! Procedure + + use parameters_model, only: & + hydromet_dim, & ! Variable(s) + sclr_dim, & + edsclr_dim + + use array_index, only: & + hydromet_list, & ! Variable(s) + l_mix_rat_hm + + implicit none + + ! External + intrinsic :: trim + + ! Input Variable + character(len= * ), dimension(nvarmax_zm), intent(in) :: vars_zm ! stats_zm variable names + + ! Input / Output Variable + logical, intent(inout) :: l_error + + ! Local Varables + integer :: tot_zm_loops + + integer :: hm_idx + + character(len=10) :: hm_type + + integer :: i, j, k + + logical :: l_found + + character(len=50) :: sclr_idx + + ! The default initialization for array indices for stats_zm is zero (see module + ! stats_variables) + + allocate( ihydrometp2(1:hydromet_dim) ) + allocate( iwphydrometp(1:hydromet_dim) ) + allocate( irtphmp(1:hydromet_dim) ) + allocate( ithlphmp(1:hydromet_dim) ) + allocate( iK_hm(1:hydromet_dim) ) + + ihydrometp2(:) = 0 + iwphydrometp(:) = 0 + irtphmp(:) = 0 + ithlphmp(:) = 0 + iK_hm(:) = 0 + + ! Allocate and then zero out passive scalar arrays on the stats_zm grid (fluxes, + ! variances and other high-order moments) + allocate(isclrprtp(1:sclr_dim)) + allocate(isclrp2(1:sclr_dim)) + allocate(isclrpthvp(1:sclr_dim)) + allocate(isclrpthlp(1:sclr_dim)) + allocate(isclrprcp(1:sclr_dim)) + allocate(iwpsclrp(1:sclr_dim)) + allocate(iwp2sclrp(1:sclr_dim)) + allocate(iwpsclrp2(1:sclr_dim)) + allocate(iwpsclrprtp(1:sclr_dim)) + allocate(iwpsclrpthlp(1:sclr_dim)) + + allocate(iwpedsclrp(1:edsclr_dim)) + + isclrprtp(:) = 0 + isclrp2(:) = 0 + isclrpthvp(:) = 0 + isclrpthlp(:) = 0 + isclrprcp(:) = 0 + iwpsclrp(:) = 0 + iwp2sclrp(:) = 0 + iwpsclrp2(:) = 0 + iwpsclrprtp(:) = 0 + iwpsclrpthlp(:) = 0 + + iwpedsclrp(:) = 0 + + ! Assign pointers for statistics variables stats_zm using stat_assign + + tot_zm_loops = stats_zm%num_output_fields + + if ( any( vars_zm == "hydrometp2" ) ) then + ! Correct for number of variables found under "hydrometp2". + ! Subtract 1 from the loop size for each hydrometeor. + tot_zm_loops = tot_zm_loops - hydromet_dim + ! Add 1 for "hydrometp2" to the loop size. + tot_zm_loops = tot_zm_loops + 1 + endif + + if ( any( vars_zm == "wphydrometp" ) ) then + ! Correct for number of variables found under "wphydrometp". + ! Subtract 1 from the loop size for each hydrometeor. + tot_zm_loops = tot_zm_loops - hydromet_dim + ! Add 1 for "wphydrometp" to the loop size. + tot_zm_loops = tot_zm_loops + 1 + endif + + if ( any( vars_zm == "rtphmp" ) ) then + ! Correct for number of variables found under "rtphmp". + ! Subtract 1 from the loop size for each hydrometeor. + tot_zm_loops = tot_zm_loops - hydromet_dim + ! Add 1 for "rtphmp" to the loop size. + tot_zm_loops = tot_zm_loops + 1 + endif + + if ( any( vars_zm == "thlphmp" ) ) then + ! Correct for number of variables found under "thlphmp". + ! Subtract 1 from the loop size for each hydrometeor. + tot_zm_loops = tot_zm_loops - hydromet_dim + ! Add 1 for "thlphmp" to the loop size. + tot_zm_loops = tot_zm_loops + 1 + endif + + if ( any( vars_zm == "K_hm" ) ) then + ! Correct for number of variables found under "K_hm". + ! Subtract 1 from the loop size for each hydrometeor. + tot_zm_loops = tot_zm_loops - hydromet_dim + ! Add 1 for "thlphmp" to the loop size. + tot_zm_loops = tot_zm_loops + 1 + endif + + k = 1 + + do i = 1, tot_zm_loops + + select case ( trim( vars_zm(i) ) ) + + case ('wp2') + iwp2 = k + call stat_assign( var_index=iwp2, var_name="wp2", & + var_description="w'^2, Variance of vertical air velocity [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('rtp2') + irtp2 = k + call stat_assign( var_index=irtp2, var_name="rtp2", & + var_description="rt'^2, Variance of rt [(kg/kg)^2]", var_units="(kg/kg)^2", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('thlp2') + ithlp2 = k + call stat_assign( var_index=ithlp2, var_name="thlp2", & + var_description="thl'^2, Variance of thl [K^2]", var_units="K^2", l_silhs=.false., & + grid_kind=stats_zm ) + k = k + 1 + + case ('rtpthlp') + irtpthlp = k + call stat_assign( var_index=irtpthlp, var_name="rtpthlp", & + var_description="rt'thl', Covariance of rt and thl [(kg K)/kg]", & + var_units="(kg K)/kg", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp') + iwprtp = k + + call stat_assign( var_index=iwprtp, var_name="wprtp", & + var_description="w'rt', Vertical turbulent flux of rt [(kg/kg) m/s]", & + var_units="(m kg)/(s kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp') + iwpthlp = k + + call stat_assign( var_index=iwpthlp, var_name="wpthlp", & + var_description="w'thl', Vertical turbulent flux of thl [K m/s]", & + var_units="(m K)/s", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wp3_zm') + iwp3_zm = k + call stat_assign( var_index=iwp3_zm, var_name="wp3_zm", & + var_description="w'^3 interpolated to moment. levels [m^3/s^3]", & + var_units="(m^3)/(s^3)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wp4') + iwp4 = k + call stat_assign( var_index=iwp4, var_name="wp4", var_description="w'^4 [m^4/s^4]", & + var_units="(m^4)/(s^4)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthvp') + iwpthvp = k + call stat_assign( var_index=iwpthvp, var_name="wpthvp", & + var_description="Buoyancy flux [K m/s]", var_units="K m/s", l_silhs=.false., & + grid_kind=stats_zm ) + k = k + 1 + + case ('rtpthvp') + irtpthvp = k + call stat_assign( var_index=irtpthvp, var_name="rtpthvp", & + var_description="rt'thv' [(kg/kg) K]", var_units="(kg/kg) K", l_silhs=.false., & + grid_kind=stats_zm ) + k = k + 1 + + case ('thlpthvp') + ithlpthvp = k + call stat_assign( var_index=ithlpthvp, var_name="thlpthvp", & + var_description="thl'thv' [K^2]", var_units="K^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('tau_zm') + itau_zm = k + + call stat_assign( var_index=itau_zm, var_name="tau_zm", & + var_description="Time-scale tau on momentum levels [s]", var_units="s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('Kh_zm') + iKh_zm = k + + call stat_assign( var_index=iKh_zm, var_name="Kh_zm", & + var_description="Eddy diffusivity on momentum levels [m^2/s]", var_units="m^2/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('K_hm') + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + iK_hm(hm_idx) = k + + + call stat_assign( var_index=iK_hm(hm_idx), & + var_name="K_hm_"//trim( hm_type(1:2) ), & + var_description="Eddy. diff. coef. of " & + // trim(hm_type(1:2)) & + // " [m^2/s]", & + var_units="[m^2/s]", & + l_silhs=.false., grid_kind=stats_zm ) + + k = k + 1 + + end do + + + case ('wprcp') + iwprcp = k + call stat_assign( var_index=iwprcp, var_name="wprcp", & + var_description="w' rc' [(m/s) (kg/kg)]", var_units="(m/s) (kg/kg)", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('rc_coef') + irc_coef = k + call stat_assign( var_index=irc_coef, var_name="rc_coef", & + var_description="Coefficient of X' R_l' in Eq. (34)", var_units="[-]", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('thlprcp') + ithlprcp = k + call stat_assign( var_index=ithlprcp, var_name="thlprcp", & + var_description="thl' rc' [K (kg/kg)]", var_units="K (kg/kg)", l_silhs=.false., & + grid_kind=stats_zm ) + k = k + 1 + + case ('rtprcp') + irtprcp = k + + call stat_assign( var_index=irtprcp, var_name="rtprcp", & + var_description="rt'rc' [(kg^2)/(kg^2)]", var_units="(kg^2)/(kg^2)", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('rcp2') + ircp2 = k + call stat_assign( var_index=ircp2, var_name="rcp2", & + var_description="rc'^2 [(kg^2)/(kg^2)]", var_units="(kg^2)/(kg^2)", l_silhs=.false., & + grid_kind=stats_zm ) + k = k + 1 + case ('upwp') + iupwp = k + call stat_assign( var_index=iupwp, var_name="upwp", & + var_description="u'w', Vertical east-west momentum flux [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('vpwp') + ivpwp = k + call stat_assign( var_index=ivpwp, var_name="vpwp", & + var_description="v'w', Vertical north-south momentum flux [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rho_zm') + irho_zm = k + call stat_assign( var_index=irho_zm, var_name="rho_zm", & + var_description="Density on momentum levels [kg/m^3]", var_units="kg m^{-3}", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('sigma_sqd_w') + isigma_sqd_w = k + call stat_assign( var_index=isigma_sqd_w, var_name="sigma_sqd_w", & + var_description="Nondimensionalized w variance of Gaussian component [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rho_ds_zm') + irho_ds_zm = k + call stat_assign( var_index=irho_ds_zm, var_name="rho_ds_zm", & + var_description="Dry, static, base-state density [kg/m^3]", var_units="kg m^{-3}", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('thv_ds_zm') + ithv_ds_zm = k + call stat_assign( var_index=ithv_ds_zm, var_name="thv_ds_zm", & + var_description="Dry, base-state theta_v [K]", var_units="K", l_silhs=.false., & + grid_kind=stats_zm ) + k = k + 1 + case ('em') + iem = k + call stat_assign( var_index=iem, var_name="em", & + var_description="Turbulent kinetic energy, usu. 0.5*(u'^2+v'^2+w'^2) [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('shear') ! Brian + ishear = k + call stat_assign( var_index=ishear, var_name="shear", & + var_description="Wind shear production term [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('mean_w_up') + imean_w_up = k + call stat_assign( var_index=imean_w_up, var_name="mean_w_up", & + var_description="Mean w >= w_ref [m/s]", var_units="m/s", l_silhs=.false., & + grid_kind=stats_zm ) + k = k + 1 + case ('mean_w_down') + imean_w_down = k + call stat_assign( var_index=imean_w_down, var_name="mean_w_down", & + var_description="Mean w <= w_ref [m/s]", var_units="m/s", l_silhs=.false., & + grid_kind=stats_zm ) + k = k + 1 + case ('Frad') + iFrad = k + call stat_assign( var_index=iFrad, var_name="Frad", & + var_description="Total (sw+lw) net (up+down) radiative flux [W/m^2]", & + var_units="W/m^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('Frad_LW') ! Brian + iFrad_LW = k + call stat_assign( var_index=iFrad_LW, var_name="Frad_LW", & + var_description="Net long-wave radiative flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('Frad_SW') ! Brian + iFrad_SW = k + + call stat_assign( var_index=iFrad_SW, var_name="Frad_SW", & + var_description="Net short-wave radiative flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('Frad_LW_up') ! Brian + iFrad_LW_up = k + call stat_assign( var_index=iFrad_LW_up, var_name="Frad_LW_up", & + var_description="Long-wave upwelling radiative flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('Frad_SW_up') ! Brian + iFrad_SW_up = k + + call stat_assign( var_index=iFrad_SW_up, var_name="Frad_SW_up", & + var_description="Short-wave upwelling radiative flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('Frad_LW_down') ! Brian + iFrad_LW_down = k + call stat_assign( var_index=iFrad_LW_down, var_name="Frad_LW_down", & + var_description="Long-wave downwelling radiative flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('Frad_SW_down') ! Brian + iFrad_SW_down = k + + call stat_assign( var_index=iFrad_SW_down, var_name="Frad_SW_down", & + var_description="Short-wave downwelling radiative flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + + case ('Fprec') ! Brian + iFprec = k + + call stat_assign( var_index=iFprec, var_name="Fprec", & + var_description="Rain flux [W/m^2]", var_units="W/m^2", l_silhs=.false., & + grid_kind=stats_zm ) + k = k + 1 + + case ('Fcsed') ! Brian + iFcsed = k + + call stat_assign( var_index=iFcsed, var_name="Fcsed", & + var_description="cloud water sedimentation flux [kg/(s*m^2)]", & + var_units="kg/(s*m^2)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case('hydrometp2') + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The overall variance of the hydrometeor. + ihydrometp2(hm_idx) = k + + if ( l_mix_rat_hm(hm_idx) ) then + + call stat_assign( var_index=ihydrometp2(hm_idx), & + var_name=trim( hm_type(1:2) )//"p2", & + var_description="<" & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // "'^2> [(kg/kg)^2]", & + var_units="(kg/kg)^2", & + l_silhs=.false., grid_kind=stats_zm ) + + else ! Concentration + + call stat_assign( var_index=ihydrometp2(hm_idx), & + var_name=trim( hm_type(1:2) )//"p2", & + var_description="<" & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // "'^2> [(num/kg)^2]", & + var_units="(num/kg)^2", & + l_silhs=.false., grid_kind=stats_zm ) + + endif ! l_mix_rat_hm(hm_idx) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ('wphydrometp') + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + iwphydrometp(hm_idx) = k + + if ( l_mix_rat_hm(hm_idx) ) then + + call stat_assign( var_index=iwphydrometp(hm_idx), & + var_name="wp"//trim( hm_type(1:2) )//"p", & + var_description="Covariance of w and " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " [(m/s) kg/kg]", & + var_units="(m/s) kg/kg", & + l_silhs=.false., grid_kind=stats_zm ) + + else ! Concentration + + call stat_assign( var_index=iwphydrometp(hm_idx), & + var_name="wp"//trim( hm_type(1:2) )//"p", & + var_description="Covariance of w and " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " [(m/s) num/kg]", & + var_units="(m/s) num/kg", & + l_silhs=.false., grid_kind=stats_zm ) + + endif ! l_mix_rat_hm(hm_idx) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ('wpNcp') + iwpNcp = k + + call stat_assign( var_index=iwpNcp, var_name="wpNcp", & + var_description="Covariance of w and " & + // "N_c [(m/s) num/kg]", & + var_units="(m/s) num/kg", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('rtphmp') + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + irtphmp(hm_idx) = k + + if ( l_mix_rat_hm(hm_idx) ) then + + call stat_assign( var_index=irtphmp(hm_idx), & + var_name="rtp"//trim( hm_type(1:2) )//"p", & + var_description="Covariance of r_t and " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " [kg^2/kg^2]", & + var_units="kg^2/kg^2", & + l_silhs=.false., grid_kind=stats_zm ) + + else ! Concentration + + call stat_assign( var_index=irtphmp(hm_idx), & + var_name="rtp"//trim( hm_type(1:2) )//"p", & + var_description="Covariance of r_t and " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " [(kg/kg) num/kg]", & + var_units="(kg/kg) num/kg", & + l_silhs=.false., grid_kind=stats_zm ) + + endif ! l_mix_rat_hm(hm_idx) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ('thlphmp') + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ithlphmp(hm_idx) = k + + if ( l_mix_rat_hm(hm_idx) ) then + + call stat_assign( var_index=ithlphmp(hm_idx), & + var_name="thlp"//trim( hm_type(1:2) )//"p", & + var_description="Covariance of th_l and " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " [K kg/kg]", & + var_units="K kg/kg", & + l_silhs=.false., grid_kind=stats_zm ) + + else ! Concentration + + call stat_assign( var_index=ithlphmp(hm_idx), & + var_name="thlp"//trim( hm_type(1:2) )//"p", & + var_description="Covariance of th_l and " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " [K num/kg]", & + var_units="K num/kg", & + l_silhs=.false., grid_kind=stats_zm ) + + endif ! l_mix_rat_hm(hm_idx) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ('VNr') + iVNr = k + + call stat_assign( var_index=iVNr, var_name="VNr", & + var_description="rrm concentration fallspeed [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('Vrr') + iVrr = k + + call stat_assign( var_index=iVrr, var_name="Vrr", & + var_description="rrm mixing ratio fallspeed [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('VNc') + iVNc = k + + call stat_assign( var_index=iVNc, var_name="VNc", & + var_description="Nrm concentration fallspeed [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('Vrc') + iVrc = k + + call stat_assign( var_index=iVrc, var_name="Vrc", & + var_description="Nrm mixing ratio fallspeed [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('VNs') + iVNs = k + + call stat_assign( var_index=iVNs, var_name="VNs", & + var_description="Snow concentration fallspeed [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('Vrs') + iVrs = k + + call stat_assign( var_index=iVrs, var_name="Vrs", & + var_description="Snow mixing ratio fallspeed [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('Vrg') + iVrg = k + + call stat_assign( var_index=iVrg, var_name="Vrg", & + var_description="Graupel sedimentation velocity [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('VNi') + iVNi = k + + call stat_assign( var_index=iVNi, var_name="VNi", & + var_description="Cloud ice concentration fallspeed [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('Vri') + iVri = k + + call stat_assign( var_index=iVri, var_name="Vri", & + var_description="Cloud ice mixing ratio fallspeed [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('Vrrprrp') + iVrrprrp = k + + call stat_assign( var_index=iVrrprrp, var_name="Vrrprrp", & + var_description="Covariance of V_rr (r_r sed. vel.) and r_r [(m/s)(kg/kg)]", & + var_units="(m/s)(kg/kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('VNrpNrp') + iVNrpNrp = k + + call stat_assign( var_index=iVNrpNrp, var_name="VNrpNrp", & + var_description="Covariance of V_Nr (N_r sed. vel.) and N_r [(m/s)(num/kg)]", & + var_units="(m/s)(num/kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('Vrrprrp_expcalc') + iVrrprrp_expcalc = k + + call stat_assign( var_index=iVrrprrp_expcalc, var_name="Vrrprrp_expcalc", & + var_description="< V_rr'r_r' > (completely explicit calculation) [(m/s)(kg/kg)]", & + var_units="(m/s)(kg/kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('VNrpNrp_expcalc') + iVNrpNrp_expcalc = k + + call stat_assign( var_index=iVNrpNrp_expcalc, var_name="VNrpNrp_expcalc", & + var_description="< V_Nr'N_r' > (completely explicit calculation) [(m/s)(num/kg)]", & + var_units="(m/s)(num/kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wp2_bt') + iwp2_bt = k + + call stat_assign( var_index=iwp2_bt, var_name="wp2_bt", & + var_description="wp2 budget: wp2 time tendency [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wp2_ma') + iwp2_ma = k + + call stat_assign( var_index=iwp2_ma, var_name="wp2_ma", & + var_description="wp2 budget: wp2 vertical mean advection [m^2/s^3]", & + var_units="m^2/s^3", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wp2_ta') + iwp2_ta = k + + call stat_assign( var_index=iwp2_ta, var_name="wp2_ta", & + var_description="wp2 budget: wp2 turbulent advection [m^2/s^3]", & + var_units="m^2/s^3", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wp2_ac') + iwp2_ac = k + + call stat_assign( var_index=iwp2_ac, var_name="wp2_ac", & + var_description="wp2 budget: wp2 accumulation term [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wp2_bp') + iwp2_bp = k + + call stat_assign( var_index=iwp2_bp, var_name="wp2_bp", & + var_description="wp2 budget: wp2 buoyancy production [m^2/s^3]", & + var_units="m^2/s^3", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wp2_pr1') + iwp2_pr1 = k + + call stat_assign( var_index=iwp2_pr1, var_name="wp2_pr1", & + var_description="wp2 budget: wp2 pressure term 1 [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wp2_pr2') + iwp2_pr2 = k + call stat_assign( var_index=iwp2_pr2, var_name="wp2_pr2", & + var_description="wp2 budget: wp2 pressure term 2 [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wp2_pr3') + iwp2_pr3 = k + call stat_assign( var_index=iwp2_pr3, var_name="wp2_pr3", & + var_description="wp2 budget: wp2 pressure term 3 [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + + k = k + 1 + + case ('wp2_dp1') + iwp2_dp1 = k + call stat_assign( var_index=iwp2_dp1, var_name="wp2_dp1", & + var_description="wp2 budget: wp2 dissipation term 1 [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wp2_dp2') + iwp2_dp2 = k + call stat_assign( var_index=iwp2_dp2, var_name="wp2_dp2", & + var_description="wp2 budget: wp2 dissipation term 2 [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + + k = k + 1 + + case ('wp2_cl') + iwp2_cl = k + + call stat_assign( var_index=iwp2_cl, var_name="wp2_cl", & + var_description="wp2 budget: wp2 clipping term [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + + k = k + 1 + + case ('wp2_pd') + iwp2_pd = k + + call stat_assign( var_index=iwp2_pd, var_name="wp2_pd", & + var_description="wp2 budget: wp2 positive definite adjustment [m^2/s^3]", & + var_units="m2/s3", l_silhs=.false., grid_kind=stats_zm ) + + k = k + 1 + + case ('wp2_sf') + iwp2_sf = k + + call stat_assign( var_index=iwp2_sf, var_name="wp2_sf", & + var_description="wp2 budget: wp2 surface variance [m^2/s^3]", var_units="m2/s3", & + l_silhs=.false., grid_kind=stats_zm ) + + k = k + 1 + + case ('wprtp_bt') + iwprtp_bt = k + call stat_assign( var_index=iwprtp_bt, var_name="wprtp_bt", & + var_description="wprtp budget: wprtp time tendency [(m kg)/(s^2 kg)]", & + var_units="(m kg)/(s^2 kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_ma') + iwprtp_ma = k + + call stat_assign( var_index=iwprtp_ma, var_name="wprtp_ma", & + var_description="wprtp budget: wprtp mean advection [(m kg)/(s^2 kg)]", & + var_units="(m kg)/(s^2 kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_ta') + iwprtp_ta = k + + call stat_assign( var_index=iwprtp_ta, var_name="wprtp_ta", & + var_description="wprtp budget: wprtp turbulent advection [(m kg)/(s^2 kg)]", & + var_units="(m kg)/(s^2 kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_tp') + iwprtp_tp = k + + call stat_assign( var_index=iwprtp_tp, var_name="wprtp_tp", & + var_description="wprtp budget: wprtp turbulent production [(m kg)/(s^2 kg)]", & + var_units="(m kg)/(s^2 kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_ac') + iwprtp_ac = k + + call stat_assign( var_index=iwprtp_ac, var_name="wprtp_ac", & + var_description="wprtp budget: wprtp accumulation term [(m kg)/(s^2 kg)]", & + var_units="(m kg)/(s^2 kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_bp') + iwprtp_bp = k + + call stat_assign( var_index=iwprtp_bp, var_name="wprtp_bp", & + var_description="wprtp budget: wprtp buoyancy production [(m kg)/(s^2 kg)]", & + var_units="(m kg)/(s^2 kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_pr1') + iwprtp_pr1 = k + + call stat_assign( var_index=iwprtp_pr1, var_name="wprtp_pr1", & + var_description="wprtp budget: wprtp pressure term 1 [(m kg)/(s^2 kg)]", & + var_units="(m kg)/(s^2 kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_pr2') + iwprtp_pr2 = k + + call stat_assign( var_index=iwprtp_pr2, var_name="wprtp_pr2", & + var_description="wprtp budget: wprtp pressure term 2 [(m kg)/(s^2 kg)]", & + var_units="(m kg)/(s^2 kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_pr3') + iwprtp_pr3 = k + + call stat_assign( var_index=iwprtp_pr3, var_name="wprtp_pr3", & + var_description="wprtp budget: wprtp pressure term 3 [(m kg)/(s^2 kg)]", & + var_units="(m kg)/(s^2 kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_dp1') + iwprtp_dp1 = k + + call stat_assign( var_index=iwprtp_dp1, var_name="wprtp_dp1", & + var_description="wprtp budget: wprtp dissipation term 1 [(m kg)/(s^2 kg)]", & + var_units="(m kg)/(s^2 kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_mfl') + iwprtp_mfl = k + + call stat_assign( var_index=iwprtp_mfl, var_name="wprtp_mfl", & + var_description="wprtp budget: wprtp monotonic flux limiter [(m kg)/(s^2 kg)]", & + var_units="(m kg)/(s^2 kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_cl') + iwprtp_cl = k + + call stat_assign( var_index=iwprtp_cl, var_name="wprtp_cl", & + var_description="wprtp budget: wprtp clipping term [(m kg)/(s^2 kg)]", & + var_units="(m kg)/(s^2 kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_sicl') + iwprtp_sicl = k + + call stat_assign( var_index=iwprtp_sicl, var_name="wprtp_sicl", & + var_description="wprtp budget: wprtp semi-implicit clipping term [(m kg)/(s^2 kg)]", & + var_units="(m kg)/(s^2 kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_pd') + iwprtp_pd = k + + call stat_assign( var_index=iwprtp_pd, var_name="wprtp_pd", & + var_description="wprtp budget: wprtp flux corrected trans. term [(m kg)/(s^2 kg)]", & + var_units="(m kg)/(s^2 kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_forcing') + iwprtp_forcing = k + + call stat_assign( var_index=iwprtp_forcing, var_name="wprtp_forcing", & + var_description="wprtp budget: wprtp forcing (includes microphysics tendency) & + &[(m kg/kg)/s^2]", & + var_units="(m kg/kg)/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_mc') + iwprtp_mc = k + + call stat_assign( var_index=iwprtp_mc, var_name="wprtp_mc", & + var_description="Microphysics tendency for wprtp (not in budget) [(m kg/kg)/s^2]", & + var_units="(m kg/kg)/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_bt') + iwpthlp_bt = k + + call stat_assign( var_index=iwpthlp_bt, var_name="wpthlp_bt", & + var_description="wpthlp budget: [(m K)/s^2]", var_units="(m K)/s^2", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_ma') + iwpthlp_ma = k + call stat_assign( var_index=iwpthlp_ma, var_name="wpthlp_ma", & + var_description="wpthlp budget: wpthlp mean advection [(m K)/s^2]", & + var_units="(m K)/s^2", l_silhs=.false., grid_kind=stats_zm ) + + k = k + 1 + + case ('wpthlp_ta') + iwpthlp_ta = k + call stat_assign( var_index=iwpthlp_ta, var_name="wpthlp_ta", & + var_description="wpthlp budget: wpthlp turbulent advection [(m K)/s^2]", & + var_units="(m K)/s^2", l_silhs=.false., grid_kind=stats_zm ) + + k = k + 1 + + case ('wpthlp_tp') + iwpthlp_tp = k + call stat_assign( var_index=iwpthlp_tp, var_name="wpthlp_tp", & + var_description="wpthlp budget: wpthlp turbulent production [(m K)/s^2]", & + var_units="(m K)/s^2", l_silhs=.false., grid_kind=stats_zm ) + + k = k + 1 + + case ('wpthlp_ac') + iwpthlp_ac = k + call stat_assign( var_index=iwpthlp_ac, var_name="wpthlp_ac", & + var_description="wpthlp budget: wpthlp accumulation term [(m K)/s^2]", & + var_units="(m K)/s^2", l_silhs=.false., grid_kind=stats_zm ) + + k = k + 1 + + case ('wpthlp_bp') + iwpthlp_bp = k + call stat_assign( var_index=iwpthlp_bp, var_name="wpthlp_bp", & + var_description="wpthlp budget: wpthlp buoyancy production [(m K)/s^2]", & + var_units="(m K)/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_pr1') + iwpthlp_pr1 = k + + call stat_assign( var_index=iwpthlp_pr1, var_name="wpthlp_pr1", & + var_description="wpthlp budget: wpthlp pressure term 1 [(m K)/s^2]", & + var_units="(m K)/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_pr2') + iwpthlp_pr2 = k + + call stat_assign( var_index=iwpthlp_pr2, var_name="wpthlp_pr2", & + var_description="wpthlp budget: wpthlp pressure term 2 [(m K)/s^2]", & + var_units="(m K)/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_pr3') + iwpthlp_pr3 = k + call stat_assign( var_index=iwpthlp_pr3, var_name="wpthlp_pr3", & + var_description="wpthlp budget: wpthlp pressure term 3 [(m K)/s^2]", & + var_units="(m K)/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_dp1') + iwpthlp_dp1 = k + call stat_assign( var_index=iwpthlp_dp1, var_name="wpthlp_dp1", & + var_description="wpthlp budget: wpthlp dissipation term 1 [(m K)/s^2]", & + var_units="(m K)/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_mfl') + iwpthlp_mfl = k + call stat_assign( var_index=iwpthlp_mfl, var_name="wpthlp_mfl", & + var_description="wpthlp budget: wpthlp monotonic flux limiter [(m K)/s^2]", & + var_units="(m K)/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_cl') + iwpthlp_cl = k + call stat_assign( var_index=iwpthlp_cl, var_name="wpthlp_cl", & + var_description="wpthlp budget: wpthlp clipping term [(m K)/s^2]", & + var_units="(m K)/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_sicl') + iwpthlp_sicl = k + call stat_assign( var_index=iwpthlp_sicl, var_name="wpthlp_sicl", & + var_description="wpthlp budget: wpthlp semi-implicit clipping term [(m K)/s^2]", & + var_units="(m K)/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_forcing') + iwpthlp_forcing = k + + call stat_assign( var_index=iwpthlp_forcing, var_name="wpthlp_forcing", & + var_description="wpthlp budget: wpthlp forcing (includes microphysics tendency) & + &[(m K)/s^2]", & + var_units="(m K)/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_mc') + iwpthlp_mc = k + + call stat_assign( var_index=iwpthlp_mc, var_name="wpthlp_mc", & + var_description="Microphysics tendency for wpthlp (not in budget) [(m K)/s^2]", & + var_units="(m K)/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + ! Variance budgets + case ('rtp2_bt') + irtp2_bt = k + call stat_assign( var_index=irtp2_bt, var_name="rtp2_bt", & + var_description="rtp2 budget: rtp2 time tendency [(kg^2)/(kg^2 s)]", & + var_units="(kg^2)/(kg^2 s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtp2_ma') + irtp2_ma = k + call stat_assign( var_index=irtp2_ma, var_name="rtp2_ma", & + var_description="rtp2 budget: rtp2 mean advection [(kg^2)/(kg^2 s)]", & + var_units="(kg^2)/(kg^2 s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtp2_ta') + irtp2_ta = k + call stat_assign( var_index=irtp2_ta, var_name="rtp2_ta", & + var_description="rtp2 budget: rtp2 turbulent advection [(kg^2)/(kg^2 s)]", & + var_units="(kg^2)/(kg^2 s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtp2_tp') + irtp2_tp = k + call stat_assign( var_index=irtp2_tp, var_name="rtp2_tp", & + var_description="rtp2 budget: rtp2 turbulent production [(kg^2)/(kg^2 s)]", & + var_units="(kg^2)/(kg^2 s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtp2_dp1') + irtp2_dp1 = k + call stat_assign( var_index=irtp2_dp1, var_name="rtp2_dp1", & + var_description="rtp2 budget: rtp2 dissipation term 1 [(kg^2)/(kg^2 s)]", & + var_units="(kg^2)/(kg^2 s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtp2_dp2') + irtp2_dp2 = k + call stat_assign( var_index=irtp2_dp2, var_name="rtp2_dp2", & + var_description="rtp2 budget: rtp2 dissipation term 2 [(kg^2)/(kg^2 s)]", & + var_units="(kg^2)/(kg^2 s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtp2_cl') + irtp2_cl = k + call stat_assign( var_index=irtp2_cl, var_name="rtp2_cl", & + var_description="rtp2 budget: rtp2 clipping term [(kg^2)/(kg^2 s)]", & + var_units="(kg^2)/(kg^2 s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('rtp2_pd') + irtp2_pd = k + call stat_assign( var_index=irtp2_pd, var_name="rtp2_pd", & + var_description="rtp2 budget: rtp2 positive definite adjustment [(kg^2)/(kg^2 s)]", & + var_units="(kg^2)/(kg^2 s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('rtp2_sf') + irtp2_sf = k + call stat_assign( var_index=irtp2_sf, var_name="rtp2_sf", & + var_description="rtp2 budget: rtp2 surface variance [(kg^2)/(kg^2 s)]", & + var_units="(kg^2)/(kg^2 s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('rtp2_forcing') + irtp2_forcing = k + + call stat_assign( var_index=irtp2_forcing, var_name="rtp2_forcing", & + var_description="rtp2 budget: rtp2 forcing (includes microphysics tendency) & + &[(kg/kg)^2/s]", & + var_units="(kg/kg)^2/s", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('rtp2_mc') + irtp2_mc = k + + call stat_assign( var_index=irtp2_mc, var_name="rtp2_mc", & + var_description="Microphysics tendency for rtp2 (not in budget) [(kg/kg)^2/s]", & + var_units="(kg/kg)^2/s", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('thlp2_bt') + ithlp2_bt = k + call stat_assign( var_index=ithlp2_bt, var_name="thlp2_bt", & + var_description="thlp2 budget: thlp2 time tendency [(K^2)/s]", var_units="(K^2)/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('thlp2_ma') + ithlp2_ma = k + call stat_assign( var_index=ithlp2_ma, var_name="thlp2_ma", & + var_description="thlp2 budget: thlp2 mean advection [(K^2)/s]", var_units="(K^2)/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('thlp2_ta') + ithlp2_ta = k + call stat_assign( var_index=ithlp2_ta, var_name="thlp2_ta", & + var_description="thlp2 budget: thlp2 turbulent advection [(K^2)/s]", & + var_units="(K^2)/s", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('thlp2_tp') + ithlp2_tp = k + call stat_assign( var_index=ithlp2_tp, var_name="thlp2_tp", & + var_description="thlp2 budget: thlp2 turbulent production [(K^2)/s]", & + var_units="(K^2)/s", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('thlp2_dp1') + ithlp2_dp1 = k + call stat_assign( var_index=ithlp2_dp1, var_name="thlp2_dp1", & + var_description="thlp2 budget: thlp2 dissipation term 1 [(K^2)/s]", & + var_units="(K^2)/s", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('thlp2_dp2') + ithlp2_dp2 = k + call stat_assign( var_index=ithlp2_dp2, var_name="thlp2_dp2", & + var_description="thlp2 budget: thlp2 dissipation term 2 [(K^2)/s]", & + var_units="(K^2)/s", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('thlp2_cl') + ithlp2_cl = k + call stat_assign( var_index=ithlp2_cl, var_name="thlp2_cl", & + var_description="thlp2 budget: thlp2 clipping term [(K^2)/s]", var_units="(K^2)/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('thlp2_pd') + ithlp2_pd = k + call stat_assign( var_index=ithlp2_pd, var_name="thlp2_pd", & + var_description="thlp2 budget: thlp2 positive definite adjustment [(K^2)/s]", & + var_units="K^2/s", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('thlp2_sf') + ithlp2_sf = k + call stat_assign( var_index=ithlp2_sf, var_name="thlp2_sf", & + var_description="thlp2 budget: thlp2 surface variance [(K^2)/s]", var_units="K^2/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('thlp2_forcing') + ithlp2_forcing = k + call stat_assign( var_index=ithlp2_forcing, var_name="thlp2_forcing", & + var_description="thlp2 budget: thlp2 forcing (includes microphysics tendency) & + &[K^2/s]", & + var_units="K^2/s", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('thlp2_mc') + ithlp2_mc = k + call stat_assign( var_index=ithlp2_mc, var_name="thlp2_mc", & + var_description="Microphysics tendency for thlp2 (not in budget) [K^2/s]", & + var_units="K^2/s", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('rtpthlp_bt') + irtpthlp_bt = k + call stat_assign( var_index=irtpthlp_bt, var_name="rtpthlp_bt", & + var_description="rtpthlp budget: rtpthlp time tendency [(kg K)/(kg s)]", & + var_units="(kg K)/(kg s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtpthlp_ma') + irtpthlp_ma = k + call stat_assign( var_index=irtpthlp_ma, var_name="rtpthlp_ma", & + var_description="rtpthlp budget: rtpthlp mean advection [(kg K)/(kg s)]", & + var_units="(kg K)/(kg s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtpthlp_ta') + irtpthlp_ta = k + call stat_assign( var_index=irtpthlp_ta, var_name="rtpthlp_ta", & + var_description="rtpthlp budget: rtpthlp turbulent advection [](kg K)/(kg s)", & + var_units="(kg K)/(kg s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtpthlp_tp1') + irtpthlp_tp1 = k + call stat_assign( var_index=irtpthlp_tp1, var_name="rtpthlp_tp1", & + var_description="rtpthlp budget: rtpthlp turbulent production 1 [(kg K)/(kg s)]", & + var_units="(kg K)/(kg s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtpthlp_tp2') + irtpthlp_tp2 = k + call stat_assign( var_index=irtpthlp_tp2, var_name="rtpthlp_tp2", & + var_description="rtpthlp budget: rtpthlp turbulent production 2 [(kg K)/(kg s)]", & + var_units="(kg K)/(kg s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtpthlp_dp1') + irtpthlp_dp1 = k + call stat_assign( var_index=irtpthlp_dp1, var_name="rtpthlp_dp1", & + var_description="rtpthlp budget: rtpthlp dissipation term 1 [(kg K)/(kg s)]", & + var_units="(kg K)/(kg s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtpthlp_dp2') + irtpthlp_dp2 = k + call stat_assign( var_index=irtpthlp_dp2, var_name="rtpthlp_dp2", & + var_description="rtpthlp budget: rtpthlp dissipation term 2 [(kg K)/(kg s)]", & + var_units="(kg K)/(kg s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtpthlp_cl') + irtpthlp_cl = k + call stat_assign( var_index=irtpthlp_cl, var_name="rtpthlp_cl", & + var_description="rtpthlp budget: rtpthlp clipping term [(kg K)/(kg s)]", & + var_units="(kg K)/(kg s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtpthlp_sf') + irtpthlp_sf = k + call stat_assign( var_index=irtpthlp_sf, var_name="rtpthlp_sf", & + var_description="rtpthlp budget: rtpthlp surface variance [(kg K)/(kg s)]", & + var_units="(kg K)/(kg s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtpthlp_forcing') + irtpthlp_forcing = k + call stat_assign( var_index=irtpthlp_forcing, var_name="rtpthlp_forcing", & + var_description="rtpthlp budget: rtpthlp forcing (includes microphysics tendency) & + &[(K kg/kg)/s]", & + var_units="(K kg/kg)/s", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtpthlp_mc') + irtpthlp_mc = k + call stat_assign( var_index=irtpthlp_mc, var_name="rtpthlp_mc", & + var_description="Microphysics tendency for rtpthlp (not in budget) [(K kg/kg)/s]", & + var_units="(K kg/kg)/s", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('up2') + iup2 = k + call stat_assign( var_index=iup2, var_name="up2", & + var_description="u'^2 (momentum levels) [m^2/s^2]", var_units="m^2/s^2", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('vp2') + ivp2 = k + call stat_assign( var_index=ivp2, var_name="vp2", & + var_description="v'^2 (momentum levels) [m^2/s^2]", var_units="m^2/s^2", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('up2_bt') + iup2_bt = k + call stat_assign( var_index=iup2_bt, var_name="up2_bt", & + var_description="up2 budget: up2 time tendency [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('up2_ma') + iup2_ma = k + call stat_assign( var_index=iup2_ma, var_name="up2_ma", & + var_description="up2 budget: up2 mean advection [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('up2_ta') + iup2_ta = k + call stat_assign( var_index=iup2_ta, var_name="up2_ta", & + var_description="up2 budget: up2 turbulent advection [m^2/s^3]", & + var_units="m^2/s^3", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('up2_tp') + iup2_tp = k + call stat_assign( var_index=iup2_tp, var_name="up2_tp", & + var_description="up2 budget: up2 turbulent production [m^2/s^3]", & + var_units="m^2/s^3", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('up2_dp1') + iup2_dp1 = k + call stat_assign( var_index=iup2_dp1, var_name="up2_dp1", & + var_description="up2 budget: up2 dissipation term 1 [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('up2_dp2') + iup2_dp2 = k + call stat_assign( var_index=iup2_dp2, var_name="up2_dp2", & + var_description="up2 budget: up2 dissipation term 2 [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('up2_pr1') + iup2_pr1 = k + call stat_assign( var_index=iup2_pr1, var_name="up2_pr1", & + var_description="up2 budget: up2 pressure term 1 [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('up2_pr2') + iup2_pr2 = k + call stat_assign( var_index=iup2_pr2, var_name="up2_pr2", & + var_description="up2 budget: up2 pressure term 2 [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('up2_cl') + iup2_cl = k + call stat_assign( var_index=iup2_cl, var_name="up2_cl", & + var_description="up2 budget: up2 clipping [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('up2_pd') + iup2_pd = k + call stat_assign( var_index=iup2_pd, var_name="up2_pd", & + var_description="up2 budget: up2 positive definite adjustment [m^2/s^3]", & + var_units="m^2/s^3", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('up2_sf') + iup2_sf = k + call stat_assign( var_index=iup2_sf, var_name="up2_sf", & + var_description="up2 budget: up2 surface variance [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('vp2_bt') + ivp2_bt = k + call stat_assign( var_index=ivp2_bt, var_name="vp2_bt", & + var_description="vp2 budget: vp2 time tendency [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('vp2_ma') + ivp2_ma = k + call stat_assign( var_index=ivp2_ma, var_name="vp2_ma", & + var_description="vp2 budget: vp2 mean advection [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('vp2_ta') + ivp2_ta = k + call stat_assign( var_index=ivp2_ta, var_name="vp2_ta", & + var_description="vp2 budget: vp2 turbulent advection [m^2/s^3]", & + var_units="m^2/s^3", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('vp2_tp') + ivp2_tp = k + call stat_assign( var_index=ivp2_tp, var_name="vp2_tp", & + var_description="vp2 budget: vp2 turbulent production [m^2/s^3]", & + var_units="m^2/s^3", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('vp2_dp1') + ivp2_dp1 = k + call stat_assign( var_index=ivp2_dp1, var_name="vp2_dp1", & + var_description="vp2 budget: vp2 dissipation term 1 [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('vp2_dp2') + ivp2_dp2 = k + call stat_assign( var_index=ivp2_dp2, var_name="vp2_dp2", & + var_description="vp2 budget: vp2 dissipation term 2 [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('vp2_pr1') + ivp2_pr1 = k + call stat_assign( var_index=ivp2_pr1, var_name="vp2_pr1", & + var_description="vp2 budget: vp2 pressure term 1 [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('vp2_pr2') + ivp2_pr2 = k + call stat_assign( var_index=ivp2_pr2, var_name="vp2_pr2", & + var_description="vp2 budget: vp2 pressure term 2 [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('vp2_cl') + ivp2_cl = k + call stat_assign( var_index=ivp2_cl, var_name="vp2_cl", & + var_description="vp2 budget: vp2 clipping [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('vp2_pd') + ivp2_pd = k + call stat_assign( var_index=ivp2_pd, var_name="vp2_pd", & + var_description="vp2 budget: vp2 positive definite adjustment [m^2/s^3]", & + var_units="m^2/s^3", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('vp2_sf') + ivp2_sf = k + call stat_assign( var_index=ivp2_sf, var_name="vp2_sf", & + var_description="vp2 budget: vp2 surface variance [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_entermfl') + iwpthlp_entermfl = k + call stat_assign( var_index=iwpthlp_entermfl, var_name="wpthlp_entermfl", & + var_description="Wpthlp entering flux limiter [(m K)/s]", var_units="(m K)/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_exit_mfl') + iwpthlp_exit_mfl = k + call stat_assign( var_index=iwpthlp_exit_mfl, var_name="wpthlp_exit_mfl", & + var_description="Wpthlp exiting flux limiter [](m K)/s", var_units="(m K)/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_mfl_min') + iwpthlp_mfl_min = k + call stat_assign( var_index=iwpthlp_mfl_min, var_name="wpthlp_mfl_min", & + var_description="Minimum allowable wpthlp [(m K)/s]", var_units="(m K)/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_mfl_max') + iwpthlp_mfl_max = k + call stat_assign( var_index=iwpthlp_mfl_max, var_name="wpthlp_mfl_max", & + var_description="Maximum allowable wpthlp ((m K)/s) [(m K)/s]", var_units="(m K)/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_mfl_min') + iwprtp_mfl_min = k + call stat_assign( var_index=iwprtp_mfl_min, var_name="wprtp_mfl_min", & + var_description="Minimum allowable wprtp [(m kg)/(s kg)]", & + var_units="(m kg)/(s kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_mfl_max') + iwprtp_mfl_max = k + call stat_assign( var_index=iwprtp_mfl_max, var_name="wprtp_mfl_max", & + var_description="Maximum allowable wprtp [(m kg)/(s kg)]", & + var_units="(m kg)/(s kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_enter_mfl') + iwprtp_enter_mfl = k + call stat_assign( var_index=iwprtp_enter_mfl, var_name="wprtp_enter_mfl", & + var_description="Wprtp entering flux limiter [(m kg)/(s kg)]", & + var_units="(m kg)/(s kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_exit_mfl') + iwprtp_exit_mfl = k + call stat_assign( var_index=iwprtp_exit_mfl, var_name="wprtp_exit_mfl", & + var_description="Wprtp exiting flux limiter [(m kg)/(s kg)]", & + var_units="(m kg)/(s kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wm_zm') + iwm_zm = k + call stat_assign( var_index=iwm_zm, var_name="wm_zm", & + var_description="Vertical (w) wind [m/s]", var_units="m/s", l_silhs=.false., & + grid_kind=stats_zm ) + k = k + 1 + + case ('cloud_frac_zm') + icloud_frac_zm = k + call stat_assign( var_index=icloud_frac_zm, var_name="cloud_frac_zm", & + var_description="Cloud fraction", var_units="count", l_silhs=.false., grid_kind=stats_zm) + k = k + 1 + + case ('ice_supersat_frac_zm') + iice_supersat_frac_zm = k + call stat_assign( var_index=iice_supersat_frac_zm, var_name="ice_supersat_frac_zm", & + var_description="Ice cloud fraction", var_units="count", l_silhs=.false., & + grid_kind=stats_zm ) + k = k + 1 + + case ('rcm_zm') + ircm_zm = k + call stat_assign( var_index=ircm_zm, var_name="rcm_zm", & + var_description="Total water mixing ratio [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('rtm_zm') + irtm_zm = k + call stat_assign( var_index=irtm_zm, var_name="rtm_zm", & + var_description="Total water mixing ratio [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('thlm_zm') + ithlm_zm = k + call stat_assign( var_index=ithlm_zm, var_name="thlm_zm", & + var_description="Liquid potential temperature [K]", var_units="K", l_silhs=.false., & + grid_kind=stats_zm ) + k = k + 1 + + case ( 'Skw_velocity' ) + iSkw_velocity = k + call stat_assign( var_index=iSkw_velocity, var_name="Skw_velocity", & + var_description="Skewness velocity [m/s]", var_units="m/s", l_silhs=.false., & + grid_kind=stats_zm ) + k = k + 1 + + case ( 'gamma_Skw_fnc' ) + igamma_Skw_fnc = k + call stat_assign( var_index=igamma_Skw_fnc, var_name="gamma_Skw_fnc", & + var_description="Gamma as a function of skewness [-]", var_units="count", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ( 'C6rt_Skw_fnc' ) + iC6rt_Skw_fnc = k + call stat_assign( var_index=iC6rt_Skw_fnc, var_name="C6rt_Skw_fnc", & + var_description="C_6rt parameter with Sk_w applied [-]", var_units="count", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ( 'C6thl_Skw_fnc' ) + iC6thl_Skw_fnc = k + call stat_assign( var_index=iC6thl_Skw_fnc, var_name="C6thl_Skw_fnc", & + var_description="C_6thl parameter with Sk_w applied [-]", var_units="count", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ( 'C7_Skw_fnc' ) + iC7_Skw_fnc = k + call stat_assign( var_index=iC7_Skw_fnc, var_name="C7_Skw_fnc", & + var_description="C_7 parameter with Sk_w applied [-]", var_units="count", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ( 'C1_Skw_fnc' ) + iC1_Skw_fnc = k + call stat_assign( var_index=iC1_Skw_fnc, var_name="C1_Skw_fnc", & + var_description="C_1 parameter with Sk_w applied [-]", var_units="count", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ( 'a3_coef' ) + ia3_coef = k + call stat_assign( var_index=ia3_coef, var_name="a3_coef", & + var_description="Quantity in formula 25 from Equations for CLUBB [-]", & + var_units="count", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ( 'wp3_on_wp2' ) + iwp3_on_wp2 = k + call stat_assign( var_index=iwp3_on_wp2, var_name="wp3_on_wp2", & + var_description="Smoothed version of wp3 / wp2 [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ( 'Skw_zm' ) + iSkw_zm = k + call stat_assign( var_index=iSkw_zm, var_name="Skw_zm", & + var_description="Skewness of w on momentum levels [-]", var_units="-", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ( 'stability_correction' ) + istability_correction = k + call stat_assign( var_index=istability_correction, var_name="stability_correction", & + var_description="Stability applied to diffusion of rtm and thlm [-]", var_units="-", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ( 'rtp2_from_chi' ) + irtp2_from_chi = k + call stat_assign( var_index=irtp2_from_chi, var_name="rtp2_from_chi", & + var_description="Variance of rt, computed from the chi/eta distribution [(kg/kg)^2]", & + var_units="(kg/kg)^2", l_silhs=.false., grid_kind=stats_zm ) + + case default + l_found = .false. + + j = 1 + + do while( j <= sclr_dim .and. .not. l_found ) + write( sclr_idx, * ) j + sclr_idx = adjustl(sclr_idx) + + if( trim(vars_zm(i)) == 'sclr'//trim(sclr_idx)//'prtp'.and. .not. l_found ) then + isclrprtp(j) = k + + call stat_assign( var_index=isclrprtp(j), var_name="sclr"//trim(sclr_idx)//"prtp", & + var_description="scalar("//trim(sclr_idx)//")'rt'", var_units="unknown", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + l_found = .true. + end if + if( trim(vars_zm(i)) == 'sclr'//trim(sclr_idx)//'p2'.and. .not. l_found ) then + isclrp2(j) = k + call stat_assign( var_index=isclrp2(j), var_name="sclr"//trim(sclr_idx)//"p2", & + var_description="scalar("//trim(sclr_idx)//")'^2'", var_units="unknown", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + l_found = .true. + end if + if( trim(vars_zm(i)) == 'sclr'//trim(sclr_idx)//'pthvp'.and. .not. l_found ) then + isclrpthvp(j) = k + call stat_assign( var_index=isclrpthvp(j), var_name="sclr"//trim(sclr_idx)//"pthvp", & + var_description="scalar("//trim(sclr_idx)//")'th_v'", var_units="unknown", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + l_found = .true. + end if + if( trim(vars_zm(i)) == 'sclr'//trim(sclr_idx)//'pthlp'.and. .not. l_found ) then + isclrpthlp(j) = k + + call stat_assign( var_index=isclrpthlp(j), var_name="sclr"//trim(sclr_idx)//"pthlp", & + var_description="scalar("//trim(sclr_idx)//")'th_l'", var_units="unknown", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + l_found = .true. + end if + if( trim(vars_zm(i)) == 'sclr'//trim(sclr_idx)//'prcp'.and. .not. l_found ) then + + isclrprcp(j) = k + + call stat_assign( var_index=isclrprcp(j), var_name="sclr"//trim(sclr_idx)//"prcp", & + var_description="scalar("//trim(sclr_idx)//")'rc'", var_units="unknown", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + l_found = .true. + end if + if( trim(vars_zm(i)) == 'wpsclr'//trim(sclr_idx)//'p'.and. .not. l_found ) then + iwpsclrp(j) = k + + call stat_assign( var_index=iwpsclrp(j), var_name="wpsclr"//trim(sclr_idx)//"p", & + var_description="'w'scalar("//trim(sclr_idx)//")", var_units="unknown", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + l_found = .true. + end if + if( trim(vars_zm(i)) == 'wpsclr'//trim(sclr_idx)//'p2'.and. .not. l_found ) then + + iwpsclrp2(j) = k + + call stat_assign( var_index=iwpsclrp2(j), var_name="wpsclr"//trim(sclr_idx)//"p2", & + var_description="'w'scalar("//trim(sclr_idx)//")'^2'", var_units="unknown", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + l_found = .true. + end if + if( trim(vars_zm(i)) == 'wp2sclr'//trim(sclr_idx)//'p'.and. .not. l_found ) then + + iwp2sclrp(j) = k + + call stat_assign( var_index=iwp2sclrp(j), var_name="wp2sclr"//trim(sclr_idx)//"p", & + var_description="'w'^2 scalar("//trim(sclr_idx)//")", var_units="unknown", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + l_found = .true. + end if + if( trim(vars_zm(i)) == 'wpsclr'//trim(sclr_idx)//'prtp'.and. .not. l_found ) then + iwpsclrprtp(j) = k + + call stat_assign( var_index=iwpsclrprtp(j), var_name="wpsclr"//trim(sclr_idx)//"prtp", & + var_description="'w' scalar("//trim(sclr_idx)//")'rt'", var_units="unknown", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + l_found = .true. + end if + if( trim(vars_zm(i)) == 'wpsclr'//trim(sclr_idx)//'pthlp'.and. .not. l_found ) then + iwpsclrpthlp(j) = k + + call stat_assign( var_index=iwpsclrpthlp(j), var_name="wpsclr"//trim(sclr_idx)//"pthlp", & + var_description="'w' scalar("//trim(sclr_idx)//")'th_l'", var_units="unknown", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + l_found = .true. + end if + j = j + 1 + end do + + j = 1 + + do while( j <= edsclr_dim .and. .not. l_found ) + + write( sclr_idx, * ) j + sclr_idx = adjustl(sclr_idx) + + if( trim(vars_zm(i)) == 'wpedsclr'//trim(sclr_idx)//'p'.and. .not. l_found ) then + iwpedsclrp(j) = k + + call stat_assign( var_index=iwpedsclrp(j), var_name="wpedsclr"//trim(sclr_idx)//"p", & + var_description="eddy scalar("//trim(sclr_idx)//")'w'", var_units="unknown", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + l_found = .true. + end if + + j = j + 1 + + end do + + if ( .not. l_found ) then + write(fstderr,*) 'Error: unrecognized variable in vars_zm: ', trim(vars_zm(i)) + l_error = .true. ! This will stop the run. + end if + + end select + + end do ! i = 1 .. stats_zm%num_output_fields + + return + end subroutine stats_init_zm + +end module stats_zm_module diff --git a/models/atm/cam/src/physics/clubb/stats_zt.F90 b/models/atm/cam/src/physics/clubb/stats_zt.F90 deleted file mode 100644 index ae92a3ea45ff..000000000000 --- a/models/atm/cam/src/physics/clubb/stats_zt.F90 +++ /dev/null @@ -1,2654 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: stats_zt.F90 5633 2012-01-19 01:00:48Z vondeyle@uwm.edu $ - -module stats_zt - - implicit none - - private ! Default Scope - - public :: stats_init_zt - -! Constant parameters - integer, parameter, public :: nvarmax_zt = 300 ! Maximum variables allowed - - contains - -!----------------------------------------------------------------------- - subroutine stats_init_zt( vars_zt, l_error ) - -! Description: -! Initializes array indices for zt - -! Note: -! All code that is within subroutine stats_init_zt, including variable -! allocation code, is not called if l_stats is false. This subroutine is -! called only when l_stats is true. - -!----------------------------------------------------------------------- - - use constants_clubb, only: & - fstderr ! Constant(s) - - use stats_variables, only: & - ithlm, & ! Variable(s) - iT_in_K, & - ithvm, & - irtm, & - ircm, & - irvm, & - ium, & - ivm, & - iwm_zt, & - ium_ref, & - ivm_ref, & - iug, & - ivg, & - icloud_frac, & - ircm_in_layer, & - ircm_in_cloud, & - icloud_cover, & - ip_in_Pa, & - iexner, & - irho_ds_zt, & - ithv_ds_zt, & - iLscale, & - iwp3, & - iwpthlp2, & - iwp2thlp, & - iwprtp2, & - iwp2rtp, & - iLscale_up, & - iLscale_down, & - itau_zt, & - iKh_zt, & - iwp2thvp, & - iwp2rcp, & - iwprtpthlp, & - isigma_sqd_w_zt - - use stats_variables, only: & - irel_humidity, & - irho, & - iNcm, & - iNcm_in_cloud, & - iNc_activated, & - iNcnm, & - isnowslope, & - ised_rcm, & - irsat, & - irsati, & - irrainm, & - iNrm, & - irain_rate_zt, & - iAKm, & - iLH_AKm, & - iAKstd, & - iAKstd_cld, & - iAKm_rcm, & - iAKm_rcc, & - iradht, & - iradht_LW, & - iradht_SW, & - idiam, & - imass_ice_cryst, & - ircm_icedfs, & - iu_T_cm, & - im_vol_rad_rain, & - im_vol_rad_cloud, & - irsnowm, & - irgraupelm, & - iricem - - use stats_variables, only: & - ieff_rad_cloud, & - ieff_rad_ice, & - ieff_rad_snow, & - ieff_rad_rain, & - ieff_rad_graupel - - use stats_variables, only: & - irtm_bt, & - irtm_ma, & - irtm_ta, & - irtm_forcing, & - irtm_mc, & - irtm_sdmp, & - ircm_mc, & - ircm_sd_mg_morr, & - irvm_mc, & - irtm_mfl, & - irtm_tacl, & - irtm_cl, & - irtm_pd, & - ithlm_bt, & - ithlm_ma, & - ithlm_ta, & - ithlm_forcing, & - ithlm_mc, & - ithlm_sdmp, & - ithlm_mfl, & - ithlm_tacl, & - ithlm_cl, & - iwp3_bt, & - iwp3_ma, & - iwp3_ta, & - iwp3_tp, & - iwp3_ac, & - iwp3_bp1, & - iwp3_bp2, & - iwp3_pr1, & - iwp3_pr2, & - iwp3_dp1, & - iwp3_4hd, & - iwp3_cl - - ! Monotonic flux limiter diagnostic variables - use stats_variables, only: & - ithlm_mfl_min, & - ithlm_mfl_max, & - irtm_mfl_min, & - irtm_mfl_max, & - ithlm_enter_mfl, & - ithlm_exit_mfl, & - ithlm_old, & - ithlm_without_ta, & - irtm_enter_mfl, & - irtm_exit_mfl, & - irtm_old, & - irtm_without_ta - - use stats_variables, only: & - irrainm_bt, & - irrainm_ma, & - irrainm_sd, & - irrainm_sd_morr, & - irrainm_dff, & - irrainm_cond, & - irrainm_auto, & - irrainm_accr, & - irrainm_cond_adj, & - irrainm_src_adj, & - irrainm_mc, & - irrainm_cl, & - iNrm_bt, & - iNrm_ma, & - iNrm_sd, & - iNrm_dff, & - iNrm_cond, & - iNrm_auto, & - iNrm_cond_adj, & - iNrm_src_adj, & - iNrm_mc, & - iNrm_cl, & - irsnowm_bt, & - irsnowm_ma, & - irsnowm_sd, & - irsnowm_sd_morr, & - irsnowm_dff - - use stats_variables, only: & - irsnowm_mc, & - irsnowm_cl, & - irgraupelm_bt, & - irgraupelm_ma, & - irgraupelm_sd, & - irgraupelm_sd_morr, & - irgraupelm_dff, & - irgraupelm_mc, & - irgraupelm_cl, & - iricem_bt, & - iricem_ma, & - iricem_sd, & - iricem_sd_mg_morr, & - iricem_dff, & - iricem_mc, & - iricem_cl, & - ivm_bt, & - ivm_ma, & - ivm_gf, & - ivm_cf, & - ivm_ta, & - ivm_f, & - ivm_sdmp, & - ivm_ndg, & - ium_bt, & - ium_ma, & - ium_gf, & - ium_cf, & - ium_ta, & - ium_f, & - ium_sdmp, & - ium_ndg - - use stats_variables, only: & - imixt_frac, & ! Variable(s) - iw1, & - iw2, & - ivarnce_w1, & - ivarnce_w2, & - ithl1, & - ithl2, & - ivarnce_thl1, & - ivarnce_thl2, & - irt1, & - irt2, & - ivarnce_rt1, & - ivarnce_rt2, & - irc1, & - irc2, & - irsl1, & - irsl2, & - icloud_frac1, & - icloud_frac2, & - is1, & - is2, & - istdev_s1, & - istdev_s2, & - irrtthl, & - iwp2_zt, & - ithlp2_zt, & - iwpthlp_zt, & - iwprtp_zt, & - irtp2_zt, & - irtpthlp_zt, & - iup2_zt, & - ivp2_zt, & - iupwp_zt, & - ivpwp_zt - - use stats_variables, only: & - zt, & - isclrm, & - isclrm_f, & - iedsclrm, & - iedsclrm_f - - use stats_variables, only: & - iNsnowm, & ! Variable(s) - iNrm, & - iNgraupelm, & - iNim, & - iNsnowm_bt, & - iNsnowm_mc, & - iNsnowm_ma, & - iNsnowm_dff, & - iNsnowm_sd, & - iNsnowm_cl, & - iNgraupelm_bt, & - iNgraupelm_mc, & - iNgraupelm_ma, & - iNgraupelm_dff, & - iNgraupelm_sd, & - iNgraupelm_cl, & - iNim_bt, & - iNim_mc, & - iNim_ma, & - iNim_dff, & - iNim_sd, & - iNim_cl - - use stats_variables, only: & - iNcm_bt, & - iNcm_mc, & - iNcm_ma, & - iNcm_dff, & - iNcm_cl, & - iNcm_act - - use stats_variables, only: & - ieff_rad_cloud, & - ieff_rad_ice, & - ieff_rad_snow, & - ieff_rad_rain, & - ieff_rad_graupel - - use stats_variables, only: & - iLH_thlm_mc, & ! Variable(s) - iLH_rvm_mc, & - iLH_rcm_mc, & - iLH_Ncm_mc, & - iLH_rrainm_mc, & - iLH_Nrm_mc, & - iLH_rsnowm_mc, & - iLH_Nsnowm_mc, & - iLH_rgraupelm_mc, & - iLH_Ngraupelm_mc, & - iLH_ricem_mc, & - iLH_Nim_mc, & - iLH_Vrr, & - iLH_VNr - - use stats_variables, only: & - iLH_rcm_avg - - use stats_variables, only: & - iLH_rrainm, & ! Variable(s) - iLH_Nrm, & - iLH_ricem, & - iLH_Nim, & - iLH_rsnowm, & - iLH_Nsnowm, & - iLH_rgraupelm, & - iLH_Ngraupelm, & - iLH_thlm, & - iLH_rcm, & - iLH_Ncm, & - iLH_rvm, & - iLH_wm, & - iLH_wp2_zt, & - iLH_rcp2_zt, & - iLH_rtp2_zt, & - iLH_thlp2_zt, & - iLH_rrainp2_zt, & - iLH_Nrp2_zt, & - iLH_Ncp2_zt, & - iLH_cloud_frac - - use stats_variables, only: & - iC11_Skw_fnc, & ! Variable(s) - is_mellor, & - iwp3_on_wp2_zt, & - ia3_coef_zt - - - use stats_type, only: & - stat_assign ! Procedure - - use parameters_model, only: & - sclr_dim,& - edsclr_dim -!use error_code, only: & -! clubb_at_least_debug_level ! Function - - - implicit none - - ! Input Variable - character(len= * ), dimension(nvarmax_zt), intent(in) :: vars_zt - - ! Output Variable - logical, intent(inout) :: l_error - -! Local Varables - integer :: i, j, k - - logical :: l_found - - character(len=50) :: sclr_idx - -! Default initialization for array indices for zt - - ithlm = 0 - iT_in_K = 0 - ithvm = 0 - irtm = 0 - ircm = 0 - irvm = 0 - ium = 0 - ivm = 0 - iwm_zt = 0 - ium_ref = 0 - ivm_ref = 0 - iug = 0 - ivg = 0 - icloud_frac = 0 - ircm_in_layer = 0 - ircm_in_cloud = 0 - icloud_cover = 0 - ip_in_Pa = 0 - iexner = 0 - irho_ds_zt = 0 - ithv_ds_zt = 0 - iLscale = 0 - iwp3 = 0 - iwpthlp2 = 0 - iwp2thlp = 0 - iwprtp2 = 0 - iwp2rtp = 0 - iLscale_up = 0 - iLscale_down = 0 - itau_zt = 0 - iKh_zt = 0 - iwp2thvp = 0 - iwp2rcp = 0 - iwprtpthlp = 0 - isigma_sqd_w_zt = 0 - irho = 0 - irel_humidity = 0 - iNcm = 0 ! Brian - iNcm_in_cloud = 0 - iNc_activated = 0 - iNcnm = 0 - iNim = 0 - isnowslope = 0 ! Adam Smith, 22 April 2008 - ised_rcm = 0 ! Brian - irsat = 0 ! Brian - irrainm = 0 ! Brian - irain_rate_zt = 0 ! Brian - iAKm = 0 ! analytic Kessler. Vince Larson 22 May 2005 - iLH_AKm = 0 ! LH Kessler. Vince Larson 22 May 2005 - iAKstd = 0 - iAKstd_cld = 0 - iAKm_rcm = 0 - iAKm_rcc = 0 - iradht = 0 - iradht_LW = 0 - iradht_SW = 0 - -! Number concentrations - iNsnowm = 0 ! Adam Smith, 22 April 2008 - iNrm = 0 ! Brian - iNgraupelm = 0 - iNim = 0 - - idiam = 0 - imass_ice_cryst = 0 - ircm_icedfs = 0 - iu_T_cm = 0 - -! From K&K microphysics - im_vol_rad_rain = 0 ! Brian - im_vol_rad_cloud = 0 - -! From Morrison microphysics - ieff_rad_cloud = 0 - ieff_rad_ice = 0 - ieff_rad_snow = 0 - ieff_rad_rain = 0 - ieff_rad_graupel = 0 - - irsnowm = 0 - irgraupelm = 0 - iricem = 0 - - irtm_bt = 0 - irtm_ma = 0 - irtm_ta = 0 - irtm_forcing = 0 - irtm_sdmp = 0 - irtm_mc = 0 - ircm_mc = 0 ! For the change due to COAMPS/Morrison microphysics - ircm_sd_mg_morr = 0 - irvm_mc = 0 ! For the change due to COAMPS/Morrison microphysics - irtm_mfl = 0 - irtm_tacl = 0 - irtm_cl = 0 ! Josh - irtm_pd = 0 - ithlm_bt = 0 - ithlm_ma = 0 - ithlm_ta = 0 - ithlm_forcing = 0 - ithlm_mc = 0 - ithlm_sdmp = 0 - ithlm_mfl = 0 - ithlm_tacl = 0 - ithlm_cl = 0 ! Josh - - ithlm_mfl_min = 0 - ithlm_mfl_max = 0 - irtm_mfl_min = 0 - irtm_mfl_max = 0 - ithlm_enter_mfl = 0 - ithlm_exit_mfl = 0 - ithlm_old = 0 - ithlm_without_ta = 0 - irtm_enter_mfl = 0 - irtm_exit_mfl = 0 - irtm_old = 0 - irtm_without_ta = 0 - - iwp3_bt = 0 - iwp3_ma = 0 - iwp3_ta = 0 - iwp3_tp = 0 - iwp3_ac = 0 - iwp3_bp1 = 0 - iwp3_bp2 = 0 - iwp3_pr1 = 0 - iwp3_pr2 = 0 - iwp3_dp1 = 0 - iwp3_4hd = 0 - iwp3_cl = 0 - - irrainm_bt = 0 - irrainm_ma = 0 - irrainm_sd = 0 - irrainm_sd_morr = 0 - irrainm_dff = 0 - irrainm_cond = 0 - irrainm_auto = 0 - irrainm_accr = 0 - irrainm_cond_adj = 0 - irrainm_src_adj = 0 - irrainm_mc = 0 - irrainm_cl = 0 - - iNrm_bt = 0 - iNrm_ma = 0 - iNrm_sd = 0 - iNrm_dff = 0 - iNrm_cond = 0 - iNrm_auto = 0 - iNrm_cond_adj = 0 - iNrm_src_adj = 0 - iNrm_mc = 0 - iNrm_cl = 0 - - iNsnowm_bt = 0 - iNsnowm_ma = 0 - iNsnowm_sd = 0 - iNsnowm_dff = 0 - iNsnowm_mc = 0 - iNsnowm_cl = 0 - - iNim_bt = 0 - iNim_ma = 0 - iNim_sd = 0 - iNim_dff = 0 - iNim_mc = 0 - iNim_cl = 0 - - iNcm_bt = 0 - iNcm_ma = 0 - iNcm_dff = 0 - iNcm_mc = 0 - iNcm_cl = 0 - iNcm_act = 0 - - irsnowm_bt = 0 - irsnowm_ma = 0 - irsnowm_sd = 0 - irsnowm_sd_morr = 0 - irsnowm_dff = 0 - irsnowm_mc = 0 - irsnowm_cl = 0 - - irgraupelm_bt = 0 - irgraupelm_ma = 0 - irgraupelm_sd = 0 - irgraupelm_sd_morr = 0 - irgraupelm_dff = 0 - irgraupelm_mc = 0 - irgraupelm_cl = 0 - - iricem_bt = 0 - iricem_ma = 0 - iricem_sd = 0 - iricem_sd_mg_morr = 0 - iricem_dff = 0 - iricem_mc = 0 - iricem_cl = 0 - - ivm_bt = 0 - ivm_ma = 0 - ivm_gf = 0 - ivm_cf = 0 - ivm_ta = 0 - ivm_f = 0 - ivm_sdmp = 0 - ivm_ndg = 0 - - ium_bt = 0 - ium_ma = 0 - ium_gf = 0 - ium_cf = 0 - ium_ta = 0 - ium_f = 0 - ium_sdmp = 0 - ium_ndg = 0 - - imixt_frac = 0 - iw1 = 0 - iw2 = 0 - ivarnce_w1 = 0 - ivarnce_w2 = 0 - ithl1 = 0 - ithl2 = 0 - ivarnce_thl1 = 0 - ivarnce_thl2 = 0 - irt1 = 0 - irt2 = 0 - ivarnce_rt1 = 0 - ivarnce_rt2 = 0 - irc1 = 0 - irc2 = 0 - irsl1 = 0 - irsl2 = 0 - icloud_frac1 = 0 - icloud_frac2 = 0 - is1 = 0 - is2 = 0 - istdev_s1 = 0 - istdev_s2 = 0 - irrtthl = 0 - - is_mellor = 0 - - iwp2_zt = 0 - ithlp2_zt = 0 - iwpthlp_zt = 0 - iwprtp_zt = 0 - irtp2_zt = 0 - irtpthlp_zt = 0 - iup2_zt = 0 - ivp2_zt = 0 - iupwp_zt = 0 - ivpwp_zt = 0 - - iLH_thlm_mc = 0 - iLH_rvm_mc = 0 - iLH_rcm_mc = 0 - iLH_Ncm_mc = 0 - iLH_rrainm_mc = 0 - iLH_Nrm_mc = 0 - iLH_rsnowm_mc = 0 - iLH_Nsnowm_mc = 0 - iLH_rgraupelm_mc = 0 - iLH_Ngraupelm_mc = 0 - iLH_ricem_mc = 0 - iLH_Nim_mc = 0 - - iLH_rcm_avg = 0 - - iLH_Vrr = 0 - iLH_VNr = 0 - - iLH_rrainm = 0 - iLH_ricem = 0 - iLH_rsnowm = 0 - iLH_rgraupelm = 0 - - iLH_Nrm = 0 - iLH_Nim = 0 - iLH_Nsnowm = 0 - iLH_Ngraupelm = 0 - - iLH_thlm = 0 - iLH_rcm = 0 - iLH_rvm = 0 - iLH_wm = 0 - iLH_cloud_frac = 0 - - iLH_wp2_zt = 0 - iLH_rcp2_zt = 0 - iLH_rtp2_zt = 0 - iLH_thlp2_zt = 0 - iLH_rrainp2_zt = 0 - iLH_Nrp2_zt = 0 - iLH_Ncp2_zt = 0 - - iC11_Skw_fnc = 0 - ia3_coef_zt = 0 - iwp3_on_wp2_zt = 0 - - allocate( isclrm(1:sclr_dim) ) - allocate( isclrm_f(1:sclr_dim) ) - - isclrm = 0 - isclrm_f = 0 - - allocate( iedsclrm(1:edsclr_dim) ) - allocate( iedsclrm_f(1:edsclr_dim) ) - - iedsclrm = 0 - - iedsclrm_f = 0 - -! Assign pointers for statistics variables zt - - k = 1 - do i=1,zt%nn - - select case ( trim(vars_zt(i)) ) - case ('thlm') - ithlm = k - call stat_assign( ithlm, "thlm", & - "Liquid water potential temperature (theta_l) [K]", "K", zt) - k = k + 1 - - case ('T_in_K') - iT_in_K = k - call stat_assign( iT_in_K, "T_in_K", & - "Absolute temperature [K]", "K", zt ) - k = k + 1 - - case ('thvm') - ithvm = k - call stat_assign( ithvm, "thvm", & - "Virtual potential temperature [K]", "K", zt ) - k = k + 1 - - case ('rtm') - irtm = k - - call stat_assign( irtm, "rtm", & - "Total (vapor+liquid) water mixing ratio [kg/kg]", "kg/kg", zt ) - - !zt%f%var(irtm)%ptr => zt%x(:,k) - !zt%f%var(irtm)%name = "rtm" - !zt%f%var(irtm)%description - != "total water mixing ratio (kg/kg)" - !zt%f%var(irtm)%units = "kg/kg" - - k = k + 1 - - case ('rcm') - ircm = k - call stat_assign( ircm, "rcm", & - "Cloud water mixing ratio [kg/kg]", "kg/kg", zt ) - k = k + 1 - case ('rvm') - irvm = k - call stat_assign( irvm, "rvm", & - "Vapor water mixing ratio [kg/kg]", "kg/kg", zt ) - k = k + 1 - case ('rel_humidity') - irel_humidity = k - call stat_assign( irel_humidity, "rel_humidity", & - "Relative humidity w.r.t. liquid (range [0,1]) [-]", "[-]", zt ) - k = k + 1 - case ('um') - ium = k - call stat_assign( ium, "um", & - "East-west (u) wind [m/s]", "m/s", zt ) - k = k + 1 - case ('vm') - ivm = k - call stat_assign( ivm, "vm", & - "North-south (v) wind [m/s]", "m/s", zt ) - k = k + 1 - case ('wm_zt') - iwm_zt = k - call stat_assign( iwm_zt, "wm", & - "Vertical (w) wind [m/s]", "m/s", zt ) - k = k + 1 - case ('um_ref') - ium_ref = k - call stat_assign( ium_ref, "um_ref", & - "reference u wind (m/s) [m/s]", "m/s", zt) - k = k + 1 - case ('vm_ref') - ivm_ref = k - call stat_assign( ivm_ref, "vm_ref", & - "reference v wind (m/s) [m/s]", "m/s", zt) - k = k + 1 - case ('ug') - iug = k - call stat_assign( iug, "ug", & - "u geostrophic wind [m/s]", "m/s", zt) - k = k + 1 - case ('vg') - ivg = k - call stat_assign( ivg, "vg", & - "v geostrophic wind [m/s]", "m/s", zt ) - k = k + 1 - case ('cloud_frac') - icloud_frac = k - call stat_assign( icloud_frac, "cloud_frac", & - "Cloud fraction (between 0 and 1) [-]", "count", zt ) - k = k + 1 - - case ('rcm_in_layer') - ircm_in_layer = k - call stat_assign( ircm_in_layer, "rcm_in_layer", & - "rcm in cloud layer [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('rcm_in_cloud') - ircm_in_cloud = k - call stat_assign( ircm_in_cloud, "rcm_in_cloud", & - "in-cloud value of rcm (for microphysics) [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('cloud_cover') - icloud_cover = k - call stat_assign( icloud_cover, "cloud_cover", & - "Cloud cover (between 0 and 1) [-]", "count", zt ) - k = k + 1 - case ('p_in_Pa') - ip_in_Pa = k - call stat_assign( ip_in_Pa, "p_in_Pa", & - "Pressure [Pa]", "Pa", zt ) - k = k + 1 - case ('exner') - iexner = k - call stat_assign( iexner, "exner", & - "Exner function = (p/p0)**(rd/cp) [-]", "count", zt ) - k = k + 1 - case ('rho_ds_zt') - irho_ds_zt = k - call stat_assign( irho_ds_zt, "rho_ds_zt", & - "Dry, static, base-state density [kg/m^3]", "kg m^{-3}", zt ) - k = k + 1 - case ('thv_ds_zt') - ithv_ds_zt = k - call stat_assign( ithv_ds_zt, "thv_ds_zt", & - "Dry, base-state theta_v [K]", "K", zt ) - k = k + 1 - case ('Lscale') - iLscale = k - call stat_assign( iLscale, "Lscale", & - "Mixing length [m]", "m", zt ) - k = k + 1 - case ('thlm_forcing') - ithlm_forcing = k - call stat_assign( ithlm_forcing, "thlm_forcing", & - "thlm budget: thetal forcing [K s^{-1}]", "K s^{-1}", zt ) - k = k + 1 - case ('thlm_mc') - ithlm_mc = k - call stat_assign( ithlm_mc, "thlm_mc", & - "Change in thlm due to microphysics (not in budget) [K s^{-1}]", "K s^{-1}", zt ) - k = k + 1 - case ('rtm_forcing') - irtm_forcing = k - call stat_assign( irtm_forcing, "rtm_forcing", & - "rtm budget: rt forcing [kg kg^{-1} s^{-1}]", "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('rtm_mc') - irtm_mc = k - call stat_assign( irtm_mc, "rtm_mc", & - "Change in rt due to microphysics (not in budget) [kg kg^{-1} s^{-1}]", & - "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('rvm_mc') - irvm_mc = k - call stat_assign( irvm_mc, "rvm_mc", & - "Time tendency of vapor mixing ratio due to microphysics [kg/kg/s]", "kg/(kg s)", zt ) - k = k + 1 - - case ('rcm_mc') - ircm_mc = k - call stat_assign( ircm_mc, "rcm_mc", & - "Time tendency of liquid water mixing ratio due microphysics [kg/kg/s]", & - "kg/kg/s", zt ) - k = k + 1 - - case ('rcm_sd_mg_morr') - ircm_sd_mg_morr = k - call stat_assign( ircm_sd_mg_morr, "rcm_sd_mg_morr", & - "rcm sedimentation when using morrision or MG microphysics (not in budget," & - // " included in rcm_mc) [kg kg^{-1} s^{-1}]", "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('thlm_mfl_min') - ithlm_mfl_min = k - call stat_assign( ithlm_mfl_min, "thlm_mfl_min", & - "Minimum allowable thlm [K]", "K", zt ) - k = k + 1 - - case ('thlm_mfl_max') - ithlm_mfl_max = k - call stat_assign( ithlm_mfl_max, "thlm_mfl_max", & - "Maximum allowable thlm [K]", "K", zt ) - k = k + 1 - - case ('thlm_enter_mfl') - ithlm_enter_mfl = k - call stat_assign( ithlm_enter_mfl, "thlm_enter_mfl", & - "Thlm before flux-limiter [K]", "K", zt ) - k = k + 1 - - case ('thlm_exit_mfl') - ithlm_exit_mfl = k - call stat_assign( ithlm_exit_mfl, "thlm_exit_mfl", & - "Thlm exiting flux-limiter [K]", "K", zt ) - k = k + 1 - - case ('thlm_old') - ithlm_old = k - call stat_assign( ithlm_old, "thlm_old", & - "Thlm at previous timestep [K]", "K", zt ) - k = k + 1 - - case ('thlm_without_ta') - ithlm_without_ta = k - call stat_assign( ithlm_without_ta, "thlm_without_ta", & - "Thlm without turbulent advection contribution [K]", "K", zt ) - k = k + 1 - - case ('rtm_mfl_min') - irtm_mfl_min = k - call stat_assign( irtm_mfl_min, "rtm_mfl_min", & - "Minimum allowable rtm [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('rtm_mfl_max') - irtm_mfl_max = k - call stat_assign( irtm_mfl_max, "rtm_mfl_max", & - "Maximum allowable rtm [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('rtm_enter_mfl') - irtm_enter_mfl = k - call stat_assign( irtm_enter_mfl, "rtm_enter_mfl", & - "Rtm before flux-limiter [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('rtm_exit_mfl') - irtm_exit_mfl = k - call stat_assign( irtm_exit_mfl, "rtm_exit_mfl", & - "Rtm exiting flux-limiter [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('rtm_old') - irtm_old = k - call stat_assign( irtm_old, "rtm_old", & - "Rtm at previous timestep [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('rtm_without_ta') - irtm_without_ta = k - call stat_assign( irtm_without_ta, "rtm_without_ta", & - "Rtm without turbulent advection contribution [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('wp3') - iwp3 = k - call stat_assign( iwp3, "wp3", & - "w third order moment [m^3/s^3]", "m^3/s^3", zt ) - k = k + 1 - - case ('wpthlp2') - iwpthlp2 = k - call stat_assign( iwpthlp2, "wpthlp2", & - "w'thl'^2 [(m K^2)/s]", "(m K^2)/s", zt ) - k = k + 1 - - case ('wp2thlp') - iwp2thlp = k - call stat_assign( iwp2thlp, "wp2thlp", & - "w'^2thl' [(m^2 K)/s^2]", "(m^2 K)/s^2", zt ) - k = k + 1 - - case ('wprtp2') - iwprtp2 = k - call stat_assign( iwprtp2, "wprtp2", & - "w'rt'^2 [(m kg)/(s kg)]", "(m kg)/(s kg)", zt ) - k = k + 1 - - case ('wp2rtp') - iwp2rtp = k - call stat_assign( iwp2rtp, "wp2rtp", & - "w'^2rt' [(m^2 kg)/(s^2 kg)]", "(m^2 kg)/(s^2 kg)", zt ) - k = k + 1 - - case ('Lscale_up') - iLscale_up = k - call stat_assign( iLscale_up, "Lscale_up", & - "Upward mixing length [m]", "m", zt ) - k = k + 1 - - case ('Lscale_down') - iLscale_down = k - call stat_assign( iLscale_down, "Lscale_down", & - "Downward mixing length [m]", "m", zt ) - k = k + 1 - - case ('tau_zt') - itau_zt = k - call stat_assign( itau_zt, "tau_zt", & - "Dissipation time [s]", "s", zt ) - k = k + 1 - - case ('Kh_zt') - iKh_zt = k - call stat_assign( iKh_zt, "Kh_zt", & - "Eddy diffusivity [m^2/s]", "m^2/s", zt ) - k = k + 1 - - case ('wp2thvp') - iwp2thvp = k - call stat_assign( iwp2thvp, "wp2thvp", & - "w'^2thv' [K m^2/s^2]", "K m^2/s^2", zt ) - k = k + 1 - - case ('wp2rcp') - iwp2rcp = k - call stat_assign( iwp2rcp, "wp2rcp", & - "w'^2rc' [(m^2 kg)/(s^2 kg)]", "(m^2 kg)/(s^2 kg)", zt ) - k = k + 1 - - case ('wprtpthlp') - iwprtpthlp = k - call stat_assign( iwprtpthlp, "wprtpthlp", & - "w'rt'thl' [(m kg K)/(s kg)]", "(m kg K)/(s kg)", zt ) - k = k + 1 - - case ('sigma_sqd_w_zt') - isigma_sqd_w_zt = k - call stat_assign( isigma_sqd_w_zt, "sigma_sqd_w_zt", & - "Nondimensionalized w variance of Gaussian component [-]", "-", zt ) - k = k + 1 - - case ('rho') - irho = k - call stat_assign( irho, "rho", & - "Air density [kg/m^3]", "kg m^{-3}", zt ) - k = k + 1 - - case ('Ncm') ! Brian - iNcm = k - call stat_assign( iNcm, "Ncm", & - "Cloud droplet number concentration [num/kg]", & - "num/kg", zt ) - k = k + 1 - - case ('Ncm_in_cloud') - iNcm_in_cloud = k - - call stat_assign( iNcm_in_cloud, "Ncm_in_cloud", & - "In cloud droplet concentration [num/kg]", "num/kg", zt ) - - k = k + 1 - - case ('Nc_activated') - iNc_activated = k - - call stat_assign( iNc_activated, "Nc_activated", & - "Droplets activated by GFDL activation [num/kg]", "num/kg", zt ) - - k = k + 1 - - case ('Ncnm') - iNcnm = k - call stat_assign( iNcnm, "Ncnm", & - "Cloud nuclei number concentration [num/kg]", & - "num/kg", zt ) - k = k + 1 - - case ('Nim') ! Brian - iNim = k - call stat_assign( iNim, "Nim", & - "Ice crystal number concentration [num/kg]", & - "num/kg", zt ) - k = k + 1 - - case ('snowslope') ! Adam Smith, 22 April 2008 - isnowslope = k - call stat_assign( isnowslope, "snowslope", & - "COAMPS microphysics snow slope parameter [1/m]", & - "1/m", zt ) - k = k + 1 - - case ('Nsnowm') ! Adam Smith, 22 April 2008 - iNsnowm = k - call stat_assign( iNsnowm, "Nsnowm", & - "Snow particle number concentration [num/kg]", & - "num/kg", zt ) - k = k + 1 - - case ('Ngraupelm') - iNgraupelm = k - call stat_assign( iNgraupelm, "Ngraupelm", & - "Graupel number concentration [num/kg]", & - "num/kg", zt ) - k = k + 1 - - case ('sed_rcm') ! Brian - ised_rcm = k - call stat_assign( ised_rcm, "sed_rcm", & - "d(rcm)/dt due to cloud sedimentation [kg / (m^2 s)]", & - "kg / [m^2 s]", zt ) - k = k + 1 - - case ('rsat') ! Brian - irsat = k - call stat_assign( irsat, "rsat", & - "Saturation mixing ratio over liquid [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('rsati') - irsati = k - call stat_assign( irsati, "rsati", & - "Saturation mixing ratio over ice [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('rrainm') ! Brian - irrainm = k - call stat_assign( irrainm, "rrainm", & - "Rain water mixing ratio [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('rsnowm') - irsnowm = k - call stat_assign( irsnowm, "rsnowm", & - "Snow water mixing ratio [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('ricem') - iricem = k - call stat_assign( iricem, "ricem", & - "Pristine ice water mixing ratio [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('rgraupelm') - irgraupelm = k - call stat_assign( irgraupelm, "rgraupelm", & - "Graupel water mixing ratio [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('Nrm') ! Brian - iNrm = k - call stat_assign( iNrm, "Nrm", & - "Rain drop number concentration [num/kg]", & - "num/kg", zt ) - k = k + 1 - - case ('m_vol_rad_rain') ! Brian - im_vol_rad_rain = k - call stat_assign( im_vol_rad_rain, "mvrr", & - "Rain drop mean volume radius [m]", "m", zt ) - k = k + 1 - - case ('m_vol_rad_cloud') - im_vol_rad_cloud = k - call stat_assign( im_vol_rad_cloud, "m_vol_rad_cloud", & - "Cloud drop mean volume radius [m]", "m", zt ) - k = k + 1 - - case ('eff_rad_cloud') - ieff_rad_cloud = k - call stat_assign( ieff_rad_cloud, "eff_rad_cloud", & - "Cloud drop effective volume radius [microns]", "microns", zt ) - k = k + 1 - - case ('eff_rad_ice') - ieff_rad_ice = k - - call stat_assign( ieff_rad_ice, "eff_rad_ice", & - "Ice effective volume radius [microns]", "microns", zt ) - k = k + 1 - - case ('eff_rad_snow') - ieff_rad_snow = k - call stat_assign( ieff_rad_snow, "eff_rad_snow", & - "Snow effective volume radius [microns]", "microns", zt ) - k = k + 1 - - case ('eff_rad_rain') - ieff_rad_rain = k - call stat_assign( ieff_rad_rain, "eff_rad_rain", & - "Rain drop effective volume radius [microns]", "microns", zt ) - k = k + 1 - - case ('eff_rad_graupel') - ieff_rad_graupel = k - call stat_assign( ieff_rad_graupel, "eff_rad_graupel", & - "Graupel effective volume radius [microns]", "microns", zt ) - k = k + 1 - - case ('rain_rate_zt') ! Brian - irain_rate_zt = k - - call stat_assign( irain_rate_zt, "rain_rate_zt", & - "Rain rate [mm/day]", "mm/day", zt ) - k = k + 1 - - case ( 'AKm' ) ! Vince Larson 22 May 2005 - iAKm = k - call stat_assign( iAKm, "AKm", & - "Analytic Kessler ac [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ( 'LH_AKm' ) ! Vince Larson 22 May 2005 - iLH_AKm = k - - call stat_assign( iLH_AKm, "LH_AKm", & - "LH Kessler estimate [kg/kg/s]", "kg/kg/s", zt ) - k = k + 1 - - case ( 'AKstd' ) - iAKstd = k - - call stat_assign( iAKstd, "AKstd", & - "Exact standard deviation of gba Kessler [kg/kg/s]", "kg/kg/s", zt ) - k = k + 1 - - case ( 'AKstd_cld' ) - iAKstd_cld = k - - call stat_assign( iAKstd_cld, "AKstd_cld", & - "Exact w/in cloud std of gba Kessler [kg/kg/s]", "kg/kg/s", zt ) - k = k + 1 - - case ( 'AKm_rcm' ) - iAKm_rcm = k - - call stat_assign( iAKm_rcm, "AKm_rcm", & - "Exact local gba auto based on rcm [kg/kg/s]", "kg/kg/s", zt ) - k = k + 1 - - case ( 'AKm_rcc' ) - iAKm_rcc = k - - call stat_assign( iAKm_rcc, "AKm_rcc", & - "Exact local gba based on w/in cloud rc [kg/kg/s]", "kg/kg/s", zt ) - k = k + 1 - - case ('radht') - iradht = k - - call stat_assign( iradht, "radht", & - "Total (sw+lw) radiative heating rate [K/s]", "K/s", zt ) - k = k + 1 - - case ('radht_LW') - iradht_LW = k - - call stat_assign( iradht_LW, "radht_LW", & - "Long-wave radiative heating rate [K/s]", "K/s", zt ) - - k = k + 1 - - case ('radht_SW') - iradht_SW = k - call stat_assign( iradht_SW, "radht_SW", & - "Short-wave radiative heating rate [K/s]", "K/s", zt ) - k = k + 1 - - case ('diam') - idiam = k - - call stat_assign( idiam, "diam", & - "Ice crystal diameter [m]", "m", zt ) - k = k + 1 - - case ('mass_ice_cryst') - imass_ice_cryst = k - call stat_assign( imass_ice_cryst, "mass_ice_cryst", & - "Mass of a single ice crystal [kg]", "kg", zt ) - k = k + 1 - - case ('rcm_icedfs') - - ircm_icedfs = k - call stat_assign( ircm_icedfs, "rcm_icedfs", & - "Change in liquid due to ice [kg/kg/s]", "kg/kg/s", zt ) - k = k + 1 - - case ('u_T_cm') - iu_T_cm = k - call stat_assign( iu_T_cm, "u_T_cm", & - "Ice crystal fallspeed [cm s^{-1}]", "cm s^{-1}", zt ) - k = k + 1 - - case ('rtm_bt') - irtm_bt = k - - call stat_assign( irtm_bt, "rtm_bt", & - "rtm budget: rtm time tendency [kg kg^{-1} s^{-1}]", "kg kg^{-1} s^{-1}", zt) - k = k + 1 - - case ('rtm_ma') - irtm_ma = k - - call stat_assign( irtm_ma, "rtm_ma", & - "rtm budget: rtm vertical mean advection [kg kg^{-1} s^{-1}]", & - "kg kg^{-1} s^{-1}", zt) - k = k + 1 - - case ('rtm_ta') - irtm_ta = k - - call stat_assign( irtm_ta, "rtm_ta", & - "rtm budget: rtm turbulent advection [kg kg^{-1} s^{-1}]", "kg kg^{-1} s^{-1}", zt) - k = k + 1 - - case ('rtm_mfl') - irtm_mfl = k - - call stat_assign( irtm_mfl, "rtm_mfl", & - "rtm budget: rtm correction due to monotonic flux limiter [kg kg^{-1} s^{-1}]", & - "kg kg^{-1} s^{-1}", zt) - k = k + 1 - - case ('rtm_tacl') - irtm_tacl = k - - call stat_assign( irtm_tacl, "rtm_tacl", & - "rtm budget: rtm correction due to ta term (wprtp) clipping [kg kg^{-1} s^{-1}]", & - "kg kg^{-1} s^{-1}", zt) - - k = k + 1 - - case ('rtm_cl') - irtm_cl = k - - call stat_assign( irtm_cl, "rtm_cl", & - "rtm budget: rtm clipping [kg kg^{-1} s^{-1}]", "kg kg^{-1} s^{-1}", zt) - - k = k + 1 - case ('rtm_sdmp') - irtm_sdmp = k - - call stat_assign( irtm_sdmp, "rtm_sdmp", & - "rtm budget: rtm correction due to sponge damping [kg kg^{-1} s^{-1}]", & - "kg kg^{-1} s^{-1}", zt) - k = k + 1 - - - case ('rtm_pd') - irtm_pd = k - - call stat_assign( irtm_pd, "rtm_pd", & - "rtm budget: rtm positive definite adjustment [kg kg^{-1} s^{-1}]", & - "kg kg^{-1} s^{-1}", zt) - - k = k + 1 - - case ('thlm_bt') - ithlm_bt = k - - call stat_assign( ithlm_bt, "thlm_bt", & - "thlm budget: thlm time tendency [K s^{-1}]", "K s^{-1}", zt) - k = k + 1 - - case ('thlm_ma') - ithlm_ma = k - - call stat_assign( ithlm_ma, "thlm_ma", & - "thlm budget: thlm vertical mean advection [K s^{-1}]", "K s^{-1}", zt) - k = k + 1 - - case ('thlm_sdmp') - ithlm_sdmp = k - - call stat_assign( ithlm_sdmp, "thlm_sdmp", & - "thlm budget: thlm correction due to sponge damping [K s^{-1}]", "K s^{-1}", zt) - k = k + 1 - - - case ('thlm_ta') - ithlm_ta = k - - call stat_assign( ithlm_ta, "thlm_ta", & - "thlm budget: thlm turbulent advection [K s^{-1}]", "K s^{-1}", zt) - k = k + 1 - - case ('thlm_mfl') - ithlm_mfl = k - - call stat_assign( ithlm_mfl, "thlm_mfl", & - "thlm budget: thlm correction due to monotonic flux limiter [K s^{-1}]", & - "K s^{-1}", zt) - k = k + 1 - - case ('thlm_tacl') - ithlm_tacl = k - - call stat_assign( ithlm_tacl, "thlm_tacl", & - "thlm budget: thlm correction due to ta term (wpthlp) clipping [K s^{-1}]", & - "K s^{-1}", zt) - k = k + 1 - - case ('thlm_cl') - ithlm_cl = k - - call stat_assign( ithlm_cl, "thlm_cl", & - "thlm budget: thlm_cl [K s^{-1}]", "K s^{-1}", zt) - k = k + 1 - - case ('wp3_bt') - iwp3_bt = k - - call stat_assign( iwp3_bt, "wp3_bt", & - "wp3 budget: wp3 time tendency [m^{3} s^{-4}]", "m^{3} s^{-4}", zt ) - k = k + 1 - - case ('wp3_ma') - iwp3_ma = k - - call stat_assign( iwp3_ma, "wp3_ma", & - "wp3 budget: wp3 vertical mean advection [m^{3} s^{-4}]", "m^{3} s^{-4}", zt ) - k = k + 1 - - case ('wp3_ta') - iwp3_ta = k - - call stat_assign( iwp3_ta, "wp3_ta", & - "wp3 budget: wp3 turbulent advection [m^{3} s^{-4}]", "m^{3} s^{-4}", zt ) - - k = k + 1 - - case ('wp3_tp') - iwp3_tp = k - call stat_assign( iwp3_tp, "wp3_tp", & - "wp3 budget: wp3 turbulent transport [m^{3} s^{-4}]", "m^{3} s^{-4}", zt ) - k = k + 1 - - case ('wp3_ac') - iwp3_ac = k - call stat_assign( iwp3_ac, "wp3_ac", & - "wp3 budget: wp3 accumulation term [m^{3} s^{-4}]", "m^{3} s^{-4}", zt ) - k = k + 1 - - case ('wp3_bp1') - iwp3_bp1 = k - call stat_assign( iwp3_bp1, "wp3_bp1", & - "wp3 budget: wp3 buoyancy production [m^{3} s^{-4}]", "m^{3} s^{-4}", zt ) - k = k + 1 - - case ('wp3_bp2') - iwp3_bp2 = k - call stat_assign( iwp3_bp2, "wp3_bp2", & - "wp3 budget: wp3 2nd buoyancy production term [m^{3} s^{-4}]", "m^{3} s^{-4}", zt ) - k = k + 1 - - case ('wp3_pr1') - iwp3_pr1 = k - call stat_assign( iwp3_pr1, "wp3_pr1", & - "wp3 budget: wp3 pressure term 1 [m^{3} s^{-4}]", "m^{3} s^{-4}", zt ) - k = k + 1 - - case ('wp3_pr2') - iwp3_pr2 = k - call stat_assign( iwp3_pr2, "wp3_pr2", & - "wp3 budget: wp3 pressure term 2 [m^{3} s^{-4}]", "m^{3} s^{-4}", zt ) - - k = k + 1 - - case ('wp3_dp1') - iwp3_dp1 = k - call stat_assign( iwp3_dp1, "wp3_dp1", & - "wp3 budget: wp3 dissipation term 1 [m^{3} s^{-4}]", "m^{3} s^{-4}", zt ) - k = k + 1 - - case ('wp3_4hd') - iwp3_4hd = k - call stat_assign( iwp3_4hd, "wp3_4hd", & - "wp3 budget: wp3 4th-order hyper-diffusion [m^{3} s^{-4}]", "m^{3} s^{-4}", zt ) - k = k + 1 - - case ('wp3_cl') - iwp3_cl = k - call stat_assign( iwp3_cl, "wp3_cl", & - "wp3 budget: wp3 clipping term [m^{3} s^{-4}]", "m^{3} s^{-4}", zt ) - k = k + 1 - - case ('rrainm_bt') - irrainm_bt = k - call stat_assign( irrainm_bt, "rrainm_bt", & - "rrainm budget: rrainm time tendency [kg kg^{-1} s^{-1}]", "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('rrainm_ma') - irrainm_ma = k - - call stat_assign( irrainm_ma, "rrainm_ma", & - "rrainm budget: rrainm vertical mean advection [kg kg^{-1} s^{-1}]", & - "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('rrainm_sd') - irrainm_sd = k - - call stat_assign( irrainm_sd, "rrainm_sd", & - "rrainm budget: rrainm sedimentation [kg kg^{-1} s^{-1}]", "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('rrainm_sd_morr') - irrainm_sd_morr = k - - call stat_assign( irrainm_sd_morr, "rrainm_sd_morr", & - "rrainm sedimentation when using morrision microphysics (not in budget, included" & - // " in rrainm_mc) [kg kg^{-1} s^{-1}]", "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('rrainm_dff') - irrainm_dff = k - - call stat_assign( irrainm_dff, "rrainm_dff", & - "rrainm budget: rrainm diffusion [kg kg^{-1} s^{-1}]", "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('rrainm_cond') - irrainm_cond = k - - call stat_assign( irrainm_cond, "rrainm_cond", & - "rrainm condensation/evaporation [kg kg^{-1} s^{-1}]", & - "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('rrainm_auto') - irrainm_auto = k - - call stat_assign( irrainm_auto, "rrainm_auto", & - "rrainm autoconversion [kg kg^{-1} s^{-1}]", "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('rrainm_accr') - irrainm_accr = k - call stat_assign( irrainm_accr, "rrainm_accr", & - "rrainm accretion [kg kg^{-1} s^{-1}]", "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('rrainm_cond_adj') - irrainm_cond_adj = k - - call stat_assign( irrainm_cond_adj, "rrainm_cond_adj", & - "rrainm budget: rrainm cond/evap adjustment due to over-evaporation " // & - "[kg kg^{-1} s^{-1}]", "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('rrainm_src_adj') - irrainm_src_adj = k - - call stat_assign( irrainm_src_adj, "rrainm_src_adj", & - "rrainm budget: rrainm source term adjustment due to over-depletion " // & - "[kg kg^{-1} s^{-1}]", "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('rrainm_cl') - irrainm_cl = k - call stat_assign( irrainm_cl, "rrainm_cl", & - "rrainm budget: rrainm clipping term [kg kg^{-1} s^{-1}]", "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('rrainm_mc') - irrainm_mc = k - - call stat_assign( irrainm_mc, "rrainm_mc", & - "rrainm budget: Change in rrainm due to microphysics [kg kg^{-1} s^{-1}]", & - "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('Nrm_bt') - iNrm_bt = k - call stat_assign( iNrm_bt, "Nrm_bt", & - "Nrm budget: Nrm time tendency [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Nrm_ma') - iNrm_ma = k - - call stat_assign( iNrm_ma, "Nrm_ma", & - "Nrm budget: Nrm vertical mean advection [(num/kg)/s]", "(num/kg)/s", zt ) - k = k + 1 - - case ('Nrm_sd') - iNrm_sd = k - - call stat_assign( iNrm_sd, "Nrm_sd", & - "Nrm budget: Nrm sedimentation [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Nrm_dff') - iNrm_dff = k - call stat_assign( iNrm_dff, "Nrm_dff", & - "Nrm budget: Nrm diffusion [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Nrm_cond') - iNrm_cond = k - - call stat_assign( iNrm_cond, "Nrm_cond", & - "Change in Nrm due to condensation [(num/kg)/s]", "(num/kg)/s", zt ) - k = k + 1 - - case ('Nrm_auto') - iNrm_auto = k - - call stat_assign( iNrm_auto, "Nrm_auto", & - "Change in Nrm due to autoconversion [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Nrm_cond_adj') - iNrm_cond_adj = k - - call stat_assign( iNrm_cond_adj, "Nrm_cond_adj", & - "Nrm budget: Nrm cond/evap adjustment due to over-evaporation [(num/kg)/s]", & - "(num/kg)/s", zt ) - k = k + 1 - - case ('Nrm_src_adj') - iNrm_src_adj = k - - call stat_assign( iNrm_src_adj, "Nrm_src_adj", & - "Nrm budget: Nrm source term adjustment due to over-depletion [(num/kg)/s]", & - "(num/kg)/s", zt ) - k = k + 1 - - case ('Nrm_cl') - iNrm_cl = k - call stat_assign( iNrm_cl, "Nrm_cl", & - "Nrm budget: Nrm clipping term [(num/kg)/s]", "(num/kg)/s", zt ) - k = k + 1 - - case ('Nrm_mc') - iNrm_mc = k - call stat_assign( iNrm_mc, "Nrm_mc", & - "Nrm budget: Change in Nrm due to microphysics (Not in budget) [(num/kg)/s]", & - "(num/kg)/s", zt ) - k = k + 1 - - case ('rsnowm_bt') - irsnowm_bt = k - call stat_assign( irsnowm_bt, "rsnowm_bt", & - "rsnowm budget: rsnowm time tendency [(kg/kg)/s]", "(kg/kg)/s", zt ) - - k = k + 1 - - case ('rsnowm_ma') - irsnowm_ma = k - - call stat_assign( irsnowm_ma, "rsnowm_ma", & - "rsnowm budget: rsnowm vertical mean advection [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('rsnowm_sd') - irsnowm_sd = k - call stat_assign( irsnowm_sd, "rsnowm_sd", & - "rsnowm budget: rsnowm sedimentation [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('rsnowm_sd_morr') - irsnowm_sd_morr = k - call stat_assign( irsnowm_sd_morr, "rsnowm_sd_morr", & - "rsnowm sedimentation when using morrison microphysics (Not in budget, included in" & - // " rsnowm_mc) [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('rsnowm_dff') - irsnowm_dff = k - - call stat_assign( irsnowm_dff, "rsnowm_dff", & - "rsnowm budget: rsnowm diffusion [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('rsnowm_mc') - irsnowm_mc = k - - call stat_assign( irsnowm_mc, "rsnowm_mc", & - "rsnowm budget: Change in rsnowm due to microphysics [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('rsnowm_cl') - irsnowm_cl = k - - call stat_assign( irsnowm_cl, "rsnowm_cl", & - "rsnowm budget: rsnowm clipping term [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('Nsnowm_bt') - iNsnowm_bt = k - call stat_assign( iNsnowm_bt, "Nsnowm_bt", & - "Nsnowm budget: [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Nsnowm_ma') - iNsnowm_ma = k - - call stat_assign( iNsnowm_ma, "Nsnowm_ma", & - "Nsnowm budget: Nsnowm mean advection [(num/kg)/s]", "(num/kg)/s", zt ) - k = k + 1 - - case ('Nsnowm_sd') - iNsnowm_sd = k - - call stat_assign( iNsnowm_sd, "Nsnowm_sd", & - "Nsnowm budget: Nsnowm sedimentation [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Nsnowm_dff') - iNsnowm_dff = k - call stat_assign( iNsnowm_dff, "Nsnowm_dff", & - "Nsnowm budget: Nsnowm diffusion [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Nsnowm_mc') - iNsnowm_mc = k - call stat_assign( iNsnowm_mc, "Nsnowm_mc", & - "Nsnowm budget: Nsnowm microphysics [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Nsnowm_cl') - iNsnowm_cl = k - - call stat_assign( iNsnowm_cl, "Nsnowm_cl", & - "Nsnowm budget: Nsnowm clipping term [(num/kg)/s]", "(num/kg)/s", zt ) - k = k + 1 - - case ('ricem_bt') - iricem_bt = k - - call stat_assign( iricem_bt, "ricem_bt", & - "ricem budget: ricem time tendency [(kg/kg)/s]", "(kg/kg)/s", zt ) - - k = k + 1 - - case ('ricem_ma') - iricem_ma = k - - call stat_assign( iricem_ma, "ricem_ma", & - "ricem budget: ricem vertical mean advection [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('ricem_sd') - iricem_sd = k - - call stat_assign( iricem_sd, "ricem_sd", & - "ricem budget: ricem sedimentation [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('ricem_sd_mg_morr') - iricem_sd_mg_morr = k - - call stat_assign( iricem_sd_mg_morr, "ricem_sd_mg_morr", & - "ricem sedimentation when using morrison or MG microphysics (not in budget," & - // " included in ricem_mc) [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('ricem_dff') - iricem_dff = k - - call stat_assign( iricem_dff, "ricem_dff", & - "ricem budget: ricem diffusion [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('ricem_mc') - iricem_mc = k - - call stat_assign( iricem_mc, "ricem_mc", & - "ricem budget: Change in ricem due to microphysics [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('ricem_cl') - iricem_cl = k - - call stat_assign( iricem_cl, "ricem_cl", & - "ricem budget: ricem clipping term [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('rgraupelm_bt') - irgraupelm_bt = k - - call stat_assign( irgraupelm_bt, "rgraupelm_bt", & - "rgraupelm budget: rgraupelm time tendency [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('rgraupelm_ma') - irgraupelm_ma = k - - call stat_assign( irgraupelm_ma, "rgraupelm_ma", & - "rgraupelm budget: rgraupelm vertical mean advection [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('rgraupelm_sd') - irgraupelm_sd = k - - call stat_assign( irgraupelm_sd, "rgraupelm_sd", & - "rgraupelm budget: rgraupelm sedimentation [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('rgraupelm_sd_morr') - irgraupelm_sd_morr = k - - call stat_assign( irgraupelm_sd_morr, "rgraupelm_sd_morr", & - "rgraupelm sedimentation when using morrison microphysics (not in budget, included" & - // " in rgraupelm_mc) [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('rgraupelm_dff') - irgraupelm_dff = k - - call stat_assign( irgraupelm_dff, "rgraupelm_dff", & - "rgraupelm budget: rgraupelm diffusion [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('rgraupelm_mc') - irgraupelm_mc = k - - call stat_assign( irgraupelm_mc, "rgraupelm_mc", & - "rgraupelm budget: Change in rgraupelm due to microphysics [(kg/kg)/s]", & - "(kg/kg)/s", zt ) - k = k + 1 - - case ('rgraupelm_cl') - irgraupelm_cl = k - - call stat_assign( irgraupelm_cl, "rgraupelm_cl", & - "rgraupelm budget: rgraupelm clipping term [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('Ngraupelm_bt') - iNgraupelm_bt = k - call stat_assign( iNgraupelm_bt, "Ngraupelm_bt", & - "Ngraupelm budget: [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Ngraupelm_ma') - iNgraupelm_ma = k - - call stat_assign( iNgraupelm_ma, "Ngraupelm_ma", & - "Ngraupelm budget: Ngraupelm mean advection [(num/kg)/s]", "(num/kg)/s", zt ) - k = k + 1 - - case ('Ngraupelm_sd') - iNgraupelm_sd = k - - call stat_assign( iNgraupelm_sd, "Ngraupelm_sd", & - "Ngraupelm budget: Ngraupelm sedimentation [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Ngraupelm_dff') - iNgraupelm_dff = k - call stat_assign( iNgraupelm_dff, "Ngraupelm_dff", & - "Ngraupelm budget: Ngraupelm diffusion [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Ngraupelm_mc') - iNgraupelm_mc = k - - call stat_assign( iNgraupelm_mc, "Ngraupelm_mc", & - "Ngraupelm budget: Ngraupelm microphysics term [(num/kg)/s]", "(num/kg)/s", zt ) - k = k + 1 - - case ('Ngraupelm_cl') - iNgraupelm_cl = k - - call stat_assign( iNgraupelm_cl, "Ngraupelm_cl", & - "Ngraupelm budget: Ngraupelm clipping term [(num/kg)/s]", "(num/kg)/s", zt ) - k = k + 1 - - case ('Nim_bt') - iNim_bt = k - call stat_assign( iNim_bt, "Nim_bt", & - "Nim budget: [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Nim_ma') - iNim_ma = k - - call stat_assign( iNim_ma, "Nim_ma", & - "Nim budget: Nim mean advection [(num/kg)/s]", "(num/kg)/s", zt ) - k = k + 1 - - case ('Nim_sd') - iNim_sd = k - - call stat_assign( iNim_sd, "Nim_sd", & - "Nim budget: Nim sedimentation [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Nim_dff') - iNim_dff = k - call stat_assign( iNim_dff, "Nim_dff", & - "Nim budget: Nim diffusion [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Nim_mc') - iNim_mc = k - - call stat_assign( iNim_mc, "Nim_mc", & - "Nim budget: Nim microphysics term [(num/kg)/s]", "(num/kg)/s", zt ) - k = k + 1 - - case ('Nim_cl') - iNim_cl = k - - call stat_assign( iNim_cl, "Nim_cl", & - "Nim budget: Nim clipping term [(num/kg)/s]", "(num/kg)/s", zt ) - k = k + 1 - - case ('Ncm_bt') - iNcm_bt = k - call stat_assign( iNcm_bt, "Ncm_bt", & - "Ncm budget: Cloud droplet number concentration budget [(num/kg)/s]", & - "(num/kg)/s", zt ) - - k = k + 1 - - case ('Ncm_ma') - iNcm_ma = k - - call stat_assign( iNcm_ma, "Ncm_ma", & - "Ncm budget: Ncm vertical mean advection [(num/kg)/s]", "(num/kg)/s", zt ) - k = k + 1 - - case ('Ncm_act') - iNcm_act = k - - call stat_assign( iNcm_act, "Ncm_act", & - "Ncm budget: Change in Ncm due to activation [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Ncm_dff') - iNcm_dff = k - call stat_assign( iNcm_dff, "Ncm_dff", & - "Ncm budget: Ncm diffusion [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Ncm_mc') - iNcm_mc = k - - call stat_assign( iNcm_mc, "Ncm_mc", & - "Ncm budget: Change in Ncm due to microphysics [(num/kg)/s]", "(num/kg)/s", zt ) - k = k + 1 - - case ('Ncm_cl') - iNcm_cl = k - - call stat_assign( iNcm_cl, "Ncm_cl", & - "Ncm budget: Ncm clipping term [(num/kg)/s]", "(num/kg)/s", zt ) - k = k + 1 - - case ('vm_bt') - ivm_bt = k - - call stat_assign( ivm_bt, "vm_bt", & - "vm budget: vm time tendency [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('vm_ma') - ivm_ma = k - call stat_assign( ivm_ma, "vm_ma", & - "vm budget: vm vertical mean advection [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('vm_gf') - ivm_gf = k - - call stat_assign( ivm_gf, "vm_gf", & - "vm budget: vm geostrophic forcing [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('vm_cf') - ivm_cf = k - - call stat_assign( ivm_cf, "vm_cf", & - "vm budget: vm coriolis forcing [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('vm_ta') - ivm_ta = k - - call stat_assign( ivm_ta, "vm_ta", & - "vm budget: vm turbulent transport [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('vm_f') - ivm_f = k - call stat_assign( ivm_f, "vm_f", & - "vm budget: vm forcing [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('vm_sdmp') - ivm_sdmp = k - call stat_assign( ivm_sdmp, "vm_sdmp", & - "vm budget: vm sponge damping [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('vm_ndg') - ivm_ndg = k - call stat_assign( ivm_ndg, "vm_ndg", & - "vm budget: vm nudging [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('um_bt') - ium_bt = k - - call stat_assign( ium_bt, "um_bt", & - "um budget: um time tendency [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('um_ma') - ium_ma = k - - call stat_assign( ium_ma, "um_ma", & - "um budget: um vertical mean advection [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('um_gf') - ium_gf = k - call stat_assign( ium_gf, "um_gf", & - "um budget: um geostrophic forcing [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('um_cf') - ium_cf = k - call stat_assign( ium_cf, "um_cf", & - "um budget: um coriolis forcing [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('um_ta') - ium_ta = k - call stat_assign( ium_ta, "um_ta", & - "um budget: um turbulent advection [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('um_f') - ium_f = k - call stat_assign( ium_f, "um_f", & - "um budget: um forcing [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('um_sdmp') - ium_sdmp = k - call stat_assign( ium_sdmp, "um_sdmp", & - "um budget: um sponge damping [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('um_ndg') - ium_ndg = k - call stat_assign( ium_ndg, "um_ndg", & - "um budget: um nudging [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('mixt_frac') - imixt_frac = k - call stat_assign( imixt_frac, "mixt_frac", & - "pdf parameter: mixture fraction [count]", "count", zt ) - k = k + 1 - - case ('w1') - iw1 = k - call stat_assign( iw1, "w1", & - "pdf parameter: mean w of component 1 [m/s]", "m/s", zt ) - - k = k + 1 - - case ('w2') - iw2 = k - - call stat_assign( iw2, "w2", & - "pdf paramete: mean w of component 2 [m/s]", "m/s", zt ) - k = k + 1 - - case ('varnce_w1') - ivarnce_w1 = k - call stat_assign( ivarnce_w1, "varnce_w1", & - "pdf parameter: w variance of component 1 [m^2/s^2]", "m^2/s^2", zt ) - - k = k + 1 - - case ('varnce_w2') - ivarnce_w2 = k - - call stat_assign( ivarnce_w2, "varnce_w2", & - "pdf parameter: w variance of component 2 [m^2/s^2]", "m^2/s^2", zt ) - k = k + 1 - - case ('thl1') - ithl1 = k - - call stat_assign( ithl1, "thl1", & - "pdf parameter: mean thl of component 1 [K]", "K", zt ) - - k = k + 1 - - case ('thl2') - ithl2 = k - - call stat_assign( ithl2, "thl2", & - "pdf parameter: mean thl of component 2 [K]", "K", zt ) - k = k + 1 - - case ('varnce_thl1') - ivarnce_thl1 = k - - call stat_assign( ivarnce_thl1, "varnce_thl1", & - "pdf parameter: thl variance of component 1 [K^2]", "K^2", zt ) - - k = k + 1 - - case ('varnce_thl2') - ivarnce_thl2 = k - call stat_assign( ivarnce_thl2, "varnce_thl2", & - "pdf parameter: thl variance of component 2 [K^2]", "K^2", zt ) - - k = k + 1 - - case ('rt1') - irt1 = k - call stat_assign( irt1, "rt1", & - "pdf parameter: mean rt of component 1 [kg/kg]", "kg/kg", zt ) - - k = k + 1 - - case ('rt2') - irt2 = k - - call stat_assign( irt2, "rt2", & - "pdf parameter: mean rt of component 2 [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('varnce_rt1') - ivarnce_rt1 = k - call stat_assign( ivarnce_rt1, "varnce_rt1", & - "pdf parameter: rt variance of component 1 [(kg^2)/(kg^2)]", "(kg^2)/(kg^2)", zt ) - k = k + 1 - - case ('varnce_rt2') - ivarnce_rt2 = k - - call stat_assign( ivarnce_rt2, "varnce_rt2", & - "pdf parameter: rt variance of component 2 [(kg^2)/(kg^2)]", "(kg^2)/(kg^2)", zt ) - k = k + 1 - - case ('rc1') - irc1 = k - - call stat_assign( irc1, "rc1", & - "pdf parameter: mean rc of component 1 [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('rc2') - irc2 = k - - call stat_assign( irc2, "rc2", & - "pdf parameter: mean rc of component 2 [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('rsl1') - irsl1 = k - - call stat_assign( irsl1, "rsl1", & - "pdf parameter: sat mix rat based on tl1 [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('rsl2') - irsl2 = k - - call stat_assign( irsl2, "rsl2", & - "pdf parameter: sat mix rat based on tl2 [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('cloud_frac1') - icloud_frac1 = k - call stat_assign( icloud_frac1, "cloud_frac1", & - "pdf parameter cloud_frac1 [count]", "count", zt ) - k = k + 1 - - case ('cloud_frac2') - icloud_frac2 = k - - call stat_assign( icloud_frac2, "cloud_frac2", & - "pdf parameter cloud_frac2 [count]", "count", zt ) - k = k + 1 - - case ('s1') - is1 = k - - call stat_assign( is1, "s1", & - "pdf parameter: Mellor's s (extended liq) for component 1 [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('s2') - is2 = k - - call stat_assign( is2, "s2", & - "pdf parameter: Mellor's s (extended liq) for component 2 [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('stdev_s1') - istdev_s1 = k - - call stat_assign( istdev_s1, "stdev_s1", & - "pdf parameter: Std dev of s1 [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('stdev_s2') - istdev_s2 = k - - call stat_assign( istdev_s2, "stdev_s2", & - "pdf parameter: Std dev of s2 [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('rrtthl') - irrtthl = k - - call stat_assign( irrtthl, "rrtthl", & - "pdf parameter: Within-component correlation of rt and thl [count]", "count", zt ) - k = k + 1 - - case('wp2_zt') - iwp2_zt = k - - call stat_assign( iwp2_zt, "wp2_zt", & - "w'^2 interpolated to thermodyamic levels [m^2/s^2]", "m^2/s^2", zt ) - k = k + 1 - - case('thlp2_zt') - ithlp2_zt = k - - call stat_assign( ithlp2_zt, "thlp2_zt", & - "thl'^2 interpolated to thermodynamic levels [K^2]", "K^2", zt ) - k = k + 1 - - case('wpthlp_zt') - iwpthlp_zt = k - - call stat_assign( iwpthlp_zt, "wpthlp_zt", & - "w'thl' interpolated to thermodynamic levels [(m K)/s]", "(m K)/s", zt ) - k = k + 1 - - case('wprtp_zt') - iwprtp_zt = k - - call stat_assign( iwprtp_zt, "wprtp_zt", & - "w'rt' interpolated to thermodynamic levels [(m kg)/(s kg)]", "(m kg)/(s kg)", zt ) - k = k + 1 - - case('rtp2_zt') - irtp2_zt = k - - call stat_assign( irtp2_zt, "rtp2_zt", & - "rt'^2 interpolated to thermodynamic levels [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case('rtpthlp_zt') - irtpthlp_zt = k - - call stat_assign( irtpthlp_zt, "rtpthlp_zt", & - "rt'thl' interpolated to thermodynamic levels [(kg K)/kg]", "(kg K)/kg", zt ) - k = k + 1 - - case ('up2_zt') - iup2_zt = k - call stat_assign( iup2_zt, "up2_zt", & - "u'^2 interpolated to thermodynamic levels [m^2/s^2]", "m^2/s^2", zt ) - k = k + 1 - - case ('vp2_zt') - ivp2_zt = k - call stat_assign( ivp2_zt, "vp2_zt", & - "v'^2 interpolated to thermodynamic levels [m^2/s^2]", "m^2/s^2", zt ) - k = k + 1 - - case ('upwp_zt') - iupwp_zt = k - call stat_assign( iupwp_zt, "upwp_zt", & - "u'w' interpolated to thermodynamic levels [m^2/s^2]", "m^2/s^2", zt ) - k = k + 1 - - case ('vpwp_zt') - ivpwp_zt = k - call stat_assign( ivpwp_zt, "vpwp_zt", & - "v'w' interpolated to thermodynamic levels [m^2/s^2]", "m^2/s^2", zt ) - k = k + 1 - - case('LH_rvm_mc') - iLH_rvm_mc = k - - call stat_assign( iLH_rvm_mc, "LH_rvm_mc", & - "Latin hypercube estimate of rvm_mc [kg/kg/s]", "kg/kg/s", zt ) - k = k + 1 - - case('LH_thlm_mc') - iLH_thlm_mc = k - - call stat_assign( iLH_thlm_mc, "LH_thlm_mc", & - "Latin hypercube estimate of thlm_mc [kg/kg/s]", "kg/kg/s", zt ) - k = k + 1 - - case('LH_rcm_mc') - iLH_rcm_mc = k - - call stat_assign( iLH_rcm_mc, "LH_rcm_mc", & - "Latin hypercube estimate of rcm_mc [kg/kg/s]", "kg/kg/s", zt ) - k = k + 1 - - case('LH_Ncm_mc') - iLH_Ncm_mc = k - - call stat_assign( iLH_Ncm_mc, "LH_Ncm_mc", & - "Latin hypercube estimate of Ncm_mc [kg/kg/s]", "kg/kg/s", zt ) - k = k + 1 - - case('LH_rrainm_mc') - iLH_rrainm_mc = k - - call stat_assign( iLH_rrainm_mc, "LH_rrainm_mc", & - "Latin hypercube estimate of rrainm_mc [kg/kg/s]", "kg/kg/s", zt ) - k = k + 1 - - case('LH_Nrm_mc') - iLH_Nrm_mc = k - - call stat_assign( iLH_Nrm_mc, "LH_Nrm_mc", & - "Latin hypercube estimate of Nrm_mc [kg/kg/s]", "kg/kg/s", zt ) - k = k + 1 - - case('LH_rsnowm_mc') - iLH_rsnowm_mc = k - - call stat_assign( iLH_rsnowm_mc, "LH_rsnowm_mc", & - "Latin hypercube estimate of rsnowm_mc [kg/kg/s]", "kg/kg/s", zt ) - k = k + 1 - - case('LH_Nsnowm_mc') - iLH_Nsnowm_mc = k - - call stat_assign( iLH_Nsnowm_mc, "LH_Nsnowm_mc", & - "Latin hypercube estimate of Nsnowm_mc [kg/kg/s]", "kg/kg/s", zt ) - k = k + 1 - - case('LH_rgraupelm_mc') - iLH_rgraupelm_mc = k - - call stat_assign( iLH_rgraupelm_mc, "LH_rgraupelm_mc", & - "Latin hypercube estimate of rgraupelm_mc [kg/kg/s]", "kg/kg/s", zt ) - k = k + 1 - - case('LH_Ngraupelm_mc') - iLH_Ngraupelm_mc = k - - call stat_assign( iLH_Ngraupelm_mc, "LH_Ngraupelm_mc", & - "Latin hypercube estimate of Ngraupelm_mc [kg/kg/s]", "kg/kg/s", zt ) - k = k + 1 - - case('LH_ricem_mc') - iLH_ricem_mc = k - - call stat_assign( iLH_ricem_mc, "LH_ricem_mc", & - "Latin hypercube estimate of ricem_mc [kg/kg/s]", "kg/kg/s", zt ) - k = k + 1 - - case('LH_Nim_mc') - iLH_Nim_mc = k - - call stat_assign( iLH_Nim_mc, "LH_Nim_mc", & - "Latin hypercube estimate of Nim_mc [kg/kg/s]", "kg/kg/s", zt ) - k = k + 1 - - case ( 'LH_Vrr' ) - iLH_Vrr = k - - call stat_assign( iLH_Vrr, "LH_Vrr", & - "Latin hypercube estimate of rrainm sedimentation velocity [m/s]", "m/s", zt ) - k = k + 1 - - case ( 'LH_VNr' ) - iLH_VNr = k - - call stat_assign( iLH_VNr, "LH_VNr", & - "Latin hypercube estimate of Nrm sedimentation velocity [m/s]", "m/s", zt ) - k = k + 1 - - case ( 'LH_rcm_avg' ) - iLH_rcm_avg = k - - call stat_assign( iLH_rcm_avg, "LH_rcm_avg", & - "Latin hypercube average estimate of rcm [kg/kg]", "kg/kg", zt ) - - k = k + 1 - - case ( 'LH_rrainm' ) - iLH_rrainm = k - - call stat_assign( iLH_rrainm, "LH_rrainm", & - "Latin hypercube estimate of rrainm [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ( 'LH_Nrm' ) - iLH_Nrm = k - - call stat_assign( iLH_Nrm, "LH_Nrm", & - "Latin hypercube estimate of Nrm [count/kg]", "count/kg", zt ) - k = k + 1 - - case ( 'LH_ricem' ) - iLH_ricem = k - - call stat_assign( iLH_ricem, "LH_ricem", & - "Latin hypercube estimate of ricem [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ( 'LH_Nim' ) - iLH_Nim = k - - call stat_assign( iLH_Nim, "LH_Nim", & - "Latin hypercube estimate of Nim [count/kg]", "count/kg", zt ) - k = k + 1 - - case ( 'LH_rsnowm' ) - iLH_rsnowm = k - - call stat_assign( iLH_rsnowm, "LH_rsnowm", & - "Latin hypercube estimate of rsnowm [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ( 'LH_Nsnowm' ) - iLH_Nsnowm = k - - call stat_assign( iLH_Nsnowm, "LH_Nsnowm", & - "Latin hypercube estimate of Nsnowm [count/kg]", "count/kg", zt ) - k = k + 1 - - - case ( 'LH_rgraupelm' ) - iLH_rgraupelm = k - - call stat_assign( iLH_rgraupelm, "LH_rgraupelm", & - "Latin hypercube estimate of rgraupelm [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ( 'LH_Ngraupelm' ) - iLH_Ngraupelm = k - - call stat_assign( iLH_Ngraupelm, "LH_Ngraupelm", & - "Latin hypercube estimate of Ngraupelm [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ( 'LH_thlm' ) - iLH_thlm = k - - call stat_assign( iLH_thlm, "LH_thlm", & - "Latin hypercube estimate of thlm [K]", "K", zt ) - k = k + 1 - - case ( 'LH_rcm' ) - iLH_rcm = k - - call stat_assign( iLH_rcm, "LH_rcm", & - "Latin hypercube estimate of rcm [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ( 'LH_Ncm' ) - iLH_Ncm = k - - call stat_assign( iLH_Ncm, "LH_Ncm", & - "Latin hypercube estimate of Ncm [count/kg]", "count/kg", zt ) - k = k + 1 - - - case ( 'LH_rvm' ) - iLH_rvm = k - - call stat_assign( iLH_rvm, "LH_rvm", & - "Latin hypercube estimate of rvm [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ( 'LH_wm' ) - iLH_wm = k - - call stat_assign( iLH_wm, "LH_wm", & - "Latin hypercube estimate of vertical velocity [m/s]", "m/s", zt ) - k = k + 1 - - case ( 'LH_cloud_frac' ) - iLH_cloud_frac = k - - ! Note: count is the udunits compatible unit - call stat_assign( iLH_cloud_frac, "LH_cloud_frac", & - "Latin hypercube estimate of cloud fraction [count]", "count", zt ) - k = k + 1 - - case ( 'LH_wp2_zt' ) - iLH_wp2_zt = k - call stat_assign( iLH_wp2_zt, "LH_wp2_zt", & - "Variance of the latin hypercube estimate of w [m^2/s^2]", "m^2/s^2", zt ) - k = k + 1 - - case ( 'LH_Ncp2_zt' ) - iLH_Ncp2_zt = k - call stat_assign( iLH_Ncp2_zt, "LH_Ncp2_zt", & - "Variance of the latin hypercube estimate of Nc [count^2/kg^2]", "count^2/kg^2", zt ) - k = k + 1 - - case ( 'LH_Nrp2_zt' ) - iLH_Nrp2_zt = k - call stat_assign( iLH_Nrp2_zt, "LH_Nrp2_zt", & - "Variance of the latin hypercube estimate of Nr [count^2/kg^2]", "count^2/kg^2", zt ) - k = k + 1 - - case ( 'LH_rcp2_zt' ) - iLH_rcp2_zt = k - call stat_assign( iLH_rcp2_zt, "LH_rcp2_zt", & - "Variance of the latin hypercube estimate of rc [kg^2/kg^2]", "kg^2/kg^2", zt ) - k = k + 1 - - case ( 'LH_rtp2_zt' ) - iLH_rtp2_zt = k - call stat_assign( iLH_rtp2_zt, "LH_rtp2_zt", & - "Variance of the latin hypercube estimate of rt [kg^2/kg^2]", "kg^2/kg^2", zt ) - k = k + 1 - - case ( 'LH_thlp2_zt' ) - iLH_thlp2_zt = k - call stat_assign( iLH_thlp2_zt, "LH_thlp2_zt", & - "Variance of the latin hypercube estimate of thl [K^2]", "K^2", zt ) - k = k + 1 - - case ( 'LH_rrainp2_zt' ) - iLH_rrainp2_zt = k - call stat_assign( iLH_rrainp2_zt, "LH_rrainp2_zt", & - "Variance of the latin hypercube estimate of rrain [kg^2/kg^2]", "kg^2/kg^2", zt ) - k = k + 1 - - case ('C11_Skw_fnc') - iC11_Skw_fnc = k - - call stat_assign( iC11_Skw_fnc, "C11_Skw_fnc", & - "C_11 parameter with Sk_w applied [-]", "count", zt ) - k = k + 1 - - case ('s_mellor') - is_mellor = k - - call stat_assign( is_mellor, "s_mellor", & - "Mellor's s (extended liq) [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ( 'a3_coef_zt' ) - ia3_coef_zt = k - call stat_assign( ia3_coef_zt, "a3_coef_zt", & - "The a3 coefficient interpolated the the zt grid [-]", "count", zt ) - k = k + 1 - - case ( 'wp3_on_wp2_zt' ) - iwp3_on_wp2_zt = k - call stat_assign( iwp3_on_wp2_zt, "wp3_on_wp2_zt", & - "Smoothed version of wp3 / wp2 [m/s]", "m/s", zt ) - k = k + 1 - - case default - - l_found =.false. - - j=1 - - do while( j <= sclr_dim .and. .not. l_found) - write(sclr_idx, * ) j - - sclr_idx = adjustl(sclr_idx) - - if(trim(vars_zt(i)) == "sclr"//trim(sclr_idx)//"m" .and. .not. l_found) then - - isclrm(j) = k - - call stat_assign( isclrm(j) , "sclr"//trim(sclr_idx)//"m",& - "passive scalar "//trim(sclr_idx), "unknown", zt ) - - k = k + 1 - - l_found = .true. - - else if(trim(vars_zt(i)) == "sclr"//trim(sclr_idx)//"m_f" .and. .not. l_found) then - - isclrm_f(j) = k - - call stat_assign( isclrm_f(j) , "sclr"//trim(sclr_idx)//"m_f", & - "passive scalar forcing "//trim(sclr_idx), "unknown", zt ) - - k = k + 1 - - l_found = .true. - - endif - - j = j + 1 - end do - - j = 1 - - do while( j <= edsclr_dim .and. .not. l_found) - - write(sclr_idx, * ) j - - sclr_idx = adjustl(sclr_idx) - - if(trim(vars_zt(i)) == "edsclr"//trim(sclr_idx)//"m" .and. .not. l_found ) then - - iedsclrm(j) = k - - call stat_assign( iedsclrm(j) , "edsclr"//trim(sclr_idx)//"m", & - "passive scalar "//trim(sclr_idx), "unknown", zt ) - - k = k + 1 - - l_found = .true. - - else if(trim(vars_zt(i)) == "edsclr"//trim(sclr_idx)//"m_f" .and. .not. l_found) then - - iedsclrm_f(j) = k - - call stat_assign( iedsclrm_f(j) , "edsclr"//trim(sclr_idx)//"m_f", & - "passive scalar forcing "//trim(sclr_idx), "unknown", zt ) - - k = k + 1 - - l_found = .true. - - endif - - j = j + 1 - - end do - - if (.not. l_found ) then - - write(fstderr,*) 'Error: unrecognized variable in vars_zt: ', trim( vars_zt(i) ) - - l_error = .true. ! This will stop the run. - - end if - - end select - - end do - - return - end subroutine stats_init_zt - -end module stats_zt diff --git a/models/atm/cam/src/physics/clubb/stats_zt_module.F90 b/models/atm/cam/src/physics/clubb/stats_zt_module.F90 new file mode 100644 index 000000000000..971e544c170c --- /dev/null +++ b/models/atm/cam/src/physics/clubb/stats_zt_module.F90 @@ -0,0 +1,5025 @@ +!--------------------------------------------------------------------------- +! $Id: stats_zt_module.F90 7377 2014-11-11 02:43:45Z bmg2@uwm.edu $ +!=============================================================================== +module stats_zt_module + + implicit none + + private ! Default Scope + + public :: stats_init_zt + + ! Constant parameters + integer, parameter, public :: nvarmax_zt = 754 ! Maximum variables allowed + + contains + + !============================================================================= + subroutine stats_init_zt( vars_zt, l_error ) + + ! Description: + ! Initializes array indices for stats_zt + + ! Note: + ! All code that is within subroutine stats_init_zt, including variable + ! allocation code, is not called if l_stats is false. This subroutine is + ! called only when l_stats is true. + + !----------------------------------------------------------------------- + + use constants_clubb, only: & + fstderr ! Constant(s) + + use stats_variables, only: & + ithlm, & ! Variable(s) + iT_in_K, & + ithvm, & + irtm, & + ircm, & + irfrzm, & + irvm, & + ium, & + ivm, & + iwm_zt, & + ium_ref, & + ivm_ref, & + iug, & + ivg, & + icloud_frac, & + iice_supersat_frac, & + ircm_in_layer, & + ircm_in_cloud, & + icloud_cover, & + ip_in_Pa, & + iexner, & + irho_ds_zt, & + ithv_ds_zt, & + iLscale + + use stats_variables, only: & + iwp3, & ! Variable(s) + iwpthlp2, & + iwp2thlp, & + iwprtp2, & + iwp2rtp, & + iLscale_up, & + iLscale_down, & + itau_zt, & + iKh_zt, & + iwp2thvp, & + iwp2rcp, & + iwprtpthlp, & + isigma_sqd_w_zt, & + iSkw_zt + + use stats_variables, only: & + icorr_w_hm_ov_adj, & ! Variable(s) + ihm1, & + ihm2, & + iLWP1, & + iLWP2, & + iprecip_frac, & + iprecip_frac_1, & + iprecip_frac_2, & + iNcnm + + use stats_variables, only: & + imu_hm_1, & ! Variable(s) + imu_hm_2, & + imu_Ncn_1, & + imu_Ncn_2, & + imu_hm_1_n, & + imu_hm_2_n, & + imu_Ncn_1_n, & + imu_Ncn_2_n, & + isigma_hm_1, & + isigma_hm_2, & + isigma_Ncn_1, & + isigma_Ncn_2, & + isigma_hm_1_n, & + isigma_hm_2_n, & + isigma_Ncn_1_n, & + isigma_Ncn_2_n + + use stats_variables, only: & + icorr_w_chi_1, & ! Variable(s) + icorr_w_chi_2, & + icorr_w_eta_1, & + icorr_w_eta_2, & + icorr_w_hm_1, & + icorr_w_hm_2, & + icorr_w_Ncn_1, & + icorr_w_Ncn_2, & + icorr_chi_eta_1_ca, & + icorr_chi_eta_2_ca, & + icorr_chi_hm_1, & + icorr_chi_hm_2, & + icorr_chi_Ncn_1, & + icorr_chi_Ncn_2, & + icorr_eta_hm_1, & + icorr_eta_hm_2, & + icorr_eta_Ncn_1, & + icorr_eta_Ncn_2, & + icorr_Ncn_hm_1, & + icorr_Ncn_hm_2, & + icorr_hmx_hmy_1, & + icorr_hmx_hmy_2 + + use stats_variables, only: & + icorr_w_hm_1_n, & ! Variable(s) + icorr_w_hm_2_n, & + icorr_w_Ncn_1_n, & + icorr_w_Ncn_2_n, & + icorr_chi_hm_1_n, & + icorr_chi_hm_2_n, & + icorr_chi_Ncn_1_n, & + icorr_chi_Ncn_2_n, & + icorr_eta_hm_1_n, & + icorr_eta_hm_2_n, & + icorr_eta_Ncn_1_n, & + icorr_eta_Ncn_2_n, & + icorr_Ncn_hm_1_n, & + icorr_Ncn_hm_2_n, & + icorr_hmx_hmy_1_n, & + icorr_hmx_hmy_2_n + + use stats_variables, only: & + irel_humidity, & + irho, & + iNcm, & + iNc_in_cloud, & + iNc_activated, & + iNccnm, & + isnowslope, & + ised_rcm, & + irsat, & + irsati, & + irrm, & + iNrm, & + iprecip_rate_zt, & + iradht, & + iradht_LW, & + iradht_SW, & + idiam, & + imass_ice_cryst, & + ircm_icedfs, & + iu_T_cm, & + im_vol_rad_rain, & + im_vol_rad_cloud, & + irsm, & + irgm, & + irim + + use stats_variables, only: & + ieff_rad_cloud, & + ieff_rad_ice, & + ieff_rad_snow, & + ieff_rad_rain, & + ieff_rad_graupel + + use stats_variables, only: & + irtm_bt, & + irtm_ma, & + irtm_ta, & + irtm_forcing, & + irtm_mc, & + irtm_sdmp, & + ircm_mc, & + ircm_sd_mg_morr, & + irvm_mc, & + irtm_mfl, & + irtm_tacl, & + irtm_cl, & + irtm_pd, & + ithlm_bt, & + ithlm_ma, & + ithlm_ta, & + ithlm_forcing, & + ithlm_mc, & + ithlm_sdmp + + use stats_variables, only: & + ithlm_mfl, & + ithlm_tacl, & + ithlm_cl, & + iwp3_bt, & + iwp3_ma, & + iwp3_ta, & + iwp3_tp, & + iwp3_ac, & + iwp3_bp1, & + iwp3_bp2, & + iwp3_pr1, & + iwp3_pr2, & + iwp3_dp1, & + iwp3_cl + + ! Monotonic flux limiter diagnostic variables + use stats_variables, only: & + ithlm_mfl_min, & + ithlm_mfl_max, & + irtm_mfl_min, & + irtm_mfl_max, & + ithlm_enter_mfl, & + ithlm_exit_mfl, & + ithlm_old, & + ithlm_without_ta, & + irtm_enter_mfl, & + irtm_exit_mfl, & + irtm_old, & + irtm_without_ta + + use stats_variables, only: & + irrm_bt, & + irrm_ma, & + irrm_ta, & + irrm_sd, & + irrm_ts, & + irrm_sd_morr, & + irrm_cond, & + irrm_auto, & + irrm_accr, & + irrm_cond_adj, & + irrm_src_adj, & + irrm_mc, & + irrm_hf + + use stats_variables, only: & + irrm_wvhf, & + irrm_cl, & + iNrm_bt, & + iNrm_ma, & + iNrm_ta, & + iNrm_sd, & + iNrm_ts, & + iNrm_cond, & + iNrm_auto, & + iNrm_cond_adj, & + iNrm_src_adj, & + iNrm_mc, & + iNrm_cl + + use stats_variables, only: & + irsm_bt, & + irsm_ma, & + irsm_sd, & + irsm_sd_morr, & + irsm_ta, & + irsm_mc, & + irsm_hf, & + irsm_wvhf, & + irsm_cl, & + irgm_bt, & + irgm_ma, & + irgm_sd, & + irgm_sd_morr, & + irgm_ta, & + irgm_mc + + use stats_variables, only: & + irgm_hf, & + irgm_wvhf, & + irgm_cl, & + irim_bt, & + irim_ma, & + irim_sd, & + irim_sd_mg_morr, & + irim_ta, & + irim_mc, & + irim_hf, & + irim_wvhf, & + irim_cl + + use stats_variables, only: & + ivm_bt, & + ivm_ma, & + ivm_gf, & + ivm_cf, & + ivm_ta, & + ivm_f, & + ivm_sdmp, & + ivm_ndg, & + ium_bt, & + ium_ma, & + ium_gf, & + ium_cf, & + ium_ta, & + ium_f, & + ium_sdmp, & + ium_ndg + + use stats_variables, only: & + imixt_frac, & ! Variable(s) + iw_1, & + iw_2, & + ivarnce_w_1, & + ivarnce_w_2, & + ithl_1, & + ithl_2, & + ivarnce_thl_1, & + ivarnce_thl_2, & + irt_1, & + irt_2, & + ivarnce_rt_1, & + ivarnce_rt_2, & + irc_1, & + irc_2, & + irsatl_1, & + irsatl_2, & + icloud_frac_1, & + icloud_frac_2 + + use stats_variables, only: & + ichi_1, & + ichi_2, & + istdev_chi_1, & + istdev_chi_2, & + ichip2, & + istdev_eta_1, & + istdev_eta_2, & + icovar_chi_eta_1, & + icovar_chi_eta_2, & + icorr_chi_eta_1, & + icorr_chi_eta_2, & + irrtthl, & + icrt_1, & + icrt_2, & + icthl_1, & + icthl_2 + + use stats_variables, only: & + iwp2_zt, & + ithlp2_zt, & + iwpthlp_zt, & + iwprtp_zt, & + irtp2_zt, & + irtpthlp_zt, & + iup2_zt, & + ivp2_zt, & + iupwp_zt, & + ivpwp_zt + + use stats_variables, only: & + ihmp2_zt + + use stats_variables, only: & + stats_zt, & + isclrm, & + isclrm_f, & + iedsclrm, & + iedsclrm_f + + use stats_variables, only: & + iNsm, & ! Variable(s) + iNrm, & + iNgm, & + iNim, & + iNsm_bt, & + iNsm_mc, & + iNsm_ma, & + iNsm_ta, & + iNsm_sd, & + iNsm_cl, & + iNgm_bt, & + iNgm_mc, & + iNgm_ma, & + iNgm_ta, & + iNgm_sd, & + iNgm_cl, & + iNim_bt, & + iNim_mc, & + iNim_ma, & + iNim_ta, & + iNim_sd, & + iNim_cl + + use stats_variables, only: & + iNcm_bt, & + iNcm_mc, & + iNcm_ma, & + iNcm_ta, & + iNcm_cl, & + iNcm_act + + use stats_variables, only: & + iw_KK_evap_covar_zt, & + irt_KK_evap_covar_zt, & + ithl_KK_evap_covar_zt, & + iw_KK_auto_covar_zt, & + irt_KK_auto_covar_zt, & + ithl_KK_auto_covar_zt, & + iw_KK_accr_covar_zt, & + irt_KK_accr_covar_zt, & + ithl_KK_accr_covar_zt, & + irr_KK_mvr_covar_zt, & + iNr_KK_mvr_covar_zt, & + iKK_mvr_variance_zt + + use stats_variables, only: & + iC11_Skw_fnc, & ! Variable(s) + ichi, & + iwp3_on_wp2_zt, & + ia3_coef_zt + + use stats_variables, only: & + iLscale_pert_1, & ! Variable(s) + iLscale_pert_2 + + use stats_variables, only: & + iPSMLT, & ! Variable(s) + iEVPMS, & + iPRACS, & + iEVPMG, & + iPRACG, & + iPGMLT, & + iMNUCCC, & + iPSACWS, & + iPSACWI, & + iQMULTS, & + iQMULTG, & + iPSACWG, & + iPGSACW, & + iPRD, & + iPRCI, & + iPRAI, & + iQMULTR, & + iQMULTRG,& + iMNUCCD, & + iPRACI, & + iPRACIS, & + iEPRD, & + iMNUCCR, & + iPIACR, & + iPIACRS, & + iPGRACS, & + iPRDS, & + iEPRDS, & + iPSACR, & + iPRDG, & + iEPRDG + + use stats_variables, only: & + iNGSTEN, & ! Lots of variable(s) + iNRSTEN, & + iNISTEN, & + iNSSTEN, & + iNCSTEN, & + iNPRC1, & + iNRAGG, & + iNPRACG, & + iNSUBR, & + iNSMLTR, & + iNGMLTR, & + iNPRACS, & + iNNUCCR, & + iNIACR, & + iNIACRS, & + iNGRACS, & + iNSMLTS, & + iNSAGG, & + iNPRCI, & + iNSCNG, & + iNSUBS, & + iPRC, & + iPRA, & + iPRE + + use stats_variables, only: & + iPCC, & + iNNUCCC, & + iNPSACWS, & + iNPRA, & + iNPRC, & + iNPSACWI, & + iNPSACWG, & + iNPRAI, & + iNMULTS, & + iNMULTG, & + iNMULTR, & + iNMULTRG, & + iNNUCCD, & + iNSUBI, & + iNGMLTG, & + iNSUBG, & + iNACT, & + iSIZEFIX_NR, & + iSIZEFIX_NC, & + iSIZEFIX_NI, & + iSIZEFIX_NS, & + iSIZEFIX_NG, & + iNEGFIX_NR, & + iNEGFIX_NC, & + iNEGFIX_NI, & + iNEGFIX_NS, & + iNEGFIX_NG, & + iNIM_MORR_CL, & + iQC_INST, & + iQR_INST, & + iQI_INST, & + iQS_INST, & + iQG_INST, & + iNC_INST, & + iNR_INST, & + iNI_INST, & + iNS_INST, & + iNG_INST, & + iT_in_K_mc + + use stats_variables, only: & + iwp2hmp, & ! Variable(s) + icloud_frac_refined, & + ircm_refined, & + ihl_on_Cp_residual, & + iqto_residual + + use stats_type_utilities, only: & + stat_assign ! Procedure + + use parameters_model, only: & + hydromet_dim, & ! Variable(s) + sclr_dim, & + edsclr_dim + + use array_index, only: & + hydromet_list, & ! Variable(s) + l_mix_rat_hm + + implicit none + + ! External + intrinsic :: trim + + ! Local Constants + + ! Input Variable + character(len= * ), dimension(nvarmax_zt), intent(in) :: vars_zt + + ! Input / Output Variable + logical, intent(inout) :: l_error + + ! Local Varables + integer :: tot_zt_loops + + integer :: i, j, k + + integer :: hm_idx, hmx_idx, hmy_idx + + character(len=10) :: hm_type, hmx_type, hmy_type + + logical :: l_found + + character(len=50) :: sclr_idx + + + ! The default initialization for array indices for stats_zt is zero (see module + ! stats_variables) + + ! Allocate and initialize hydrometeor statistical variables. + allocate( icorr_w_hm_ov_adj(1:hydromet_dim) ) + allocate( ihm1(1:hydromet_dim) ) + allocate( ihm2(1:hydromet_dim) ) + allocate( imu_hm_1(1:hydromet_dim) ) + allocate( imu_hm_2(1:hydromet_dim) ) + allocate( imu_hm_1_n(1:hydromet_dim) ) + allocate( imu_hm_2_n(1:hydromet_dim) ) + allocate( isigma_hm_1(1:hydromet_dim) ) + allocate( isigma_hm_2(1:hydromet_dim) ) + allocate( isigma_hm_1_n(1:hydromet_dim) ) + allocate( isigma_hm_2_n(1:hydromet_dim) ) + + allocate( icorr_w_hm_1(1:hydromet_dim) ) + allocate( icorr_w_hm_2(1:hydromet_dim) ) + allocate( icorr_chi_hm_1(1:hydromet_dim) ) + allocate( icorr_chi_hm_2(1:hydromet_dim) ) + allocate( icorr_eta_hm_1(1:hydromet_dim) ) + allocate( icorr_eta_hm_2(1:hydromet_dim) ) + allocate( icorr_Ncn_hm_1(1:hydromet_dim) ) + allocate( icorr_Ncn_hm_2(1:hydromet_dim) ) + allocate( icorr_hmx_hmy_1(1:hydromet_dim,1:hydromet_dim) ) + allocate( icorr_hmx_hmy_2(1:hydromet_dim,1:hydromet_dim) ) + + allocate( icorr_w_hm_1_n(1:hydromet_dim) ) + allocate( icorr_w_hm_2_n(1:hydromet_dim) ) + allocate( icorr_chi_hm_1_n(1:hydromet_dim) ) + allocate( icorr_chi_hm_2_n(1:hydromet_dim) ) + allocate( icorr_eta_hm_1_n(1:hydromet_dim) ) + allocate( icorr_eta_hm_2_n(1:hydromet_dim) ) + allocate( icorr_Ncn_hm_1_n(1:hydromet_dim) ) + allocate( icorr_Ncn_hm_2_n(1:hydromet_dim) ) + allocate( icorr_hmx_hmy_1_n(1:hydromet_dim,1:hydromet_dim) ) + allocate( icorr_hmx_hmy_2_n(1:hydromet_dim,1:hydromet_dim) ) + + allocate( ihmp2_zt(1:hydromet_dim) ) + + allocate( iwp2hmp(1:hydromet_dim) ) + + icorr_w_hm_ov_adj(:) = 0 + ihm1(:) = 0 + ihm2(:) = 0 + imu_hm_1(:) = 0 + imu_hm_2(:) = 0 + imu_hm_1_n(:) = 0 + imu_hm_2_n(:) = 0 + isigma_hm_1(:) = 0 + isigma_hm_2(:) = 0 + isigma_hm_1_n(:) = 0 + isigma_hm_2_n(:) = 0 + + icorr_w_hm_1(:) = 0 + icorr_w_hm_2(:) = 0 + icorr_chi_hm_1(:) = 0 + icorr_chi_hm_2(:) = 0 + icorr_eta_hm_1(:) = 0 + icorr_eta_hm_2(:) = 0 + icorr_Ncn_hm_1(:) = 0 + icorr_Ncn_hm_2(:) = 0 + icorr_hmx_hmy_1(:,:) = 0 + icorr_hmx_hmy_2(:,:) = 0 + + icorr_w_hm_1_n(:) = 0 + icorr_w_hm_2_n(:) = 0 + icorr_chi_hm_1_n(:) = 0 + icorr_chi_hm_2_n(:) = 0 + icorr_eta_hm_1_n(:) = 0 + icorr_eta_hm_2_n(:) = 0 + icorr_Ncn_hm_1_n(:) = 0 + icorr_Ncn_hm_2_n(:) = 0 + icorr_hmx_hmy_1_n(:,:) = 0 + icorr_hmx_hmy_2_n(:,:) = 0 + + ihmp2_zt(:) = 0 + + iwp2hmp(:) = 0 + + ! Allocate and then zero out passive scalar arrays + allocate( isclrm(1:sclr_dim) ) + allocate( isclrm_f(1:sclr_dim) ) + + isclrm(:) = 0 + isclrm_f(:) = 0 + + allocate( iedsclrm(1:edsclr_dim) ) + allocate( iedsclrm_f(1:edsclr_dim) ) + + iedsclrm(:) = 0 + iedsclrm_f(:) = 0 + + ! Assign pointers for statistics variables stats_zt using stat_assign + + tot_zt_loops = stats_zt%num_output_fields + + if ( any( vars_zt == "corr_w_hm_ov_adj" ) ) then + ! Correct for number of variables found under "corr_w_hm_ov_adj". + ! Subtract 1 from the loop size for each hydrometeor. + tot_zt_loops = tot_zt_loops - hydromet_dim + ! Add 1 for "corr_w_hm_ov_adj" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "hmi" ) ) then + ! Correct for number of variables found under "hmi". + ! Subtract 2 from the loop size (1st PDF component and 2nd PDF component) + ! for each hydrometeor. + tot_zt_loops = tot_zt_loops - 2 * hydromet_dim + ! Add 1 for "hmi" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "mu_hm_i" ) ) then + ! Correct for number of variables found under "mu_hm_i". + ! Subtract 2 from the loop size (1st PDF component and 2nd PDF component) + ! for each hydrometeor. + tot_zt_loops = tot_zt_loops - 2 * hydromet_dim + ! Add 1 for "mu_hm_i" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "mu_Ncn_i" ) ) then + ! Correct for number of variables found under "mu_Ncn_i". + ! Subtract 2 from the loop size (1st PDF comp. and 2nd PDF comp.). + tot_zt_loops = tot_zt_loops - 2 + ! Add 1 for "mu_Ncn_i" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "mu_hm_i_n" ) ) then + ! Correct for number of variables found under "mu_hm_i_n". + ! Subtract 2 from the loop size (1st PDF component and 2nd PDF component) + ! for each hydrometeor. + tot_zt_loops = tot_zt_loops - 2 * hydromet_dim + ! Add 1 for "mu_hm_i_n" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "mu_Ncn_i_n" ) ) then + ! Correct for number of variables found under "mu_Ncn_i_n". + ! Subtract 2 from the loop size (1st PDF comp. and 2nd PDF comp.). + tot_zt_loops = tot_zt_loops - 2 + ! Add 1 for "mu_Ncn_i_n" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "sigma_hm_i" ) ) then + ! Correct for number of variables found under "sigma_hm_i". + ! Subtract 2 from the loop size (1st PDF component and 2nd PDF component) + ! for each hydrometeor. + tot_zt_loops = tot_zt_loops - 2 * hydromet_dim + ! Add 1 for "sigma_hm_i" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "sigma_Ncn_i" ) ) then + ! Correct for number of variables found under "sigma_Ncn_i". + ! Subtract 2 from the loop size (1st PDF comp. and 2nd PDF comp.). + tot_zt_loops = tot_zt_loops - 2 + ! Add 1 for "sigma_Ncn_i" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "sigma_hm_i_n" ) ) then + ! Correct for number of variables found under "sigma_hm_i_n". + ! Subtract 2 from the loop size (1st PDF component and 2nd PDF component) + ! for each hydrometeor. + tot_zt_loops = tot_zt_loops - 2 * hydromet_dim + ! Add 1 for "sigma_hm_i_n" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "sigma_Ncn_i_n" ) ) then + ! Correct for number of variables found under "sigma_Ncn_i_n". + ! Subtract 2 from the loop size (1st PDF comp. and 2nd PDF comp.). + tot_zt_loops = tot_zt_loops - 2 + ! Add 1 for "sigma_Ncn_i_n" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + + if ( any( vars_zt == "corr_w_hm_i" ) ) then + ! Correct for number of variables found under "corr_whm_i". + ! Subtract 2 from the loop size (1st PDF component and 2nd PDF component) + ! for each hydrometeor. + tot_zt_loops = tot_zt_loops - 2 * hydromet_dim + ! Add 1 for "corr_whm_i" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "corr_w_Ncn_i" ) ) then + ! Correct for number of variables found under "corr_wNcn_i". + ! Subtract 2 from the loop size (1st PDF comp. and 2nd PDF comp.). + tot_zt_loops = tot_zt_loops - 2 + ! Add 1 for "corr_wNcn_i" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "corr_chi_hm_i" ) ) then + ! Correct for number of variables found under "corr_chi_hm_i". + ! Subtract 2 from the loop size (1st PDF component and 2nd PDF component) + ! for each hydrometeor. + tot_zt_loops = tot_zt_loops - 2 * hydromet_dim + ! Add 1 for "corr_chi_hm_i" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "corr_chi_Ncn_i" ) ) then + ! Correct for number of variables found under "corr_chi_Ncn_i". + ! Subtract 2 from the loop size (1st PDF comp. and 2nd PDF comp.). + tot_zt_loops = tot_zt_loops - 2 + ! Add 1 for "corr_chi_Ncn_i" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "corr_eta_hm_i" ) ) then + ! Correct for number of variables found under "corr_eta_hm_i". + ! Subtract 2 from the loop size (1st PDF component and 2nd PDF component) + ! for each hydrometeor. + tot_zt_loops = tot_zt_loops - 2 * hydromet_dim + ! Add 1 for "corr_eta_hm_i" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "corr_eta_Ncn_i" ) ) then + ! Correct for number of variables found under "corr_eta_Ncn_i". + ! Subtract 2 from the loop size (1st PDF comp. and 2nd PDF comp.). + tot_zt_loops = tot_zt_loops - 2 + ! Add 1 for "corr_eta_Ncn_i" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "corr_Ncn_hm_i" ) ) then + ! Correct for number of variables found under "corr_Ncnhm_i". + ! Subtract 2 from the loop size (1st PDF component and 2nd PDF component) + ! for each hydrometeor. + tot_zt_loops = tot_zt_loops - 2 * hydromet_dim + ! Add 1 for "corr_Ncnhm_i" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "corr_hmx_hmy_i" ) ) then + ! Correct for number of variables found under "corr_hmxhmy_i". + ! Subtract 2 (1st PDF component and 2nd PDF component) multipled by the + ! number of correlations of two hydrometeors, which is found by: + ! (1/2) * hydromet_dim * ( hydromet_dim - 1 ); from the loop size. + tot_zt_loops = tot_zt_loops - hydromet_dim * ( hydromet_dim - 1 ) + ! Add 1 for "corr_hmxhmy_i" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + + if ( any( vars_zt == "corr_w_hm_i_n" ) ) then + ! Correct for number of variables found under "corr_whm_i_n". + ! Subtract 2 from the loop size (1st PDF component and 2nd PDF component) + ! for each hydrometeor. + tot_zt_loops = tot_zt_loops - 2 * hydromet_dim + ! Add 1 for "corr_whm_i_n" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "corr_w_Ncn_i_n" ) ) then + ! Correct for number of variables found under "corr_wNcn_i_n". + ! Subtract 2 from the loop size (1st PDF comp. and 2nd PDF comp.). + tot_zt_loops = tot_zt_loops - 2 + ! Add 1 for "corr_wNcn_i_n" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "corr_chi_hm_i_n" ) ) then + ! Correct for number of variables found under "corr_chi_hm_i_n". + ! Subtract 2 from the loop size (1st PDF component and 2nd PDF component) + ! for each hydrometeor. + tot_zt_loops = tot_zt_loops - 2 * hydromet_dim + ! Add 1 for "corr_chi_hm_i_n" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "corr_chi_Ncn_i_n" ) ) then + ! Correct for number of variables found under "corr_chi_Ncn_i_n". + ! Subtract 2 from the loop size (1st PDF comp. and 2nd PDF comp.). + tot_zt_loops = tot_zt_loops - 2 + ! Add 1 for "corr_chi_Ncn_i_n" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "corr_eta_hm_i_n" ) ) then + ! Correct for number of variables found under "corr_eta_hm_i_n". + ! Subtract 2 from the loop size (1st PDF component and 2nd PDF component) + ! for each hydrometeor. + tot_zt_loops = tot_zt_loops - 2 * hydromet_dim + ! Add 1 for "corr_eta_hm_i_n" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "corr_eta_Ncn_i_n" ) ) then + ! Correct for number of variables found under "corr_eta_Ncn_i_n". + ! Subtract 2 from the loop size (1st PDF comp. and 2nd PDF comp.). + tot_zt_loops = tot_zt_loops - 2 + ! Add 1 for "corr_eta_Ncn_i_n" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "corr_Ncn_hm_i_n" ) ) then + ! Correct for number of variables found under "corr_Ncnhm_i_n". + ! Subtract 2 from the loop size (1st PDF component and 2nd PDF component) + ! for each hydrometeor. + tot_zt_loops = tot_zt_loops - 2 * hydromet_dim + ! Add 1 for "corr_Ncnhm_i_n" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "corr_hmx_hmy_i_n" ) ) then + ! Correct for number of variables found under "corr_hmxhmy_i_n". + ! Subtract 2 (1st PDF component and 2nd PDF component) multipled by the + ! number of normalized correlations of two hydrometeors, which is found + ! by: (1/2) * hydromet_dim * ( hydromet_dim - 1 ); + ! from the loop size. + tot_zt_loops = tot_zt_loops - hydromet_dim * ( hydromet_dim - 1 ) + ! Add 1 for "corr_hmxhmy_i_n" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + + if ( any( vars_zt == "hmp2_zt" ) ) then + ! Correct for number of variables found under "hmp2_zt". + ! Subtract 1 from the loop size for each hydrometeor. + tot_zt_loops = tot_zt_loops - hydromet_dim + ! Add 1 for "hmp2_zt" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + + if ( any( vars_zt == "wp2hmp" ) ) then + ! Correct for number of variables found under "wp2hmp". + ! Subtract 1 from the loop size for each hydrometeor. + tot_zt_loops = tot_zt_loops - hydromet_dim + ! Add 1 for "wp2hmp" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + + k = 1 + + do i = 1, tot_zt_loops + + select case ( trim( vars_zt(i) ) ) + case ('thlm') + ithlm = k + call stat_assign( var_index=ithlm, var_name="thlm", & + var_description="Liquid water potential temperature (theta_l) [K]", var_units="K", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('T_in_K') + iT_in_K = k + call stat_assign( var_index=iT_in_K, var_name="T_in_K", & + var_description="Absolute temperature [K]", var_units="K", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('thvm') + ithvm = k + call stat_assign( var_index=ithvm, var_name="thvm", & + var_description="Virtual potential temperature [K]", var_units="K", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('rtm') + irtm = k + + call stat_assign( var_index=irtm, var_name="rtm", & + var_description="Total (vapor+liquid) water mixing ratio [kg/kg]", & + var_units="kg/kg", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('rcm') + ircm = k + call stat_assign( var_index=ircm, var_name="rcm", & + var_description="Cloud water mixing ratio [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rfrzm') + irfrzm = k + call stat_assign( var_index=irfrzm, var_name="rfrzm", & + var_description="Total ice phase water mixing ratio [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rvm') + irvm = k + call stat_assign( var_index=irvm, var_name="rvm", & + var_description="Vapor water mixing ratio [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + case ('rel_humidity') + irel_humidity = k + call stat_assign( var_index=irel_humidity, var_name="rel_humidity", & + var_description="Relative humidity w.r.t. liquid (range [0,1]) [-]", & + var_units="[-]", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + case ('um') + ium = k + call stat_assign( var_index=ium, var_name="um", & + var_description="East-west (u) wind [m/s]", var_units="m/s", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + case ('vm') + ivm = k + call stat_assign( var_index=ivm, var_name="vm", & + var_description="North-south (v) wind [m/s]", var_units="m/s", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + case ('wm_zt') + iwm_zt = k + call stat_assign( var_index=iwm_zt, var_name="wm", & + var_description="Vertical (w) wind [m/s]", var_units="m/s", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + case ('um_ref') + ium_ref = k + call stat_assign( var_index=ium_ref, var_name="um_ref", & + var_description="reference u wind (m/s) [m/s]", var_units="m/s", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + case ('vm_ref') + ivm_ref = k + call stat_assign( var_index=ivm_ref, var_name="vm_ref", & + var_description="reference v wind (m/s) [m/s]", var_units="m/s", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + case ('ug') + iug = k + call stat_assign( var_index=iug, var_name="ug", & + var_description="u geostrophic wind [m/s]", var_units="m/s", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + case ('vg') + ivg = k + call stat_assign( var_index=ivg, var_name="vg", & + var_description="v geostrophic wind [m/s]", var_units="m/s", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + case ('cloud_frac') + icloud_frac = k + call stat_assign( var_index=icloud_frac, var_name="cloud_frac", & + var_description="Cloud fraction (between 0 and 1) [-]", var_units="count", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('ice_supersat_frac') + iice_supersat_frac = k + call stat_assign( var_index=iice_supersat_frac, var_name="ice_supersat_frac", & + var_description="Ice cloud fraction (between 0 and 1) [-]", var_units="count", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rcm_in_layer') + ircm_in_layer = k + call stat_assign( var_index=ircm_in_layer, var_name="rcm_in_layer", & + var_description="rcm in cloud layer [kg/kg]", var_units="kg/kg", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('rcm_in_cloud') + ircm_in_cloud = k + call stat_assign( var_index=ircm_in_cloud, var_name="rcm_in_cloud", & + var_description="in-cloud value of rcm (for microphysics) [kg/kg]", & + var_units="kg/kg", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('cloud_cover') + icloud_cover = k + call stat_assign( var_index=icloud_cover, var_name="cloud_cover", & + var_description="Cloud cover (between 0 and 1) [-]", var_units="count", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + case ('p_in_Pa') + ip_in_Pa = k + call stat_assign( var_index=ip_in_Pa, var_name="p_in_Pa", & + var_description="Pressure [Pa]", var_units="Pa", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + case ('exner') + iexner = k + call stat_assign( var_index=iexner, var_name="exner", & + var_description="Exner function = (p/p0)**(rd/cp) [-]", var_units="count", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + case ('rho_ds_zt') + irho_ds_zt = k + call stat_assign( var_index=irho_ds_zt, var_name="rho_ds_zt", & + var_description="Dry, static, base-state density [kg/m^3]", var_units="kg m^{-3}", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + case ('thv_ds_zt') + ithv_ds_zt = k + call stat_assign( var_index=ithv_ds_zt, var_name="thv_ds_zt", & + var_description="Dry, base-state theta_v [K]", var_units="K", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + case ('Lscale') + iLscale = k + call stat_assign( var_index=iLscale, var_name="Lscale", & + var_description="Mixing length [m]", var_units="m", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + case ('thlm_forcing') + ithlm_forcing = k + call stat_assign( var_index=ithlm_forcing, var_name="thlm_forcing", & + var_description="thlm budget: thetal forcing (includes thlm_mc and radht) [K s^{-1}]",& + var_units="K s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + case ('thlm_mc') + ithlm_mc = k + call stat_assign( var_index=ithlm_mc, var_name="thlm_mc", & + var_description="Change in thlm due to microphysics (not in budget) [K s^{-1}]", & + var_units="K s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + case ('rtm_forcing') + irtm_forcing = k + call stat_assign( var_index=irtm_forcing, var_name="rtm_forcing", & + var_description="rtm budget: rt forcing (includes rtm_mc) [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rtm_mc') + irtm_mc = k + call stat_assign( var_index=irtm_mc, var_name="rtm_mc", & + var_description="Change in rt due to microphysics (not in budget) & + &[kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rvm_mc') + irvm_mc = k + call stat_assign( var_index=irvm_mc, var_name="rvm_mc", & + var_description="Time tendency of vapor mixing ratio due to microphysics [kg/kg/s]", & + var_units="kg/(kg s)", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rcm_mc') + ircm_mc = k + call stat_assign( var_index=ircm_mc, var_name="rcm_mc", & + var_description="Time tendency of liquid water mixing ratio due microphysics & + &[kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rcm_sd_mg_morr') + ircm_sd_mg_morr = k + call stat_assign( var_index=ircm_sd_mg_morr, var_name="rcm_sd_mg_morr", & + var_description="rcm sedimentation when using morrision or MG microphysics & + &(not in budget, included in rcm_mc) [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('thlm_mfl_min') + ithlm_mfl_min = k + call stat_assign( var_index=ithlm_mfl_min, var_name="thlm_mfl_min", & + var_description="Minimum allowable thlm [K]", var_units="K", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('thlm_mfl_max') + ithlm_mfl_max = k + call stat_assign( var_index=ithlm_mfl_max, var_name="thlm_mfl_max", & + var_description="Maximum allowable thlm [K]", var_units="K", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('thlm_enter_mfl') + ithlm_enter_mfl = k + call stat_assign( var_index=ithlm_enter_mfl, var_name="thlm_enter_mfl", & + var_description="Thlm before flux-limiter [K]", var_units="K", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('thlm_exit_mfl') + ithlm_exit_mfl = k + call stat_assign( var_index=ithlm_exit_mfl, var_name="thlm_exit_mfl", & + var_description="Thlm exiting flux-limiter [K]", var_units="K", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('thlm_old') + ithlm_old = k + call stat_assign( var_index=ithlm_old, var_name="thlm_old", & + var_description="Thlm at previous timestep [K]", var_units="K", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('thlm_without_ta') + ithlm_without_ta = k + call stat_assign( var_index=ithlm_without_ta, var_name="thlm_without_ta", & + var_description="Thlm without turbulent advection contribution [K]", var_units="K", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rtm_mfl_min') + irtm_mfl_min = k + call stat_assign( var_index=irtm_mfl_min, var_name="rtm_mfl_min", & + var_description="Minimum allowable rtm [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rtm_mfl_max') + irtm_mfl_max = k + call stat_assign( var_index=irtm_mfl_max, var_name="rtm_mfl_max", & + var_description="Maximum allowable rtm [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rtm_enter_mfl') + irtm_enter_mfl = k + call stat_assign( var_index=irtm_enter_mfl, var_name="rtm_enter_mfl", & + var_description="Rtm before flux-limiter [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rtm_exit_mfl') + irtm_exit_mfl = k + call stat_assign( var_index=irtm_exit_mfl, var_name="rtm_exit_mfl", & + var_description="Rtm exiting flux-limiter [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rtm_old') + irtm_old = k + call stat_assign( var_index=irtm_old, var_name="rtm_old", & + var_description="Rtm at previous timestep [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rtm_without_ta') + irtm_without_ta = k + call stat_assign( var_index=irtm_without_ta, var_name="rtm_without_ta", & + var_description="Rtm without turbulent advection contribution [kg/kg]", & + var_units="kg/kg", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('wp3') + iwp3 = k + call stat_assign( var_index=iwp3, var_name="wp3", & + var_description="w third order moment [m^3/s^3]", var_units="m^3/s^3", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('wpthlp2') + iwpthlp2 = k + call stat_assign( var_index=iwpthlp2, var_name="wpthlp2", & + var_description="w'thl'^2 [(m K^2)/s]", var_units="(m K^2)/s", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('wp2thlp') + iwp2thlp = k + call stat_assign( var_index=iwp2thlp, var_name="wp2thlp", & + var_description="w'^2thl' [(m^2 K)/s^2]", var_units="(m^2 K)/s^2", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('wprtp2') + iwprtp2 = k + call stat_assign( var_index=iwprtp2, var_name="wprtp2", & + var_description="w'rt'^2 [(m kg)/(s kg)]", var_units="(m kg)/(s kg)", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('wp2rtp') + iwp2rtp = k + call stat_assign( var_index=iwp2rtp, var_name="wp2rtp", & + var_description="w'^2rt' [(m^2 kg)/(s^2 kg)]", var_units="(m^2 kg)/(s^2 kg)", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Lscale_up') + iLscale_up = k + call stat_assign( var_index=iLscale_up, var_name="Lscale_up", & + var_description="Upward mixing length [m]", var_units="m", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('Lscale_down') + iLscale_down = k + call stat_assign( var_index=iLscale_down, var_name="Lscale_down", & + var_description="Downward mixing length [m]", var_units="m", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('Lscale_pert_1') + iLscale_pert_1 = k + call stat_assign( var_index=iLscale_pert_1, var_name="Lscale_pert_1", & + var_description="Mixing length using a perturbed value of rtm/thlm [m]", & + var_units="m", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Lscale_pert_2') + iLscale_pert_2 = k + call stat_assign( var_index=iLscale_pert_2, var_name="Lscale_pert_2", & + var_description="Mixing length using a perturbed value of rtm/thlm [m]", & + var_units="m", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('tau_zt') + itau_zt = k + call stat_assign( var_index=itau_zt, var_name="tau_zt", & + var_description="Dissipation time [s]", var_units="s", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('Kh_zt') + iKh_zt = k + call stat_assign( var_index=iKh_zt, var_name="Kh_zt", & + var_description="Eddy diffusivity [m^2/s]", var_units="m^2/s", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('wp2thvp') + iwp2thvp = k + call stat_assign( var_index=iwp2thvp, var_name="wp2thvp", & + var_description="w'^2thv' [K m^2/s^2]", var_units="K m^2/s^2", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('wp2rcp') + iwp2rcp = k + call stat_assign( var_index=iwp2rcp, var_name="wp2rcp", & + var_description="w'^2rc' [(m^2 kg)/(s^2 kg)]", var_units="(m^2 kg)/(s^2 kg)", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('wprtpthlp') + iwprtpthlp = k + call stat_assign( var_index=iwprtpthlp, var_name="wprtpthlp", & + var_description="w'rt'thl' [(m kg K)/(s kg)]", var_units="(m kg K)/(s kg)", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('sigma_sqd_w_zt') + isigma_sqd_w_zt = k + call stat_assign( var_index=isigma_sqd_w_zt, var_name="sigma_sqd_w_zt", & + var_description="Nondimensionalized w variance of Gaussian component [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rho') + irho = k + call stat_assign( var_index=irho, var_name="rho", var_description="Air density [kg/m^3]", & + var_units="kg m^{-3}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Ncm') ! Brian + iNcm = k + call stat_assign( var_index=iNcm, var_name="Ncm", & + var_description="Cloud droplet number concentration [num/kg]", var_units="num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nc_in_cloud') + iNc_in_cloud = k + + call stat_assign( var_index=iNc_in_cloud, var_name="Nc_in_cloud", & + var_description="In cloud droplet concentration [num/kg]", var_units="num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Nc_activated') + iNc_activated = k + + call stat_assign( var_index=iNc_activated, var_name="Nc_activated", & + var_description="Droplets activated by GFDL activation [num/kg]", & + var_units="num/kg", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Nccnm') + iNccnm = k + call stat_assign( var_index=iNccnm, var_name="Nccnm", & + var_description="Cloud condensation nuclei concentration (COAMPS/MG) [num/kg]", & + var_units="num/kg", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nim') ! Brian + iNim = k + call stat_assign( var_index=iNim, var_name="Nim", & + var_description="Ice crystal number concentration [num/kg]", var_units="num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('snowslope') ! Adam Smith, 22 April 2008 + isnowslope = k + call stat_assign( var_index=isnowslope, var_name="snowslope", & + var_description="COAMPS microphysics snow slope parameter [1/m]", var_units="1/m", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nsm') ! Adam Smith, 22 April 2008 + iNsm = k + call stat_assign( var_index=iNsm, var_name="Nsm", & + var_description="Snow particle number concentration [num/kg]", var_units="num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Ngm') + iNgm = k + call stat_assign( var_index=iNgm, var_name="Ngm", & + var_description="Graupel number concentration [num/kg]", var_units="num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('sed_rcm') ! Brian + ised_rcm = k + call stat_assign( var_index=ised_rcm, var_name="sed_rcm", & + var_description="d(rcm)/dt due to cloud sedimentation [kg / (m^2 s)]", & + var_units="kg / [m^2 s]", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rsat') ! Brian + irsat = k + call stat_assign( var_index=irsat, var_name="rsat", & + var_description="Saturation mixing ratio over liquid [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rsati') + irsati = k + call stat_assign( var_index=irsati, var_name="rsati", & + var_description="Saturation mixing ratio over ice [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm') ! Brian + irrm = k + call stat_assign( var_index=irrm, var_name="rrm", & + var_description="Rain water mixing ratio [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rsm') + irsm = k + call stat_assign( var_index=irsm, var_name="rsm", & + var_description="Snow water mixing ratio [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rim') + irim = k + call stat_assign( var_index=irim, var_name="rim", & + var_description="Pristine ice water mixing ratio [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rgm') + irgm = k + call stat_assign( var_index=irgm, var_name="rgm", & + var_description="Graupel water mixing ratio [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nrm') ! Brian + iNrm = k + call stat_assign( var_index=iNrm, var_name="Nrm", & + var_description="Rain drop number concentration [num/kg]", var_units="num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('m_vol_rad_rain') ! Brian + im_vol_rad_rain = k + call stat_assign( var_index=im_vol_rad_rain, var_name="mvrr", & + var_description="Rain drop mean volume radius [m]", var_units="m", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('m_vol_rad_cloud') + im_vol_rad_cloud = k + call stat_assign( var_index=im_vol_rad_cloud, var_name="m_vol_rad_cloud", & + var_description="Cloud drop mean volume radius [m]", var_units="m", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('eff_rad_cloud') + ieff_rad_cloud = k + call stat_assign( var_index=ieff_rad_cloud, var_name="eff_rad_cloud", & + var_description="Cloud drop effective volume radius [microns]", var_units="microns", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('eff_rad_ice') + ieff_rad_ice = k + + call stat_assign( var_index=ieff_rad_ice, var_name="eff_rad_ice", & + var_description="Ice effective volume radius [microns]", var_units="microns", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('eff_rad_snow') + ieff_rad_snow = k + call stat_assign( var_index=ieff_rad_snow, var_name="eff_rad_snow", & + var_description="Snow effective volume radius [microns]", var_units="microns", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('eff_rad_rain') + ieff_rad_rain = k + call stat_assign( var_index=ieff_rad_rain, var_name="eff_rad_rain", & + var_description="Rain drop effective volume radius [microns]", var_units="microns", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('eff_rad_graupel') + ieff_rad_graupel = k + call stat_assign( var_index=ieff_rad_graupel, var_name="eff_rad_graupel", & + var_description="Graupel effective volume radius [microns]", var_units="microns", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('precip_rate_zt') ! Brian + iprecip_rate_zt = k + + call stat_assign( var_index=iprecip_rate_zt, var_name="precip_rate_zt", & + var_description="Rain rate [mm/day]", var_units="mm/day", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('radht') + iradht = k + + call stat_assign( var_index=iradht, var_name="radht", & + var_description="Total (sw+lw) radiative heating rate [K/s]", var_units="K/s", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('radht_LW') + iradht_LW = k + + call stat_assign( var_index=iradht_LW, var_name="radht_LW", & + var_description="Long-wave radiative heating rate [K/s]", var_units="K/s", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('radht_SW') + iradht_SW = k + call stat_assign( var_index=iradht_SW, var_name="radht_SW", & + var_description="Short-wave radiative heating rate [K/s]", var_units="K/s", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('diam') + idiam = k + + call stat_assign( var_index=idiam, var_name="diam", & + var_description="Ice crystal diameter [m]", var_units="m", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('mass_ice_cryst') + imass_ice_cryst = k + call stat_assign( var_index=imass_ice_cryst, var_name="mass_ice_cryst", & + var_description="Mass of a single ice crystal [kg]", var_units="kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rcm_icedfs') + + ircm_icedfs = k + call stat_assign( var_index=ircm_icedfs, var_name="rcm_icedfs", & + var_description="Change in liquid due to ice [kg/kg/s]", var_units="kg/kg/s", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('u_T_cm') + iu_T_cm = k + call stat_assign( var_index=iu_T_cm, var_name="u_T_cm", & + var_description="Ice crystal fallspeed [cm s^{-1}]", var_units="cm s^{-1}", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rtm_bt') + irtm_bt = k + + call stat_assign( var_index=irtm_bt, var_name="rtm_bt", & + var_description="rtm budget: rtm time tendency [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rtm_ma') + irtm_ma = k + + call stat_assign( var_index=irtm_ma, var_name="rtm_ma", & + var_description="rtm budget: rtm vertical mean advection [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rtm_ta') + irtm_ta = k + + call stat_assign( var_index=irtm_ta, var_name="rtm_ta", & + var_description="rtm budget: rtm turbulent advection [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rtm_mfl') + irtm_mfl = k + + call stat_assign( var_index=irtm_mfl, var_name="rtm_mfl", & + var_description="rtm budget: rtm correction due to monotonic flux limiter & + &[kg kg^{-1} s^{-1}]", var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt) + k = k + 1 + + case ('rtm_tacl') + irtm_tacl = k + + call stat_assign( var_index=irtm_tacl, var_name="rtm_tacl", & + var_description="rtm budget: rtm correction due to ta term (wprtp) clipping & + &[kg kg^{-1} s^{-1}]", var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt) + + k = k + 1 + + case ('rtm_cl') + irtm_cl = k + + call stat_assign( var_index=irtm_cl, var_name="rtm_cl", & + var_description="rtm budget: rtm clipping [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + case ('rtm_sdmp') + irtm_sdmp = k + + call stat_assign( var_index=irtm_sdmp, var_name="rtm_sdmp", & + var_description="rtm budget: rtm correction due to sponge damping & + &[kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + + case ('rtm_pd') + irtm_pd = k + + call stat_assign( var_index=irtm_pd, var_name="rtm_pd", & + var_description="rtm budget: rtm positive definite adjustment [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('thlm_bt') + ithlm_bt = k + + call stat_assign( var_index=ithlm_bt, var_name="thlm_bt", & + var_description="thlm budget: thlm time tendency [K s^{-1}]", var_units="K s^{-1}", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('thlm_ma') + ithlm_ma = k + + call stat_assign( var_index=ithlm_ma, var_name="thlm_ma", & + var_description="thlm budget: thlm vertical mean advection [K s^{-1}]", & + var_units="K s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('thlm_sdmp') + ithlm_sdmp = k + + call stat_assign( var_index=ithlm_sdmp, var_name="thlm_sdmp", & + var_description="thlm budget: thlm correction due to sponge damping [K s^{-1}]", & + var_units="K s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + + case ('thlm_ta') + ithlm_ta = k + + call stat_assign( var_index=ithlm_ta, var_name="thlm_ta", & + var_description="thlm budget: thlm turbulent advection [K s^{-1}]", & + var_units="K s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('thlm_mfl') + ithlm_mfl = k + + call stat_assign( var_index=ithlm_mfl, var_name="thlm_mfl", & + var_description="thlm budget: thlm correction due to monotonic flux limiter & + &[K s^{-1}]", & + var_units="K s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('thlm_tacl') + ithlm_tacl = k + + call stat_assign( var_index=ithlm_tacl, var_name="thlm_tacl", & + var_description="thlm budget: thlm correction due to ta term (wpthlp) clipping & + &[K s^{-1}]", & + var_units="K s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('thlm_cl') + ithlm_cl = k + + call stat_assign( var_index=ithlm_cl, var_name="thlm_cl", & + var_description="thlm budget: thlm_cl [K s^{-1}]", var_units="K s^{-1}", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('wp3_bt') + iwp3_bt = k + + call stat_assign( var_index=iwp3_bt, var_name="wp3_bt", & + var_description="wp3 budget: wp3 time tendency [m^{3} s^{-4}]", & + var_units="m^{3} s^{-4}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('wp3_ma') + iwp3_ma = k + + call stat_assign( var_index=iwp3_ma, var_name="wp3_ma", & + var_description="wp3 budget: wp3 vertical mean advection [m^{3} s^{-4}]", & + var_units="m^{3} s^{-4}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('wp3_ta') + iwp3_ta = k + + call stat_assign( var_index=iwp3_ta, var_name="wp3_ta", & + var_description="wp3 budget: wp3 turbulent advection [m^{3} s^{-4}]", & + var_units="m^{3} s^{-4}", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('wp3_tp') + iwp3_tp = k + call stat_assign( var_index=iwp3_tp, var_name="wp3_tp", & + var_description="wp3 budget: wp3 turbulent transport [m^{3} s^{-4}]", & + var_units="m^{3} s^{-4}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('wp3_ac') + iwp3_ac = k + call stat_assign( var_index=iwp3_ac, var_name="wp3_ac", & + var_description="wp3 budget: wp3 accumulation term [m^{3} s^{-4}]", & + var_units="m^{3} s^{-4}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('wp3_bp1') + iwp3_bp1 = k + call stat_assign( var_index=iwp3_bp1, var_name="wp3_bp1", & + var_description="wp3 budget: wp3 buoyancy production [m^{3} s^{-4}]", & + var_units="m^{3} s^{-4}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('wp3_bp2') + iwp3_bp2 = k + call stat_assign( var_index=iwp3_bp2, var_name="wp3_bp2", & + var_description="wp3 budget: wp3 2nd buoyancy production term [m^{3} s^{-4}]", & + var_units="m^{3} s^{-4}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('wp3_pr1') + iwp3_pr1 = k + call stat_assign( var_index=iwp3_pr1, var_name="wp3_pr1", & + var_description="wp3 budget: wp3 pressure term 1 [m^{3} s^{-4}]", & + var_units="m^{3} s^{-4}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('wp3_pr2') + iwp3_pr2 = k + call stat_assign( var_index=iwp3_pr2, var_name="wp3_pr2", & + var_description="wp3 budget: wp3 pressure term 2 [m^{3} s^{-4}]", & + var_units="m^{3} s^{-4}", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('wp3_dp1') + iwp3_dp1 = k + call stat_assign( var_index=iwp3_dp1, var_name="wp3_dp1", & + var_description="wp3 budget: wp3 dissipation term 1 [m^{3} s^{-4}]", & + var_units="m^{3} s^{-4}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('wp3_cl') + iwp3_cl = k + call stat_assign( var_index=iwp3_cl, var_name="wp3_cl", & + var_description="wp3 budget: wp3 clipping term [m^{3} s^{-4}]", & + var_units="m^{3} s^{-4}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_bt') + irrm_bt = k + call stat_assign( var_index=irrm_bt, var_name="rrm_bt", & + var_description="rrm budget: rrm time tendency [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_ma') + irrm_ma = k + + call stat_assign( var_index=irrm_ma, var_name="rrm_ma", & + var_description="rrm budget: rrm vertical mean advection [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_sd') + irrm_sd = k + + call stat_assign( var_index=irrm_sd, var_name="rrm_sd", & + var_description="rrm budget: rrm sedimentation [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_ts') + irrm_ts = k + + call stat_assign( var_index=irrm_ts, var_name="rrm_ts", & + var_description="rrm budget: rrm turbulent sedimentation [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_sd_morr') + irrm_sd_morr = k + + call stat_assign( var_index=irrm_sd_morr, var_name="rrm_sd_morr", & + var_description="rrm sedimentation when using morrision microphysics & + &(not in budget, included in rrm_mc) [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_ta') + irrm_ta = k + + call stat_assign( var_index=irrm_ta, var_name="rrm_ta", & + var_description="rrm budget: rrm turbulent advection [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_cond') + irrm_cond = k + + call stat_assign( var_index=irrm_cond, var_name="rrm_cond", & + var_description="rrm evaporation rate [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_auto') + irrm_auto = k + + call stat_assign( var_index=irrm_auto, var_name="rrm_auto", & + var_description="rrm autoconversion rate [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_accr') + irrm_accr = k + call stat_assign( var_index=irrm_accr, var_name="rrm_accr", & + var_description="rrm accretion rate [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_cond_adj') + irrm_cond_adj = k + + call stat_assign( var_index=irrm_cond_adj, var_name="rrm_cond_adj", & + var_description="rrm evaporation adjustment due to over-evaporation & + &[kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_src_adj') + irrm_src_adj = k + + call stat_assign( var_index=irrm_src_adj, var_name="rrm_src_adj", & + var_description="rrm source term adjustment due to over-depletion & + &[kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_hf') + irrm_hf = k + call stat_assign( var_index=irrm_hf, var_name="rrm_hf", & + var_description="rrm budget: rrm hole-filling term [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_wvhf') + irrm_wvhf = k + call stat_assign( var_index=irrm_wvhf, var_name="rrm_wvhf", & + var_description="rrm budget: rrm water vapor hole-filling term & + &[kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_cl') + irrm_cl = k + call stat_assign( var_index=irrm_cl, var_name="rrm_cl", & + var_description="rrm budget: rrm clipping term [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_mc') + irrm_mc = k + + call stat_assign( var_index=irrm_mc, var_name="rrm_mc", & + var_description="rrm budget: Change in rrm due to microphysics & + &[kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nrm_bt') + iNrm_bt = k + call stat_assign( var_index=iNrm_bt, var_name="Nrm_bt", & + var_description="Nrm budget: Nrm time tendency [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Nrm_ma') + iNrm_ma = k + + call stat_assign( var_index=iNrm_ma, var_name="Nrm_ma", & + var_description="Nrm budget: Nrm vertical mean advection [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nrm_sd') + iNrm_sd = k + + call stat_assign( var_index=iNrm_sd, var_name="Nrm_sd", & + var_description="Nrm budget: Nrm sedimentation [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Nrm_ts') + iNrm_ts = k + + call stat_assign( var_index=iNrm_ts, var_name="Nrm_ts", & + var_description="Nrm budget: Nrm turbulent sedimentation [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nrm_ta') + iNrm_ta = k + call stat_assign( var_index=iNrm_ta, var_name="Nrm_ta", & + var_description="Nrm budget: Nrm turbulent advection [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Nrm_cond') + iNrm_cond = k + + call stat_assign( var_index=iNrm_cond, var_name="Nrm_cond", & + var_description="Nrm evaporation rate [(num/kg)/s]", var_units="(num/kg)/s", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nrm_auto') + iNrm_auto = k + + call stat_assign( var_index=iNrm_auto, var_name="Nrm_auto", & + var_description="Nrm autoconversion rate [(num/kg)/s]", var_units="(num/kg)/s", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Nrm_cond_adj') + iNrm_cond_adj = k + + call stat_assign( var_index=iNrm_cond_adj, var_name="Nrm_cond_adj", & + var_description="Nrm evaporation adjustment due to over-evaporation [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nrm_src_adj') + iNrm_src_adj = k + + call stat_assign( var_index=iNrm_src_adj, var_name="Nrm_src_adj", & + var_description="Nrm source term adjustment due to over-depletion [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nrm_cl') + iNrm_cl = k + call stat_assign( var_index=iNrm_cl, var_name="Nrm_cl", & + var_description="Nrm budget: Nrm clipping term [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nrm_mc') + iNrm_mc = k + call stat_assign( var_index=iNrm_mc, var_name="Nrm_mc", & + var_description="Nrm budget: Change in Nrm due to microphysics (Not in budget) & + &[(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rsm_bt') + irsm_bt = k + call stat_assign( var_index=irsm_bt, var_name="rsm_bt", & + var_description="rsm budget: rsm time tendency [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('rsm_ma') + irsm_ma = k + + call stat_assign( var_index=irsm_ma, var_name="rsm_ma", & + var_description="rsm budget: rsm vertical mean advection [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rsm_sd') + irsm_sd = k + call stat_assign( var_index=irsm_sd, var_name="rsm_sd", & + var_description="rsm budget: rsm sedimentation [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rsm_sd_morr') + irsm_sd_morr = k + call stat_assign( var_index=irsm_sd_morr, var_name="rsm_sd_morr", & + var_description="rsm sedimentation when using morrison microphysics & + &(Not in budget, included in rsm_mc) [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('rsm_ta') + irsm_ta = k + + call stat_assign( var_index=irsm_ta, var_name="rsm_ta", & + var_description="rsm budget: rsm turbulent advection [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rsm_mc') + irsm_mc = k + + call stat_assign( var_index=irsm_mc, var_name="rsm_mc", & + var_description="rsm budget: Change in rsm due to microphysics [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rsm_hf') + irsm_hf = k + + call stat_assign( var_index=irsm_hf, var_name="rsm_hf", & + var_description="rsm budget: rsm hole-filling term [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rsm_wvhf') + irsm_wvhf = k + + call stat_assign( var_index=irsm_wvhf, var_name="rsm_wvhf", & + var_description="rsm budget: rsm water vapor hole-filling term [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rsm_cl') + irsm_cl = k + + call stat_assign( var_index=irsm_cl, var_name="rsm_cl", & + var_description="rsm budget: rsm clipping term [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nsm_bt') + iNsm_bt = k + call stat_assign( var_index=iNsm_bt, var_name="Nsm_bt", & + var_description="Nsm budget: [(num/kg)/s]", var_units="(num/kg)/s", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Nsm_ma') + iNsm_ma = k + + call stat_assign( var_index=iNsm_ma, var_name="Nsm_ma", & + var_description="Nsm budget: Nsm mean advection [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nsm_sd') + iNsm_sd = k + + call stat_assign( var_index=iNsm_sd, var_name="Nsm_sd", & + var_description="Nsm budget: Nsm sedimentation [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Nsm_ta') + iNsm_ta = k + call stat_assign( var_index=iNsm_ta, var_name="Nsm_ta", & + var_description="Nsm budget: Nsm turbulent advection [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Nsm_mc') + iNsm_mc = k + call stat_assign( var_index=iNsm_mc, var_name="Nsm_mc", & + var_description="Nsm budget: Nsm microphysics [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Nsm_cl') + iNsm_cl = k + + call stat_assign( var_index=iNsm_cl, var_name="Nsm_cl", & + var_description="Nsm budget: Nsm clipping term [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rim_bt') + irim_bt = k + + call stat_assign( var_index=irim_bt, var_name="rim_bt", & + var_description="rim budget: rim time tendency [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('rim_ma') + irim_ma = k + + call stat_assign( var_index=irim_ma, var_name="rim_ma", & + var_description="rim budget: rim vertical mean advection [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rim_sd') + irim_sd = k + + call stat_assign( var_index=irim_sd, var_name="rim_sd", & + var_description="rim budget: rim sedimentation [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rim_sd_mg_morr') + irim_sd_mg_morr = k + + call stat_assign( var_index=irim_sd_mg_morr, var_name="rim_sd_mg_morr", & + var_description="rim sedimentation when using morrison or MG microphysics & + &(not in budget, included in rim_mc) [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('rim_ta') + irim_ta = k + + call stat_assign( var_index=irim_ta, var_name="rim_ta", & + var_description="rim budget: rim turbulent advection [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rim_mc') + irim_mc = k + + call stat_assign( var_index=irim_mc, var_name="rim_mc", & + var_description="rim budget: Change in rim due to microphysics [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rim_hf') + irim_hf = k + + call stat_assign( var_index=irim_hf, var_name="rim_hf", & + var_description="rim budget: rim hole-filling term [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rim_wvhf') + irim_wvhf = k + + call stat_assign( var_index=irim_wvhf, var_name="rim_wvhf", & + var_description="rim budget: rim water vapor hole-filling term [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rim_cl') + irim_cl = k + + call stat_assign( var_index=irim_cl, var_name="rim_cl", & + var_description="rim budget: rim clipping term [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rgm_bt') + irgm_bt = k + + call stat_assign( var_index=irgm_bt, var_name="rgm_bt", & + var_description="rgm budget: rgm time tendency [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rgm_ma') + irgm_ma = k + + call stat_assign( var_index=irgm_ma, var_name="rgm_ma", & + var_description="rgm budget: rgm vertical mean advection [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rgm_sd') + irgm_sd = k + + call stat_assign( var_index=irgm_sd, var_name="rgm_sd", & + var_description="rgm budget: rgm sedimentation [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rgm_sd_morr') + irgm_sd_morr = k + + call stat_assign( var_index=irgm_sd_morr, var_name="rgm_sd_morr", & + var_description="rgm sedimentation when using morrison microphysics & + &(not in budget, included in rgm_mc) [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('rgm_ta') + irgm_ta = k + + call stat_assign( var_index=irgm_ta, var_name="rgm_ta", & + var_description="rgm budget: rgm turbulent advection [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rgm_mc') + irgm_mc = k + + call stat_assign( var_index=irgm_mc, var_name="rgm_mc", & + var_description="rgm budget: Change in rgm due to microphysics & + &[(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rgm_hf') + irgm_hf = k + + call stat_assign( var_index=irgm_hf, var_name="rgm_hf", & + var_description="rgm budget: rgm hole-filling term [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rgm_wvhf') + irgm_wvhf = k + + call stat_assign( var_index=irgm_wvhf, var_name="rgm_wvhf", & + var_description="rgm budget: rgm water vapor hole-filling term & + &[(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rgm_cl') + irgm_cl = k + + call stat_assign( var_index=irgm_cl, var_name="rgm_cl", & + var_description="rgm budget: rgm clipping term [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Ngm_bt') + iNgm_bt = k + call stat_assign( var_index=iNgm_bt, var_name="Ngm_bt", & + var_description="Ngm budget: [(num/kg)/s]", var_units="(num/kg)/s", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Ngm_ma') + iNgm_ma = k + + call stat_assign( var_index=iNgm_ma, var_name="Ngm_ma", & + var_description="Ngm budget: Ngm mean advection [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Ngm_sd') + iNgm_sd = k + + call stat_assign( var_index=iNgm_sd, var_name="Ngm_sd", & + var_description="Ngm budget: Ngm sedimentation [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Ngm_ta') + iNgm_ta = k + call stat_assign( var_index=iNgm_ta, var_name="Ngm_ta", & + var_description="Ngm budget: Ngm turbulent advection [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Ngm_mc') + iNgm_mc = k + + call stat_assign( var_index=iNgm_mc, var_name="Ngm_mc", & + var_description="Ngm budget: Ngm microphysics term [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Ngm_cl') + iNgm_cl = k + + call stat_assign( var_index=iNgm_cl, var_name="Ngm_cl", & + var_description="Ngm budget: Ngm clipping term [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nim_bt') + iNim_bt = k + call stat_assign( var_index=iNim_bt, var_name="Nim_bt", & + var_description="Nim budget: [(num/kg)/s]", var_units="(num/kg)/s", l_silhs=.false., & + grid_kind=stats_zt ) + + k = k + 1 + + case ('Nim_ma') + iNim_ma = k + + call stat_assign( var_index=iNim_ma, var_name="Nim_ma", & + var_description="Nim budget: Nim mean advection [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nim_sd') + iNim_sd = k + + call stat_assign( var_index=iNim_sd, var_name="Nim_sd", & + var_description="Nim budget: Nim sedimentation [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Nim_ta') + iNim_ta = k + call stat_assign( var_index=iNim_ta, var_name="Nim_ta", & + var_description="Nim budget: Nim turbulent advection [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Nim_mc') + iNim_mc = k + + call stat_assign( var_index=iNim_mc, var_name="Nim_mc", & + var_description="Nim budget: Nim microphysics term [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nim_cl') + iNim_cl = k + + call stat_assign( var_index=iNim_cl, var_name="Nim_cl", & + var_description="Nim budget: Nim clipping term [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Ncm_bt') + iNcm_bt = k + call stat_assign( var_index=iNcm_bt, var_name="Ncm_bt", & + var_description="Ncm budget: Cloud droplet number concentration budget [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Ncm_ma') + iNcm_ma = k + + call stat_assign( var_index=iNcm_ma, var_name="Ncm_ma", & + var_description="Ncm budget: Ncm vertical mean advection [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Ncm_act') + iNcm_act = k + + call stat_assign( var_index=iNcm_act, var_name="Ncm_act", & + var_description="Ncm budget: Change in Ncm due to activation [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Ncm_ta') + iNcm_ta = k + call stat_assign( var_index=iNcm_ta, var_name="Ncm_ta", & + var_description="Ncm budget: Ncm turbulent advection [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Ncm_mc') + iNcm_mc = k + + call stat_assign( var_index=iNcm_mc, var_name="Ncm_mc", & + var_description="Ncm budget: Change in Ncm due to microphysics [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Ncm_cl') + iNcm_cl = k + + call stat_assign( var_index=iNcm_cl, var_name="Ncm_cl", & + var_description="Ncm budget: Ncm clipping term [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('PSMLT') + iPSMLT = k + + call stat_assign( var_index=iPSMLT, var_name="PSMLT", & + var_description="Freezing of rain to form snow, +rsm, -rrm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('EVPMS') + iEVPMS = k + + call stat_assign( var_index=iEVPMS, var_name="EVPMS", & + var_description="Evaporation of melted snow, +rsm, -rvm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PRACS') + iPRACS = k + + call stat_assign( var_index=iPRACS, var_name="PRACS", & + var_description="Collection of rain by snow, +rsm, -rrm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('EVPMG') + iEVPMG = k + + call stat_assign( var_index=iEVPMG, var_name="EVPMG", & + var_description="Evaporation of melted graupel, +rgm, -rvm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PRACG') + iPRACG = k + + call stat_assign( var_index=iPRACG, var_name="PRACG", & + var_description="Negative of collection of rain by graupel, +rrm, -rgm & + &[(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PGMLT') + iPGMLT = k + + call stat_assign( var_index=iPGMLT, var_name="PGMLT", & + var_description="Negative of melting of graupel, +rgm, -rrm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('MNUCCC') + iMNUCCC = k + + call stat_assign( var_index=iMNUCCC, var_name="MNUCCC", & + var_description="Contact freezing of cloud droplets, +rim, -rcm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PSACWS') + iPSACWS = k + + call stat_assign( var_index=iPSACWS, var_name="PSACWS", & + var_description="Collection of cloud water by snow, +rsm, -rcm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PSACWI') + iPSACWI = k + + call stat_assign( var_index=iPSACWI, var_name="PSACWI", & + var_description="Collection of cloud water by cloud ice, +rim, -rcm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('QMULTS') + iQMULTS = k + + call stat_assign( var_index=iQMULTS, var_name="QMULTS", & + var_description="Splintering from cloud droplets accreted onto snow, +rim, -rcm & + &[(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('QMULTG') + iQMULTG = k + + call stat_assign( var_index=iQMULTG, var_name="QMULTG", & + var_description="Splintering from droplets accreted onto graupel, +rim, -rcm & + &[(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PSACWG') + iPSACWG = k + + call stat_assign( var_index=iPSACWG, var_name="PSACWG", & + var_description="Collection of cloud water by graupel, +rgm, -rcm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PGSACW') + iPGSACW = k + + call stat_assign( var_index=iPGSACW, var_name="PGSACW", & + var_description="Reclassification of rimed snow as graupel, +rgm, -rcm & + &[(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PRD') + iPRD = k + + call stat_assign( var_index=iPRD, var_name="PRD", & + var_description="Depositional growth of cloud ice, +rim, -rvm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PRCI') + iPRCI = k + + call stat_assign( var_index=iPRCI, var_name="PRCI", & + var_description="Autoconversion of cloud ice to snow, +rsm, -rim [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PRAI') + iPRAI = k + + call stat_assign( var_index=iPRAI, var_name="PRAI", & + var_description="Collection of cloud ice by snow, +rsm, -rim [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('QMULTR') + iQMULTR = k + + call stat_assign( var_index=iQMULTR, var_name="QMULTR", & + var_description="Splintering from rain droplets accreted onto snow, +rim, -rrm & + &[(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('QMULTRG') + iQMULTRG = k + + call stat_assign( var_index=iQMULTRG, var_name="QMULTRG", & + var_description="Splintering from rain droplets accreted onto graupel, +rim, -rrm& + & [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('MNUCCD') + iMNUCCD = k + + call stat_assign( var_index=iMNUCCD, var_name="MNUCCD", & + var_description="Freezing of aerosol, +rim, -rvm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PRACI') + iPRACI = k + + call stat_assign( var_index=iPRACI, var_name="PRACI", & + var_description="Collection of cloud ice by rain, +rgm, -rim [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PRACIS') + iPRACIS = k + + call stat_assign( var_index=iPRACIS, var_name="PRACIS", & + var_description="Collection of cloud ice by rain, +rsm, -rim [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('EPRD') + iEPRD = k + + call stat_assign( var_index=iEPRD, var_name="EPRD", & + var_description="Negative of sublimation of cloud ice, +rim, -rvm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('MNUCCR') + iMNUCCR = k + + call stat_assign( var_index=iMNUCCR, var_name="MNUCCR", & + var_description="Contact freezing of rain droplets, +rgm, -rrm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PIACR') + iPIACR = k + + call stat_assign( var_index=iPIACR, var_name="PIACR", & + var_description="Collection of cloud ice by rain, +rgm, -rrm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PIACRS') + iPIACRS = k + + call stat_assign( var_index=iPIACRS, var_name="PIACRS", & + var_description="Collection of cloud ice by rain, +rsm, -rrm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PGRACS') + iPGRACS = k + + call stat_assign( var_index=iPGRACS, var_name="PGRACS", & + var_description="Collection of rain by snow, +rgm, -rrm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PRDS') + iPRDS = k + + call stat_assign( var_index=iPRDS, var_name="PRDS", & + var_description="Depositional growth of snow, +rsm, -rvm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('EPRDS') + iEPRDS = k + + call stat_assign( var_index=iEPRDS, var_name="EPRDS", & + var_description="Negative of sublimation of snow, +rsm, -rvm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PSACR') + iPSACR = k + + call stat_assign( var_index=iPSACR, var_name="PSACR", & + var_description="Collection of snow by rain, +rgm, -rsm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PRDG') + iPRDG = k + + call stat_assign( var_index=iPRDG, var_name="PRDG", & + var_description="Depositional growth of graupel, +rgm, -rvm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('EPRDG') + iEPRDG = k + + call stat_assign( var_index=iEPRDG, var_name="EPRDG", & + var_description="Negative of sublimation of graupel, +rgm, -rvm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NGSTEN') + iNGSTEN = k + + call stat_assign( var_index=iNGSTEN, var_name="NGSTEN", & + var_description="Graupel sedimentation tendency [(#/kg/s)]", var_units="(#/kg/s)", & + l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NRSTEN') + iNRSTEN = k + + call stat_assign( var_index=iNRSTEN, var_name="NRSTEN", & + var_description="Rain sedimentation tendency [(#/kg/s)]", var_units="(#/kg/s)", & + l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NISTEN') + iNISTEN = k + + call stat_assign( var_index=iNISTEN, var_name="NISTEN", & + var_description="Cloud ice sedimentation tendency [(#/kg/s)]", var_units="(#/kg/s)", & + l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NSSTEN') + iNSSTEN = k + + call stat_assign( var_index=iNSSTEN, var_name="NSSTEN", & + var_description="Snow sedimentation tendency [(#/kg/s)]", var_units="(#/kg/s)", & + l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NCSTEN') + iNCSTEN = k + + call stat_assign( var_index=iNCSTEN, var_name="NCSTEN", & + var_description="Cloud water sedimentation tendency [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NPRC1') + iNPRC1 = k + + call stat_assign( var_index=iNPRC1, var_name="NPRC1", & + var_description="Change in Nrm due to autoconversion of droplets, +Nrm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NRAGG') + iNRAGG = k + + call stat_assign( var_index=iNRAGG, var_name="NRAGG", & + var_description="Change in Nrm due to self-collection of raindrops, +Nrm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NPRACG') + iNPRACG = k + + call stat_assign( var_index=iNPRACG, var_name="NPRACG", & + var_description="Collection of rainwater by graupel, -Nrm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NSUBR') + iNSUBR = k + + call stat_assign( var_index=iNSUBR, var_name="NSUBR", & + var_description="Loss of Nrm by evaporation, +Nrm [(#/kg/s)]", var_units="(#/kg/s)", & + l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NSMLTR') + iNSMLTR = k + + call stat_assign( var_index=iNSMLTR, var_name="NSMLTR", & + var_description="Melting of snow to form rain, -Nrm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NGMLTR') + iNGMLTR = k + + call stat_assign( var_index=iNGMLTR, var_name="NGMLTR", & + var_description="Melting of graupel to form rain, -Nrm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NPRACS') + iNPRACS = k + + call stat_assign( var_index=iNPRACS, var_name="NPRACS", & + var_description="Collection of rainwater by snow, -Nrm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NNUCCR') + iNNUCCR = k + + call stat_assign( var_index=iNNUCCR, var_name="NNUCCR", & + var_description="Contact freezing of rain, +Ngm, -Nrm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NIACR') + iNIACR = k + + call stat_assign( var_index=iNIACR, var_name="NIACR", & + var_description="Collection of cloud ice by rain, +Ngm, -Nrm, -Nim [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NIACRS') + iNIACRS = k + + call stat_assign( var_index=iNIACRS, var_name="NIACRS", & + var_description="Collection of cloud ice by rain, +Nsm, -Nrm, -Nim [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NGRACS') + iNGRACS = k + + call stat_assign( var_index=iNGRACS, var_name="NGRACS", & + var_description="Collection of rain by snow, +Ngm, -Nrm, -Nsm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NSMLTS') + iNSMLTS= k + + call stat_assign( var_index=iNSMLTS, var_name="NSMLTS", & + var_description="Melting of snow, +Nsm [(#/kg/s)]", var_units="(#/kg/s)", & + l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NSAGG') + iNSAGG= k + + call stat_assign( var_index=iNSAGG, var_name="NSAGG", & + var_description="Self collection of snow, +Nsm [(#/kg/s)]", var_units="(#/kg/s)", & + l_silhs=.true., grid_kind=stats_zt ) + + k = k + 1 + + case ('NPRCI') + iNPRCI= k + + call stat_assign( var_index=iNPRCI, var_name="NPRCI", & + var_description="Autoconversion of cloud ice to snow, -Nim, +Nsm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NSCNG') + iNSCNG= k + + call stat_assign( var_index=iNSCNG, var_name="NSCNG", & + var_description="Conversion of snow to graupel, +Ngm, -Nsm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NSUBS') + iNSUBS= k + + call stat_assign( var_index=iNSUBS, var_name="NSUBS", & + var_description="Loss of snow due to sublimation, +Nsm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PRC') + iPRC= k + + call stat_assign( var_index=iPRC, var_name="PRC", & + var_description="Autoconversion +rrm -rcm [(kg/kg/s)]", var_units="(kg/kg/s)", & + l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PRA') + iPRA= k + + call stat_assign( var_index=iPRA, var_name="PRA", & + var_description="Accretion +rrm -rcm [(kg/kg/s)]", var_units="(kg/kg/s)", & + l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PRE') + iPRE= k + + call stat_assign( var_index=iPRE, var_name="PRE", & + var_description="Evaporation of rain -rrm [(kg/kg/s)]", var_units="(kg/kg/s)", & + l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PCC') + iPCC= k + + call stat_assign( var_index=iPCC, var_name="PCC", & + var_description="Satuation adjustment -rvm +rcm [(kg/kg/s)]", var_units="(kg/kg/s)", & + l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NNUCCC') + iNNUCCC= k + + call stat_assign( var_index=iNNUCCC, var_name="NNUCCC", & + var_description="Contact freezing of drops, -Ncm + Nim [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NPSACWS') + iNPSACWS= k + + call stat_assign( var_index=iNPSACWS, var_name="NPSACWS", & + var_description="Droplet accretion by snow, -Ncm [(#/kg/s)]", var_units="(#/kg/s)", & + l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NPRA') + iNPRA= k + + call stat_assign( var_index=iNPRA, var_name="NPRA", & + var_description="Droplet accretion by rain, -Ncm [(#/kg/s)]", var_units="(#/kg/s)", & + l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NPRC') + iNPRC= k + + call stat_assign( var_index=iNPRC, var_name="NPRC", & + var_description="Autoconversion of cloud drops, -Ncm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NPSACWI') + iNPSACWI= k + + call stat_assign( var_index=iNPSACWI, var_name="NPSACWI", & + var_description="Droplet accretion by cloud ice, -Ncm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NPSACWG') + iNPSACWG= k + + call stat_assign( var_index=iNPSACWG, var_name="NPSACWG", & + var_description="Collection of cloud droplets by graupel, -Ncm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NPRAI') + iNPRAI= k + + call stat_assign( var_index=iNPRAI, var_name="NPRAI", & + var_description="Accretion of cloud ice by snow, -Nim [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NMULTS') + iNMULTS= k + + call stat_assign( var_index=iNMULTS, var_name="NMULTS", & + var_description="Ice multiplication due to riming of cloud droplets by snow, +Nim & + &[(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NMULTG') + iNMULTG= k + + call stat_assign( var_index=iNMULTG, var_name="NMULTG", & + var_description="Ice multiplication due to accretion of droplets by graupel, +Nim & + &[(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NMULTR') + iNMULTR= k + + call stat_assign( var_index=iNMULTR, var_name="NMULTR", & + var_description="Ice multiplication due to riming of rain by snow, +Nim [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NMULTRG') + iNMULTRG= k + + call stat_assign( var_index=iNMULTRG, var_name="NMULTRG", & + var_description="Ice multiplication due to accretion of rain by graupel, +Nim & + &[(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NNUCCD') + iNNUCCD= k + + call stat_assign( var_index=iNNUCCD, var_name="NNUCCD", & + var_description="Primary ice nucleation, freezing of aerosol, +Nim [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NSUBI') + iNSUBI= k + + call stat_assign( var_index=iNSUBI, var_name="NSUBI", & + var_description="Loss of ice due to sublimation, -Nim [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NGMLTG') + iNGMLTG= k + + call stat_assign( var_index=iNGMLTG, var_name="NGMLTG", & + var_description="Loss of graupel due to melting, -Ngm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NSUBG') + iNSUBG= k + + call stat_assign( var_index=iNSUBG, var_name="NSUBG", & + var_description="Loss of graupel due to sublimation, -Ngm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NACT') + iNACT= k + + call stat_assign( var_index=iNACT, var_name="NACT", & + var_description="Cloud drop formation by aerosol activation, +Ncm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('SIZEFIX_NR') + iSIZEFIX_NR= k + + call stat_assign( var_index=iSIZEFIX_NR, var_name="SIZEFIX_NR", & + var_description="Adjust rain # conc. for large/small drops, +Nrm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('SIZEFIX_NC') + iSIZEFIX_NC= k + + call stat_assign( var_index=iSIZEFIX_NC, var_name="SIZEFIX_NC", & + var_description="Adjust cloud # conc. for large/small drops, +Ncm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('SIZEFIX_NI') + iSIZEFIX_NI= k + + call stat_assign( var_index=iSIZEFIX_NI, var_name="SIZEFIX_NI", & + var_description="Adjust ice # conc. for large/small drops, +Nim [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('SIZEFIX_NS') + iSIZEFIX_NS= k + + call stat_assign( var_index=iSIZEFIX_NS, var_name="SIZEFIX_NS", & + var_description="Adjust snow # conc. for large/small drops, +Nsm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('SIZEFIX_NG') + iSIZEFIX_NG= k + + call stat_assign( var_index=iSIZEFIX_NG, var_name="SIZEFIX_NG", & + var_description="Adjust graupel # conc. for large/small drops,+Ngm [(#/kg/s)]",& + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NEGFIX_NR') + iNEGFIX_NR= k + + call stat_assign( var_index=iNEGFIX_NR, var_name="NEGFIX_NR", & + var_description="Removal of negative rain drop number conc., -Nrm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NEGFIX_NC') + iNEGFIX_NC= k + + call stat_assign( var_index=iNEGFIX_NC, var_name="NEGFIX_NC", & + var_description="Removal of negative cloud drop number conc., -Ncm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NEGFIX_NI') + iNEGFIX_NI= k + + call stat_assign( var_index=iNEGFIX_NI, var_name="NEGFIX_NI", & + var_description="Removal of negative ice number conc., -Nim [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NEGFIX_NS') + iNEGFIX_NS= k + + call stat_assign( var_index=iNEGFIX_NS, var_name="NEGFIX_NS", & + var_description="Removal of negative snow number conc,, -Nsm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NEGFIX_NG') + iNEGFIX_NG= k + + call stat_assign( var_index=iNEGFIX_NG, var_name="NEGFIX_NG", & + var_description="Removal of negative graupel number conc., -Ngm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NIM_MORR_CL') + iNIM_MORR_CL= k + + call stat_assign( var_index=iNIM_MORR_CL, var_name="NIM_MORR_CL", & + var_description="Clipping of large ice concentrations, -Nim [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('QC_INST') + iQC_INST= k + + call stat_assign( var_index=iQC_INST, var_name="QC_INST", & + var_description="Change in mixing ratio due to instantaneous processes," // & + " +rcm [(kg/kg/s)]", & + var_units="(kg/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('QR_INST') + iQR_INST= k + + call stat_assign( var_index=iQR_INST, var_name="QR_INST", & + var_description="Change in mixing ratio from instantaneous processes," // & + " +rrm [(kg/kg/s)]", & + var_units="(kg/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('QI_INST') + iQI_INST= k + + call stat_assign( var_index=iQI_INST, var_name="QI_INST", & + var_description="Change in mixing ratio from instantaneous processes," // & + " +rim [(kg/kg/s)]", & + var_units="(kg/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('QS_INST') + iQS_INST= k + + call stat_assign( var_index=iQS_INST, var_name="QS_INST", & + var_description="Change in mixing ratio from instantaneous processes," // & + " +rsm [(kg/kg/s)]", & + var_units="(kg/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('QG_INST') + iQG_INST= k + + call stat_assign( var_index=iQG_INST, var_name="QG_INST", & + var_description="Change in mixing ratio from instantaneous processes," // & + " +rgm [(kg/kg/s)]", & + var_units="(kg/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NC_INST') + iNC_INST= k + + call stat_assign( var_index=iNC_INST, var_name="NC_INST", & + var_description="Change in # conc. from instantaneous processes," // & + " +Ncm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NR_INST') + iNR_INST= k + + call stat_assign( var_index=iNR_INST, var_name="NR_INST", & + var_description="Change in # conc. from instantaneous processes," // & + " +Nrm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NI_INST') + iNI_INST= k + + call stat_assign( var_index=iNI_INST, var_name="NI_INST", & + var_description="Change in # conc. from instantaneous processes," // & + " +Nim [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NS_INST') + iNS_INST= k + + call stat_assign( var_index=iNS_INST, var_name="NS_INST", & + var_description="Change in # conc. from instantaneous processes," // & + " +Nsm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NG_INST') + iNG_INST= k + + call stat_assign( var_index=iNG_INST, var_name="NG_INST", & + var_description="Change in # conc. from instantaneous processes," // & + " +Ngm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + + case ('T_in_K_mc') + iT_in_K_mc= k + + call stat_assign( var_index=iT_in_K_mc, var_name="T_in_K_mc", & + var_description="Temperature tendency from Morrison microphysics [(K/s)]", & + var_units="(K/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('w_KK_evap_covar_zt') + iw_KK_evap_covar_zt = k + + call stat_assign( var_index=iw_KK_evap_covar_zt, var_name="w_KK_evap_covar_zt", & + var_description="Covariance of w and KK evaporation rate", & + var_units="m*(kg/kg)/s^2", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rt_KK_evap_covar_zt') + irt_KK_evap_covar_zt = k + + call stat_assign( var_index=irt_KK_evap_covar_zt, var_name="rt_KK_evap_covar_zt", & + var_description="Covariance of r_t and KK evaporation rate", & + var_units="(kg/kg)^2/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('thl_KK_evap_covar_zt') + ithl_KK_evap_covar_zt = k + + call stat_assign( var_index=ithl_KK_evap_covar_zt, var_name="thl_KK_evap_covar_zt", & + var_description="Covariance of theta_l and KK evaporation rate", & + var_units="K*(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('w_KK_auto_covar_zt') + iw_KK_auto_covar_zt = k + + call stat_assign( var_index=iw_KK_auto_covar_zt, var_name="w_KK_auto_covar_zt", & + var_description="Covariance of w and KK autoconversion rate", & + var_units="m*(kg/kg)/s^2", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rt_KK_auto_covar_zt') + irt_KK_auto_covar_zt = k + + call stat_assign( var_index=irt_KK_auto_covar_zt, var_name="rt_KK_auto_covar_zt", & + var_description="Covariance of r_t and KK autoconversion rate", & + var_units="(kg/kg)^2/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('thl_KK_auto_covar_zt') + ithl_KK_auto_covar_zt = k + + call stat_assign( var_index=ithl_KK_auto_covar_zt, var_name="thl_KK_auto_covar_zt", & + var_description="Covariance of theta_l and KK autoconversion rate", & + var_units="K*(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('w_KK_accr_covar_zt') + iw_KK_accr_covar_zt = k + + call stat_assign( var_index=iw_KK_accr_covar_zt, var_name="w_KK_accr_covar_zt", & + var_description="Covariance of w and KK accretion rate", var_units="m*(kg/kg)/s^2", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rt_KK_accr_covar_zt') + irt_KK_accr_covar_zt = k + + call stat_assign( var_index=irt_KK_accr_covar_zt, var_name="rt_KK_accr_covar_zt", & + var_description="Covariance of r_t and KK accretion rate", var_units="(kg/kg)^2/s", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('thl_KK_accr_covar_zt') + ithl_KK_accr_covar_zt = k + + call stat_assign( var_index=ithl_KK_accr_covar_zt, var_name="thl_KK_accr_covar_zt", & + var_description="Covariance of theta_l and KK accretion rate", & + var_units="K*(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rr_KK_mvr_covar_zt') + irr_KK_mvr_covar_zt = k + + call stat_assign( var_index=irr_KK_mvr_covar_zt, var_name="rr_KK_mvr_covar_zt", & + var_description="Covariance of r_r and KK rain drop mean volume radius [(kg/kg)m]", & + var_units="(kg/kg)m", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nr_KK_mvr_covar_zt') + iNr_KK_mvr_covar_zt = k + + call stat_assign( var_index=iNr_KK_mvr_covar_zt, var_name="Nr_KK_mvr_covar_zt", & + var_description="Covariance of N_r and KK rain drop mean volume radius [(num/kg)m]", & + var_units="(num/kg)m", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('KK_mvr_variance_zt') + iKK_mvr_variance_zt = k + + call stat_assign( var_index=iKK_mvr_variance_zt, var_name="KK_mvr_variance_zt", & + var_description="Variance of KK rain drop mean volume radius [m^2]", & + var_units="m^2", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('vm_bt') + ivm_bt = k + + call stat_assign( var_index=ivm_bt, var_name="vm_bt", & + var_description="vm budget: vm time tendency [m s^{-2}]", var_units="m s^{-2}", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('vm_ma') + ivm_ma = k + call stat_assign( var_index=ivm_ma, var_name="vm_ma", & + var_description="vm budget: vm vertical mean advection [m s^{-2}]", & + var_units="m s^{-2}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('vm_gf') + ivm_gf = k + + call stat_assign( var_index=ivm_gf, var_name="vm_gf", & + var_description="vm budget: vm geostrophic forcing [m s^{-2}]", & + var_units="m s^{-2}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('vm_cf') + ivm_cf = k + + call stat_assign( var_index=ivm_cf, var_name="vm_cf", & + var_description="vm budget: vm coriolis forcing [m s^{-2}]", var_units="m s^{-2}", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('vm_ta') + ivm_ta = k + + call stat_assign( var_index=ivm_ta, var_name="vm_ta", & + var_description="vm budget: vm turbulent transport [m s^{-2}]", & + var_units="m s^{-2}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('vm_f') + ivm_f = k + call stat_assign( var_index=ivm_f, var_name="vm_f", & + var_description="vm budget: vm forcing [m s^{-2}]", var_units="m s^{-2}", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('vm_sdmp') + ivm_sdmp = k + call stat_assign( var_index=ivm_sdmp, var_name="vm_sdmp", & + var_description="vm budget: vm sponge damping [m s^{-2}]", var_units="m s^{-2}", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('vm_ndg') + ivm_ndg = k + call stat_assign( var_index=ivm_ndg, var_name="vm_ndg", & + var_description="vm budget: vm nudging [m s^{-2}]", var_units="m s^{-2}", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('um_bt') + ium_bt = k + + call stat_assign( var_index=ium_bt, var_name="um_bt", & + var_description="um budget: um time tendency [m s^{-2}]", var_units="m s^{-2}", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('um_ma') + ium_ma = k + + call stat_assign( var_index=ium_ma, var_name="um_ma", & + var_description="um budget: um vertical mean advection [m s^{-2}]", & + var_units="m s^{-2}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('um_gf') + ium_gf = k + call stat_assign( var_index=ium_gf, var_name="um_gf", & + var_description="um budget: um geostrophic forcing [m s^{-2}]", & + var_units="m s^{-2}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('um_cf') + ium_cf = k + call stat_assign( var_index=ium_cf, var_name="um_cf", & + var_description="um budget: um coriolis forcing [m s^{-2}]", var_units="m s^{-2}", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('um_ta') + ium_ta = k + call stat_assign( var_index=ium_ta, var_name="um_ta", & + var_description="um budget: um turbulent advection [m s^{-2}]", & + var_units="m s^{-2}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('um_f') + ium_f = k + call stat_assign( var_index=ium_f, var_name="um_f", & + var_description="um budget: um forcing [m s^{-2}]", var_units="m s^{-2}", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('um_sdmp') + ium_sdmp = k + call stat_assign( var_index=ium_sdmp, var_name="um_sdmp", & + var_description="um budget: um sponge damping [m s^{-2}]", var_units="m s^{-2}", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('um_ndg') + ium_ndg = k + call stat_assign( var_index=ium_ndg, var_name="um_ndg", & + var_description="um budget: um nudging [m s^{-2}]", var_units="m s^{-2}", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('mixt_frac') + imixt_frac = k + call stat_assign( var_index=imixt_frac, var_name="mixt_frac", & + var_description="pdf parameter: mixture fraction [count]", var_units="count", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('w_1') + iw_1 = k + call stat_assign( var_index=iw_1, var_name="w_1", & + var_description="pdf parameter: mean w of component 1 [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('w_2') + iw_2 = k + + call stat_assign( var_index=iw_2, var_name="w_2", & + var_description="pdf paramete: mean w of component 2 [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('varnce_w_1') + ivarnce_w_1 = k + call stat_assign( var_index=ivarnce_w_1, var_name="varnce_w_1", & + var_description="pdf parameter: w variance of component 1 [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('varnce_w_2') + ivarnce_w_2 = k + + call stat_assign( var_index=ivarnce_w_2, var_name="varnce_w_2", & + var_description="pdf parameter: w variance of component 2 [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('thl_1') + ithl_1 = k + + call stat_assign( var_index=ithl_1, var_name="thl_1", & + var_description="pdf parameter: mean thl of component 1 [K]", var_units="K", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('thl_2') + ithl_2 = k + + call stat_assign( var_index=ithl_2, var_name="thl_2", & + var_description="pdf parameter: mean thl of component 2 [K]", var_units="K", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('varnce_thl_1') + ivarnce_thl_1 = k + + call stat_assign( var_index=ivarnce_thl_1, var_name="varnce_thl_1", & + var_description="pdf parameter: thl variance of component 1 [K^2]", var_units="K^2", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('varnce_thl_2') + ivarnce_thl_2 = k + call stat_assign( var_index=ivarnce_thl_2, var_name="varnce_thl_2", & + var_description="pdf parameter: thl variance of component 2 [K^2]", var_units="K^2", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('rt_1') + irt_1 = k + call stat_assign( var_index=irt_1, var_name="rt_1", & + var_description="pdf parameter: mean rt of component 1 [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('rt_2') + irt_2 = k + + call stat_assign( var_index=irt_2, var_name="rt_2", & + var_description="pdf parameter: mean rt of component 2 [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('varnce_rt_1') + ivarnce_rt_1 = k + call stat_assign( var_index=ivarnce_rt_1, var_name="varnce_rt_1", & + var_description="pdf parameter: rt variance of component 1 [(kg^2)/(kg^2)]", & + var_units="(kg^2)/(kg^2)", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('varnce_rt_2') + ivarnce_rt_2 = k + + call stat_assign( var_index=ivarnce_rt_2, var_name="varnce_rt_2", & + var_description="pdf parameter: rt variance of component 2 [(kg^2)/(kg^2)]", & + var_units="(kg^2)/(kg^2)", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rc_1') + irc_1 = k + + call stat_assign( var_index=irc_1, var_name="rc_1", & + var_description="pdf parameter: mean rc of component 1 [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rc_2') + irc_2 = k + + call stat_assign( var_index=irc_2, var_name="rc_2", & + var_description="pdf parameter: mean rc of component 2 [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rsatl_1') + irsatl_1 = k + + call stat_assign( var_index=irsatl_1, var_name="rsatl_1", & + var_description="pdf parameter: sat mix rat based on tl1 [kg/kg]", & + var_units="kg/kg", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rsatl_2') + irsatl_2 = k + + call stat_assign( var_index=irsatl_2, var_name="rsatl_2", & + var_description="pdf parameter: sat mix rat based on tl2 [kg/kg]", & + var_units="kg/kg", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('cloud_frac_1') + icloud_frac_1 = k + call stat_assign( var_index=icloud_frac_1, var_name="cloud_frac_1", & + var_description="pdf parameter cloud_frac_1 [count]", var_units="count", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('cloud_frac_2') + icloud_frac_2 = k + + call stat_assign( var_index=icloud_frac_2, var_name="cloud_frac_2", & + var_description="pdf parameter cloud_frac_2 [count]", var_units="count", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('chi_1') + ichi_1 = k + + call stat_assign( var_index=ichi_1, var_name="chi_1", & + var_description="pdf parameter: Mellor's s (extended liq) for component 1 [kg/kg]", & + var_units="kg/kg", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('chi_2') + ichi_2 = k + + call stat_assign( var_index=ichi_2, var_name="chi_2", & + var_description="pdf parameter: Mellor's s (extended liq) for component 2 [kg/kg]", & + var_units="kg/kg", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('stdev_chi_1') + istdev_chi_1 = k + + call stat_assign( var_index=istdev_chi_1, var_name="stdev_chi_1", & + var_description="pdf parameter: Std dev of chi_1 [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('stdev_chi_2') + istdev_chi_2 = k + + call stat_assign( var_index=istdev_chi_2, var_name="stdev_chi_2", & + var_description="pdf parameter: Std dev of chi_2 [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('chip2') + ichip2 = k + call stat_assign( var_index=ichip2, var_name="chip2", & + var_description="Variance of chi(s) (overall) [(kg/kg)^2]", var_units="(kg/kg)^2", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('stdev_eta_1') + istdev_eta_1 = k + + call stat_assign( var_index=istdev_eta_1, var_name="stdev_eta_1", & + var_description="Standard dev. of eta(t) (1st PDF component) [kg/kg]", & + var_units="kg/kg", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('stdev_eta_2') + istdev_eta_2 = k + + call stat_assign( var_index=istdev_eta_2, var_name="stdev_eta_2", & + var_description="Standard dev. of eta(t) (2nd PDF component) [kg/kg]", & + var_units="kg/kg", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('covar_chi_eta_1') + icovar_chi_eta_1 = k + + call stat_assign( var_index=icovar_chi_eta_1, var_name="covar_chi_eta_1", & + var_description="Covariance of chi(s) and eta(t) (1st PDF component) [kg^2/kg^2]", & + var_units="kg^2/kg^2", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('covar_chi_eta_2') + icovar_chi_eta_2 = k + + call stat_assign( var_index=icovar_chi_eta_2, var_name="covar_chi_eta_2", & + var_description="Covariance of chi(s) and eta(t) (2nd PDF component) [kg^2/kg^2]", & + var_units="kg^2/kg^2", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('corr_chi_eta_1') + icorr_chi_eta_1 = k + + call stat_assign( var_index=icorr_chi_eta_1, & + var_name="corr_chi_eta_1", & + var_description="Correlation of chi (s) and" & + // " eta (t) (1st PDF component) [-]", & + var_units="-", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('corr_chi_eta_2') + icorr_chi_eta_2 = k + + call stat_assign( var_index=icorr_chi_eta_2, & + var_name="corr_chi_eta_2", & + var_description="Correlation of chi (s) and" & + // " eta (t) (2nd PDF component) [-]", & + var_units="-", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrtthl') + irrtthl = k + + call stat_assign( var_index=irrtthl, var_name="rrtthl", & + var_description="Correlation of rt and thl" & + // " (both PDF components) [-]", var_units="-", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('crt_1') + icrt_1 = k + + call stat_assign( var_index=icrt_1, var_name="crt_1", & + var_description="Coefficient on rt in chi/eta" & + // " equations (1st PDF comp.) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('crt_2') + icrt_2 = k + + call stat_assign( var_index=icrt_2, var_name="crt_2", & + var_description="Coefficient on rt in chi/eta" & + // " equations (2nd PDF comp.) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('cthl_1') + icthl_1 = k + + call stat_assign( var_index=icthl_1, var_name="cthl_1", & + var_description="Coefficient on theta-l in chi/eta" & + // " equations (1st PDF comp.) [kg/kg/K]", & + var_units="kg/kg/K", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('cthl_2') + icthl_2 = k + + call stat_assign( var_index=icthl_2, var_name="cthl_2", & + var_description="Coefficient on theta-l in chi/eta" & + // " equations (2nd PDF comp.) [kg/kg/K]", & + var_units="kg/kg/K", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + + case('wp2_zt') + iwp2_zt = k + + call stat_assign( var_index=iwp2_zt, var_name="wp2_zt", & + var_description="w'^2 interpolated to thermodyamic levels [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case('thlp2_zt') + ithlp2_zt = k + + call stat_assign( var_index=ithlp2_zt, var_name="thlp2_zt", & + var_description="thl'^2 interpolated to thermodynamic levels [K^2]", & + var_units="K^2", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case('wpthlp_zt') + iwpthlp_zt = k + + call stat_assign( var_index=iwpthlp_zt, var_name="wpthlp_zt", & + var_description="w'thl' interpolated to thermodynamic levels [(m K)/s]", & + var_units="(m K)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case('wprtp_zt') + iwprtp_zt = k + + call stat_assign( var_index=iwprtp_zt, var_name="wprtp_zt", & + var_description="w'rt' interpolated to thermodynamic levels [(m kg)/(s kg)]", & + var_units="(m kg)/(s kg)", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case('rtp2_zt') + irtp2_zt = k + + call stat_assign( var_index=irtp2_zt, var_name="rtp2_zt", & + var_description="rt'^2 interpolated to thermodynamic levels [(kg/kg)^2]", & + var_units="(kg/kg)^2", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case('rtpthlp_zt') + irtpthlp_zt = k + + call stat_assign( var_index=irtpthlp_zt, var_name="rtpthlp_zt", & + var_description="rt'thl' interpolated to thermodynamic levels [(kg K)/kg]", & + var_units="(kg K)/kg", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('up2_zt') + iup2_zt = k + call stat_assign( var_index=iup2_zt, var_name="up2_zt", & + var_description="u'^2 interpolated to thermodynamic levels [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('vp2_zt') + ivp2_zt = k + call stat_assign( var_index=ivp2_zt, var_name="vp2_zt", & + var_description="v'^2 interpolated to thermodynamic levels [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('upwp_zt') + iupwp_zt = k + call stat_assign( var_index=iupwp_zt, var_name="upwp_zt", & + var_description="u'w' interpolated to thermodynamic levels [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('vpwp_zt') + ivpwp_zt = k + call stat_assign( var_index=ivpwp_zt, var_name="vpwp_zt", & + var_description="v'w' interpolated to thermodynamic levels [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Skw_zt') + iSkw_zt = k + call stat_assign( var_index=iSkw_zt, var_name="Skw_zt", & + var_description="Skewness of w on thermodynamic levels [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + ! Hydrometeor overall variances for each hydrometeor type. + case('hmp2_zt') + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The overall variance of the hydrometeor. + ihmp2_zt(hm_idx) = k + + if ( l_mix_rat_hm(hm_idx) ) then + + call stat_assign( var_index=ihmp2_zt(hm_idx), & + var_name=trim( hm_type(1:2) )//"p2_zt", & + var_description="<" & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // "'^2> on thermodyamic levels (from " & + // "integration over PDF) [(kg/kg)^2]", & + var_units="(kg/kg)^2", & + l_silhs=.false., grid_kind=stats_zt ) + + else ! Concentration + + call stat_assign( var_index=ihmp2_zt(hm_idx), & + var_name=trim( hm_type(1:2) )//"p2_zt", & + var_description="<" & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // "'^2> on thermodyamic levels (from " & + // "integration over PDF) [(num/kg)^2]", & + var_units="(num/kg)^2", & + l_silhs=.false., grid_kind=stats_zt ) + + endif ! l_mix_rat_hm(hm_idx) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ('C11_Skw_fnc') + iC11_Skw_fnc = k + + call stat_assign( var_index=iC11_Skw_fnc, var_name="C11_Skw_fnc", & + var_description="C_11 parameter with Sk_w applied [-]", var_units="count", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('chi') + ichi = k + + call stat_assign( var_index=ichi, var_name="chi", & + var_description="Mellor's s (extended liq) [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ( 'a3_coef_zt' ) + ia3_coef_zt = k + call stat_assign( var_index=ia3_coef_zt, var_name="a3_coef_zt", & + var_description="The a3 coefficient interpolated the the zt grid [-]", & + var_units="count", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ( 'wp3_on_wp2_zt' ) + iwp3_on_wp2_zt = k + call stat_assign( var_index=iwp3_on_wp2_zt, var_name="wp3_on_wp2_zt", & + var_description="Smoothed version of wp3 / wp2 [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + ! Adjusted overall correlation of w and a hydrometeor for each hydrometeor + ! type. The adjusted overall correlation is the overall correlation of w + ! and a hydrometeor multiplied by a constant tunable parameter that has a + ! value between 0 and 1, inclusive. + case ( 'corr_w_hm_ov_adj' ) + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The adjusted overall correlation of w and the hydrometeor. + icorr_w_hm_ov_adj(hm_idx) = k + + call stat_assign( var_index=icorr_w_hm_ov_adj(hm_idx), & + var_name="corr_w_"//trim( hm_type(1:2) ) & + //"_ov_adj", & + var_description="Adjusted overall correlation " & + // "of w and " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " [-]", & + var_units="-", l_silhs=.false., & + grid_kind=stats_zt ) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + ! Hydrometeor component mean values for each PDF component and hydrometeor + ! type. + case ( "hmi" ) + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The mean of the hydrometeor in the 1st PDF component. + ihm1(hm_idx) = k + + if ( l_mix_rat_hm(hm_idx) ) then + + call stat_assign( var_index=ihm1(hm_idx), & + var_name=trim( hm_type(1:2) )//"1", & + var_description="Mean of " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [kg/kg]", & + var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + else ! Concentration + + call stat_assign( var_index=ihm1(hm_idx), & + var_name=trim( hm_type(1:2) )//"1", & + var_description="Mean of " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [num/kg]", & + var_units="num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + endif ! l_mix_rat_hm(hm_idx) + + k = k + 1 + + ! The mean of the hydrometeor in the 2nd PDF component. + ihm2(hm_idx) = k + + if ( l_mix_rat_hm(hm_idx) ) then + + call stat_assign( var_index=ihm2(hm_idx), & + var_name=trim( hm_type(1:2) )//"2", & + var_description="Mean of " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [kg/kg]", & + var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + else ! Concentration + + call stat_assign( var_index=ihm2(hm_idx), & + var_name=trim( hm_type(1:2) )//"2", & + var_description="Mean of " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [num/kg]", & + var_units="num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + endif ! l_mix_rat_hm(hm_idx) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ( 'LWP1' ) + iLWP1 = k + call stat_assign( var_index=iLWP1, var_name="LWP1", & + var_description="Liquid water path (1st PDF component) [kg/m^2]", & + var_units="kg/m^2", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ( 'LWP2' ) + iLWP2 = k + call stat_assign( var_index=iLWP2, var_name="LWP2", & + var_description="Liquid water path (2nd PDF component) [kg/m^2]", & + var_units="kg/m^2", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ( 'precip_frac' ) + iprecip_frac = k + call stat_assign( var_index=iprecip_frac, var_name="precip_frac", & + var_description="Precipitation Fraction [-]", var_units="-", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ( 'precip_frac_1' ) + iprecip_frac_1 = k + call stat_assign( var_index=iprecip_frac_1, var_name="precip_frac_1", & + var_description="Precipitation Fraction (1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ( 'precip_frac_2' ) + iprecip_frac_2 = k + call stat_assign( var_index=iprecip_frac_2, var_name="precip_frac_2", & + var_description="Precipitation Fraction (2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ( 'Ncnm' ) + iNcnm = k + call stat_assign( var_index=iNcnm, var_name="Ncnm", & + var_description="Cloud nuclei concentration (PDF) [num/kg]", & + var_units="num/kg", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + ! Hydrometeor component mean values (in-precip) for each PDF component and + ! hydrometeor type. + case ( 'mu_hm_i' ) + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The in-precip mean of the hydrometeor in the 1st PDF component. + imu_hm_1(hm_idx) = k + + if ( l_mix_rat_hm(hm_idx) ) then + + call stat_assign( var_index=imu_hm_1(hm_idx), & + var_name="mu_"//trim( hm_type(1:2) )//"_1", & + var_description="Mean (in-precip) of " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [kg/kg]", & + var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + else ! Concentration + + call stat_assign( var_index=imu_hm_1(hm_idx), & + var_name="mu_"//trim( hm_type(1:2) )//"_1", & + var_description="Mean (in-precip) of " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [num/kg]", & + var_units="num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + endif ! l_mix_rat_hm(hm_idx) + + k = k + 1 + + ! The in-precip mean of the hydrometeor in the 2nd PDF component. + imu_hm_2(hm_idx) = k + + if ( l_mix_rat_hm(hm_idx) ) then + + call stat_assign( var_index=imu_hm_2(hm_idx), & + var_name="mu_"//trim( hm_type(1:2) )//"_2", & + var_description="Mean (in-precip) of " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [kg/kg]", & + var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + else ! Concentration + + call stat_assign( var_index=imu_hm_2(hm_idx), & + var_name="mu_"//trim( hm_type(1:2) )//"_2", & + var_description="Mean (in-precip) of " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [num/kg]", & + var_units="num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + endif ! l_mix_rat_hm(hm_idx) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ( 'mu_Ncn_i' ) + + imu_Ncn_1 = k + + call stat_assign( var_index=imu_Ncn_1, & + var_name="mu_Ncn_1", & + var_description="Mean of N_cn (1st PDF component) " & + // "[num/kg]", var_units="num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + imu_Ncn_2 = k + + call stat_assign( var_index=imu_Ncn_2, & + var_name="mu_Ncn_2", & + var_description="Mean of N_cn (2nd PDF component) " & + // "[num/kg]", var_units="num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! Hydrometeor component mean values (in-precip) for ln hm for each PDF + ! component and hydrometeor type. + case ( 'mu_hm_i_n' ) + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The in-precip mean of ln hm in the 1st PDF component. + imu_hm_1_n(hm_idx) = k + + if ( l_mix_rat_hm(hm_idx) ) then + + call stat_assign( var_index=imu_hm_1_n(hm_idx), & + var_name="mu_"//trim( hm_type(1:2) )//"_1_n", & + var_description="Mean (in-precip) of ln " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [ln(kg/kg)]", & + var_units="ln(kg/kg)", & + l_silhs=.false., grid_kind=stats_zt ) + + else ! Concentration + + call stat_assign( var_index=imu_hm_1_n(hm_idx), & + var_name="mu_"//trim( hm_type(1:2) )//"_1_n", & + var_description="Mean (in-precip) of ln " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [ln(num/kg)]", & + var_units="ln(num/kg)", & + l_silhs=.false., grid_kind=stats_zt ) + + endif ! l_mix_rat_hm(hm_idx) + + k = k + 1 + + ! The in-precip mean of ln hm in the 2nd PDF component. + imu_hm_2_n(hm_idx) = k + + if ( l_mix_rat_hm(hm_idx) ) then + + call stat_assign( var_index=imu_hm_2_n(hm_idx), & + var_name="mu_"//trim( hm_type(1:2) )//"_2_n", & + var_description="Mean (in-precip) of ln " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [ln(kg/kg)]", & + var_units="ln(kg/kg)", & + l_silhs=.false., grid_kind=stats_zt ) + + else ! Concentration + + call stat_assign( var_index=imu_hm_2_n(hm_idx), & + var_name="mu_"//trim( hm_type(1:2) )//"_2_n", & + var_description="Mean (in-precip) of ln " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [ln(num/kg)]", & + var_units="ln(num/kg)", & + l_silhs=.false., grid_kind=stats_zt ) + + endif ! l_mix_rat_hm(hm_idx) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ( 'mu_Ncn_i_n' ) + + imu_Ncn_1_n = k + + call stat_assign( var_index=imu_Ncn_1_n, & + var_name="mu_Ncn_1_n", & + var_description="Mean of ln N_cn " & + // "(1st PDF component) [ln(num/kg)]", & + var_units="ln(num/kg)", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + imu_Ncn_2_n = k + + call stat_assign( var_index=imu_Ncn_2_n, & + var_name="mu_Ncn_2_n", & + var_description="Mean of ln N_cn " & + // "(2nd PDF component) [ln(num/kg)]", & + var_units="ln(num/kg)", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! Hydrometeor component standard deviations (in-precip) for each PDF + ! component and hydrometeor type. + case ( 'sigma_hm_i' ) + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The in-precip standard deviation of the hydrometeor in the 1st PDF + ! component. + isigma_hm_1(hm_idx) = k + + if ( l_mix_rat_hm(hm_idx) ) then + + call stat_assign( var_index=isigma_hm_1(hm_idx), & + var_name="sigma_" & + // trim( hm_type(1:2) )//"_1", & + var_description="Standard deviation " & + // "(in-precip) of " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [kg/kg]", & + var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + else ! Concentration + + call stat_assign( var_index=isigma_hm_1(hm_idx), & + var_name="sigma_" & + // trim( hm_type(1:2) )//"_1", & + var_description="Standard deviation " & + // "(in-precip) of " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [num/kg]", & + var_units="num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + endif ! l_mix_rat_hm(hm_idx) + + k = k + 1 + + ! The in-precip standard deviation of the hydrometeor in the 2nd PDF + ! component. + isigma_hm_2(hm_idx) = k + + if ( l_mix_rat_hm(hm_idx) ) then + + call stat_assign( var_index=isigma_hm_2(hm_idx), & + var_name="sigma_" & + // trim( hm_type(1:2) )//"_2", & + var_description="Standard deviation " & + // "(in-precip) of " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [kg/kg]", & + var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + else ! Concentration + + call stat_assign( var_index=isigma_hm_2(hm_idx), & + var_name="sigma_" & + // trim( hm_type(1:2) )//"_2", & + var_description="Standard deviation " & + // "(in-precip) of " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [num/kg]", & + var_units="num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + endif ! l_mix_rat_hm(hm_idx) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ( 'sigma_Ncn_i' ) + + isigma_Ncn_1 = k + + call stat_assign( var_index=isigma_Ncn_1, & + var_name="sigma_Ncn_1", & + var_description="Standard deviation of N_cn " & + // "(1st PDF component) [num/kg]", & + var_units="num/kg", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + isigma_Ncn_2 = k + + call stat_assign( var_index=isigma_Ncn_2, & + var_name="sigma_Ncn_2", & + var_description="Standard deviation of N_cn " & + // "(2nd PDF component) [num/kg]", & + var_units="num/kg", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! Hydrometeor component standard deviations (in-precip) for ln hm for each + ! PDF component and hydrometeor type. + case ( 'sigma_hm_i_n' ) + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The in-precip standard deviation of ln hm in the 1st PDF + ! component. + isigma_hm_1_n(hm_idx) = k + + call stat_assign( var_index=isigma_hm_1_n(hm_idx), & + var_name="sigma_" & + // trim( hm_type(1:2) )//"_1_n", & + var_description="Standard deviation " & + // "(in-precip) of ln " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [-]", & + var_units="-", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! The in-precip standard deviation of ln hm in the 2nd PDF + ! component. + isigma_hm_2_n(hm_idx) = k + + call stat_assign( var_index=isigma_hm_2_n(hm_idx), & + var_name="sigma_" & + // trim( hm_type(1:2) )//"_2_n", & + var_description="Standard deviation " & + // "(in-precip) of ln " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [-]", & + var_units="-", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ( 'sigma_Ncn_i_n' ) + + isigma_Ncn_1_n = k + + call stat_assign( var_index=isigma_Ncn_1_n, & + var_name="sigma_Ncn_1_n", & + var_description="Standard deviation of ln N_cn " & + // "(1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + isigma_Ncn_2_n = k + + call stat_assign( var_index=isigma_Ncn_2_n, & + var_name="sigma_Ncn_2_n", & + var_description="Standard deviation of ln N_cn " & + // "(2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('corr_w_chi_1') + icorr_w_chi_1 = k + + call stat_assign( var_index=icorr_w_chi_1, var_name="corr_w_chi_1", & + var_description="Correlation of w and chi" & + // " (1st PDF component) -- should be 0 by" & + // " CLUBB standards [-]", var_units="-", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('corr_w_chi_2') + icorr_w_chi_2 = k + + call stat_assign( var_index=icorr_w_chi_2, var_name="corr_w_chi_2", & + var_description="Correlation of w and chi" & + // " (2nd PDF component) -- should be 0 by" & + // " CLUBB standards [-]", var_units="-", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('corr_w_eta_1') + icorr_w_eta_1 = k + + call stat_assign( var_index=icorr_w_eta_1, var_name="corr_w_eta_1", & + var_description="Correlation of w and eta" & + // " (1st PDF component) -- should be 0 by" & + // " CLUBB standards [-]", var_units="-", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('corr_w_eta_2') + icorr_w_eta_2 = k + + call stat_assign( var_index=icorr_w_eta_2, var_name="corr_w_eta_2", & + var_description="Correlation of w and eta" & + // " (2nd PDF component) -- should be 0 by" & + // " CLUBB standards [-]", var_units="-", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + ! Correlation of w and a hydrometeor (in-precip) for each PDF + ! component and hydrometeor type. + case ( 'corr_w_hm_i' ) + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The in-precip correlation of w and the hydrometeor in the + ! 1st PDF component. + icorr_w_hm_1(hm_idx) = k + + call stat_assign( var_index=icorr_w_hm_1(hm_idx), & + var_name="corr_w_"//trim( hm_type(1:2) )//"_1", & + var_description="Correlation (in-precip) " & + // "of w and " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! The in-precip correlation of w and the hydrometeor in the + ! 2nd PDF component. + icorr_w_hm_2(hm_idx) = k + + call stat_assign( var_index=icorr_w_hm_2(hm_idx), & + var_name="corr_w_"//trim( hm_type(1:2) )//"_2", & + var_description="Correlation (in-precip) " & + // "of w and " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ( 'corr_w_Ncn_i' ) + + icorr_w_Ncn_1 = k + + call stat_assign( var_index=icorr_w_Ncn_1, & + var_name="corr_w_Ncn_1", & + var_description="Correlation of w and N_cn " & + // "(1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + icorr_w_Ncn_2 = k + + call stat_assign( var_index=icorr_w_Ncn_2, & + var_name="corr_w_Ncn_2", & + var_description="Correlation of w and N_cn " & + // "(2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('corr_chi_eta_1_ca') + icorr_chi_eta_1_ca = k + + call stat_assign( var_index=icorr_chi_eta_1_ca, & + var_name="corr_chi_eta_1_ca", & + var_description="Correlation of chi (s) and" & + // " eta (t) (1st PDF component) found in the" & + // " correlation array [-]", var_units="-", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('corr_chi_eta_2_ca') + icorr_chi_eta_2_ca = k + + call stat_assign( var_index=icorr_chi_eta_2_ca, & + var_name="corr_chi_eta_2_ca", & + var_description="Correlation of chi (s) and" & + // " eta (t) (2nd PDF component) found in the" & + // " correlation array [-]", var_units="-", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + ! Correlation of chi(s) and a hydrometeor (in-precip) for each PDF + ! component and hydrometeor type. + case ( 'corr_chi_hm_i' ) + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The in-precip correlation of chi and the hydrometeor in the + ! 1st PDF component. + icorr_chi_hm_1(hm_idx) = k + + call stat_assign( var_index=icorr_chi_hm_1(hm_idx), & + var_name="corr_chi_"//trim(hm_type(1:2))//"_1", & + var_description="Correlation (in-precip) " & + // "of chi (s) and " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! The in-precip correlation of chi and the hydrometeor in the + ! 2nd PDF component. + icorr_chi_hm_2(hm_idx) = k + + call stat_assign( var_index=icorr_chi_hm_2(hm_idx), & + var_name="corr_chi_"//trim(hm_type(1:2))//"_2", & + var_description="Correlation (in-precip) " & + // "of chi (s) and " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ( 'corr_chi_Ncn_i' ) + + icorr_chi_Ncn_1 = k + + call stat_assign( var_index=icorr_chi_Ncn_1, & + var_name="corr_chi_Ncn_1", & + var_description="Correlation of chi and N_cn " & + // "(1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + icorr_chi_Ncn_2 = k + + call stat_assign( var_index=icorr_chi_Ncn_2, & + var_name="corr_chi_Ncn_2", & + var_description="Correlation of chi and N_cn " & + // "(2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! Correlation of eta(t) and a hydrometeor (in-precip) for each PDF + ! component and hydrometeor type. + case ( 'corr_eta_hm_i' ) + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The in-precip correlation of eta and the hydrometeor in the + ! 1st PDF component. + icorr_eta_hm_1(hm_idx) = k + + call stat_assign( var_index=icorr_eta_hm_1(hm_idx), & + var_name="corr_eta_"//trim(hm_type(1:2))//"_1", & + var_description="Correlation (in-precip) " & + // "of eta (t) and " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! The in-precip correlation of eta and the hydrometeor in the + ! 2nd PDF component. + icorr_eta_hm_2(hm_idx) = k + + call stat_assign( var_index=icorr_eta_hm_2(hm_idx), & + var_name="corr_eta_"//trim(hm_type(1:2))//"_2", & + var_description="Correlation (in-precip) " & + // "of eta (t) and " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ( 'corr_eta_Ncn_i' ) + + icorr_eta_Ncn_1 = k + + call stat_assign( var_index=icorr_eta_Ncn_1, & + var_name="corr_eta_Ncn_1", & + var_description="Correlation of eta and N_cn " & + // "(1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + icorr_eta_Ncn_2 = k + + call stat_assign( var_index=icorr_eta_Ncn_2, & + var_name="corr_eta_Ncn_2", & + var_description="Correlation of eta and N_cn " & + // "(2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! Correlation of Ncn and a hydrometeor (in-precip) for each PDF + ! component and hydrometeor type. + case ( 'corr_Ncn_hm_i' ) + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The in-precip correlation of Ncn and the hydrometeor in the + ! 1st PDF component. + icorr_Ncn_hm_1(hm_idx) = k + + call stat_assign( var_index=icorr_Ncn_hm_1(hm_idx), & + var_name="corr_Ncn_"//trim(hm_type(1:2))//"_1", & + var_description="Correlation (in-precip) " & + // "of N_cn and " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! The in-precip correlation of Ncn and the hydrometeor in the + ! 2nd PDF component. + icorr_Ncn_hm_2(hm_idx) = k + + call stat_assign( var_index=icorr_Ncn_hm_2(hm_idx), & + var_name="corr_Ncn_"//trim(hm_type(1:2))//"_2", & + var_description="Correlation (in-precip) " & + // "of N_cn and " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + ! Correlation (in-precip) of two different hydrometeors (hmx and hmy) + ! for each PDF component and hydrometeor type. + case ( 'corr_hmx_hmy_i' ) + + do hmx_idx = 1, hydromet_dim, 1 + + hmx_type = hydromet_list(hmx_idx) + + do hmy_idx = hmx_idx+1, hydromet_dim, 1 + + hmy_type = hydromet_list(hmy_idx) + + ! The in-precip correlation of hmx and hmy in the 1st PDF + ! component. + icorr_hmx_hmy_1(hmy_idx,hmx_idx) = k + + call stat_assign( var_index=icorr_hmx_hmy_1(hmy_idx,hmx_idx), & + var_name="corr_"//trim( hmx_type(1:2) )//"_" & + // trim( hmy_type(1:2) )//"_1", & + var_description="Correlation (in-precip) " & + // "of " & + // hmx_type(1:1)//"_"//trim( hmx_type(2:2) ) & + // " and " & + // hmy_type(1:1)//"_"//trim( hmy_type(2:2) ) & + // " (1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! The in-precip correlation of hmx and hmy in the 2nd PDF + ! component. + icorr_hmx_hmy_2(hmy_idx,hmx_idx) = k + + call stat_assign( var_index=icorr_hmx_hmy_2(hmy_idx,hmx_idx), & + var_name="corr_"//trim( hmx_type(1:2) )//"_" & + // trim( hmy_type(1:2) )//"_2", & + var_description="Correlation (in-precip) " & + // "of " & + // hmx_type(1:1)//"_"//trim( hmx_type(2:2) ) & + // " and " & + // hmy_type(1:1)//"_"//trim( hmy_type(2:2) ) & + // " (2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + enddo ! hmy_idx = hmx_idx+1, hydromet_dim, 1 + + enddo ! hmx_idx = 1, hydromet_dim, 1 + + ! Correlation (in-precip) of w and ln hm for each PDF component and + ! hydrometeor type. + case ( 'corr_w_hm_i_n' ) + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The in-precip correlation of w and ln hm in the 1st PDF + ! component. + icorr_w_hm_1_n(hm_idx) = k + + call stat_assign( var_index=icorr_w_hm_1_n(hm_idx), & + var_name="corr_w_"//trim(hm_type(1:2))//"_1_n", & + var_description="Correlation (in-precip) " & + // "of w and ln " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! The in-precip correlation of w and ln hm in the 2nd PDF + ! component. + icorr_w_hm_2_n(hm_idx) = k + + call stat_assign( var_index=icorr_w_hm_2_n(hm_idx), & + var_name="corr_w_"//trim(hm_type(1:2))//"_2_n", & + var_description="Correlation (in-precip) " & + // "of w and ln " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ( 'corr_w_Ncn_i_n' ) + + icorr_w_Ncn_1_n = k + + call stat_assign( var_index=icorr_w_Ncn_1_n, & + var_name="corr_w_Ncn_1_n", & + var_description="Correlation of w and " & + // "ln N_cn (1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + icorr_w_Ncn_2_n = k + + call stat_assign( var_index=icorr_w_Ncn_2_n, & + var_name="corr_w_Ncn_2_n", & + var_description="Correlation of w and " & + // "ln N_cn (2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! Correlation (in-precip) of chi and ln hm for each PDF component and + ! hydrometeor type. + case ( 'corr_chi_hm_i_n' ) + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The in-precip correlation of chi and ln hm in the 1st PDF + ! component. + icorr_chi_hm_1_n(hm_idx) = k + + call stat_assign( var_index=icorr_chi_hm_1_n(hm_idx), & + var_name="corr_chi_"//trim(hm_type(1:2)) & + // "_1_n", & + var_description="Correlation (in-precip) " & + // "of chi (s) and ln " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! The in-precip correlation of chi(s) and ln hm in the 2nd PDF + ! component. + icorr_chi_hm_2_n(hm_idx) = k + + call stat_assign( var_index=icorr_chi_hm_2_n(hm_idx), & + var_name="corr_chi_"//trim(hm_type(1:2)) & + // "_2_n", & + var_description="Correlation (in-precip) " & + // "of chi (s) and ln " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ( 'corr_chi_Ncn_i_n' ) + + icorr_chi_Ncn_1_n = k + + call stat_assign( var_index=icorr_chi_Ncn_1_n, & + var_name="corr_chi_Ncn_1_n", & + var_description="Correlation of chi (s) and " & + // "ln N_cn (1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + icorr_chi_Ncn_2_n = k + + call stat_assign( var_index=icorr_chi_Ncn_2_n, & + var_name="corr_chi_Ncn_2_n", & + var_description="Correlation of chi (s) and " & + // "ln N_cn (2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! Correlation (in-precip) of eta and ln hm for each PDF component and + ! hydrometeor type. + case ( 'corr_eta_hm_i_n' ) + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The in-precip correlation of eta and ln hm in the 1st PDF + ! component. + icorr_eta_hm_1_n(hm_idx) = k + + call stat_assign( var_index=icorr_eta_hm_1_n(hm_idx), & + var_name="corr_eta_"//trim( hm_type(1:2) ) & + // "_1_n", & + var_description="Correlation (in-precip) " & + // "of eta (t) and ln " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! The in-precip correlation of eta and ln hm in the 2nd PDF + ! component. + icorr_eta_hm_2_n(hm_idx) = k + + call stat_assign( var_index=icorr_eta_hm_2_n(hm_idx), & + var_name="corr_eta_"//trim( hm_type(1:2) ) & + // "_2_n", & + var_description="Correlation (in-precip) " & + // "of eta(t) and ln " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ( 'corr_eta_Ncn_i_n' ) + + icorr_eta_Ncn_1_n = k + + call stat_assign( var_index=icorr_eta_Ncn_1_n, & + var_name="corr_eta_Ncn_1_n", & + var_description="Correlation of eta (t) and " & + // "ln N_cn (1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + icorr_eta_Ncn_2_n = k + + call stat_assign( var_index=icorr_eta_Ncn_2_n, & + var_name="corr_eta_Ncn_2_n", & + var_description="Correlation of eta (t) and " & + // "ln N_cn (2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! Correlation (in-precip) of ln Ncn and ln hm for each PDF component + ! and hydrometeor type. + case ( 'corr_Ncn_hm_i_n' ) + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The in-precip correlation of ln Ncn and ln hm in the 1st PDF + ! component. + icorr_Ncn_hm_1_n(hm_idx) = k + + call stat_assign( var_index=icorr_Ncn_hm_1_n(hm_idx), & + var_name="corr_Ncn_"//trim(hm_type(1:2)) & + // "_1_n", & + var_description="Correlation (in-precip) " & + // "of ln N_cn and ln " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! The in-precip correlation of ln Ncn and ln hm in the 2nd PDF + ! component. + icorr_Ncn_hm_2_n(hm_idx) = k + + call stat_assign( var_index=icorr_Ncn_hm_2_n(hm_idx), & + var_name="corr_Ncn_"//trim(hm_type(1:2)) & + // "_2_n", & + var_description="Correlation (in-precip) " & + // "of ln N_cn and ln " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + ! Correlation (in-precip) of ln hmx and ln hmy (hmx and hmy are two + ! different hydrometeors) for each PDF component and hydrometeor type. + case ( 'corr_hmx_hmy_i_n' ) + + do hmx_idx = 1, hydromet_dim, 1 + + hmx_type = hydromet_list(hmx_idx) + + do hmy_idx = hmx_idx+1, hydromet_dim, 1 + + hmy_type = hydromet_list(hmy_idx) + + ! The in-precip correlation of ln hmx and ln hmy in the 1st + ! PDF component. + icorr_hmx_hmy_1_n(hmy_idx,hmx_idx) = k + + call stat_assign( var_index=icorr_hmx_hmy_1_n(hmy_idx,hmx_idx), & + var_name="corr_"//trim( hmx_type(1:2) )//"_" & + // trim( hmy_type(1:2) )//"_1_n", & + var_description="Correlation (in-precip) " & + // "of ln " & + // hmx_type(1:1)//"_"//trim( hmx_type(2:2) ) & + // " and ln " & + // hmy_type(1:1)//"_"//trim( hmy_type(2:2) ) & + // " (1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! The in-precip correlation of ln hmx and ln hmy in the 2nd + ! PDF component. + icorr_hmx_hmy_2_n(hmy_idx,hmx_idx) = k + + call stat_assign( var_index=icorr_hmx_hmy_2_n(hmy_idx,hmx_idx), & + var_name="corr_"//trim( hmx_type(1:2) )//"_" & + // trim( hmy_type(1:2) )//"_2_n", & + var_description="Correlation (in-precip) " & + // "of ln " & + // hmx_type(1:1)//"_"//trim( hmx_type(2:2) ) & + // " and ln " & + // hmy_type(1:1)//"_"//trim( hmy_type(2:2) ) & + // " (2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + enddo ! hmy_idx = hmx_idx+1, hydromet_dim, 1 + + enddo ! hmx_idx = 1, hydromet_dim, 1 + + ! Third-order mixed moment < w'^2 hm' >, where hm is a hydrometeor. + case ('wp2hmp') + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + iwp2hmp(hm_idx) = k + + if ( l_mix_rat_hm(hm_idx) ) then + + call stat_assign( var_index=iwp2hmp(hm_idx), & + var_name="wp2"//trim( hm_type(1:2) )//"p", & + var_description="Third-order moment < w'^2 " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // "' > [(m/s)^2 kg/kg]", & + var_units="(m/s)^2 kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + else ! Concentration + + call stat_assign( var_index=iwp2hmp(hm_idx), & + var_name="wp2"//trim( hm_type(1:2) )//"p", & + var_description="Third-order moment < w'^2 " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // "' > [(m/s)^2 num/kg]", & + var_units="(m/s)^2 num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + endif ! l_mix_rat_hm(hm_idx) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ('cloud_frac_refined') + icloud_frac_refined = k + call stat_assign( var_index=icloud_frac_refined, var_name="cloud_frac_refined", & + var_description="Cloud fraction computed on refined grid [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rcm_refined') + ircm_refined = k + call stat_assign( var_index=ircm_refined, var_name="rcm_refined", & + var_description="Cloud water mixing ratio computed on refined grid & + &[kg/kg]", var_units="kg/kg", l_silhs=.false., grid_kind=stats_zt) + k = k + 1 + + case ('hl_on_Cp_residual') + ihl_on_Cp_residual = k + call stat_assign( var_index=ihl_on_Cp_residual, var_name="hl_on_Cp_residual", & + var_description="Residual change in HL/Cp from Morrison microphysics & + ¬ due to sedimentation [K]", & + var_units="K", l_silhs=.true., grid_kind=stats_zt) + k = k + 1 + + case ('qto_residual') + iqto_residual = k + call stat_assign( var_index=iqto_residual, var_name="qto_residual", & + var_description="Residual change in total water from Morrison & + µphysics not due to sedimentation [kg/kg]", & + var_units="kg/kg", l_silhs=.true., grid_kind=stats_zt) + k = k + 1 + + + case default + + l_found = .false. + + j = 1 + + do while( j <= sclr_dim .and. .not. l_found) + write(sclr_idx, * ) j + + sclr_idx = adjustl(sclr_idx) + + if(trim(vars_zt(i)) == "sclr"//trim(sclr_idx)//"m" .and. .not. l_found) then + + isclrm(j) = k + + call stat_assign( var_index=isclrm(j), var_name="sclr"//trim(sclr_idx)//"m", & + var_description="passive scalar "//trim(sclr_idx), var_units="unknown", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + l_found = .true. + + else if(trim(vars_zt(i)) == "sclr"//trim(sclr_idx)//"m_f" .and. .not. l_found) then + + isclrm_f(j) = k + + call stat_assign( var_index=isclrm_f(j), var_name="sclr"//trim(sclr_idx)//"m_f", & + var_description="passive scalar forcing "//trim(sclr_idx), var_units="unknown", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + l_found = .true. + + endif + + j = j + 1 + end do + + j = 1 + + do while( j <= edsclr_dim .and. .not. l_found) + + write(sclr_idx, * ) j + + sclr_idx = adjustl(sclr_idx) + + if(trim(vars_zt(i)) == "edsclr"//trim(sclr_idx)//"m" .and. .not. l_found ) then + + iedsclrm(j) = k + + call stat_assign( var_index=iedsclrm(j), var_name="edsclr"//trim(sclr_idx)//"m", & + var_description="passive scalar "//trim(sclr_idx), var_units="unknown", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + l_found = .true. + + else if(trim(vars_zt(i)) == "edsclr"//trim(sclr_idx)//"m_f" .and. .not. l_found) then + + iedsclrm_f(j) = k + + call stat_assign( var_index=iedsclrm_f(j), var_name="edsclr"//trim(sclr_idx)//"m_f", & + var_description="passive scalar forcing "//trim(sclr_idx), var_units="unknown", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + l_found = .true. + + endif + + j = j + 1 + + end do + + if (.not. l_found ) then + + write(fstderr,*) 'Error: unrecognized variable in vars_zt: ', trim( vars_zt(i) ) + + l_error = .true. ! This will stop the run. + + end if + + end select ! trim( vars_zt ) + + + end do ! i=1,stats_zt%num_output_fields + + + return + + end subroutine stats_init_zt + +!=============================================================================== + +end module stats_zt_module diff --git a/models/atm/cam/src/physics/clubb/surface_varnce_module.F90 b/models/atm/cam/src/physics/clubb/surface_varnce_module.F90 index da2835493df2..a55e46e09dc9 100644 --- a/models/atm/cam/src/physics/clubb/surface_varnce_module.F90 +++ b/models/atm/cam/src/physics/clubb/surface_varnce_module.F90 @@ -1,4 +1,5 @@ -! $Id: surface_varnce_module.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +!------------------------------------------------------------------------- +! $Id: surface_varnce_module.F90 6952 2014-06-17 15:59:47Z schemena@uwm.edu $ !=============================================================================== module surface_varnce_module @@ -10,52 +11,61 @@ module surface_varnce_module contains -!============================================================================= + !============================================================================= subroutine surface_varnce( upwp_sfc, vpwp_sfc, wpthlp_sfc, wprtp_sfc, & - um_sfc, vm_sfc, wpsclrp_sfc, & + um_sfc, vm_sfc, Lscale_up_sfc, wpsclrp_sfc, & wp2_sfc, up2_sfc, vp2_sfc, & thlp2_sfc, rtp2_sfc, rtpthlp_sfc, err_code, & sclrp2_sfc, & sclrprtp_sfc, & sclrpthlp_sfc ) -! Description: -! This subroutine computes estimate of the surface thermodynamic -! second order moments. + ! Description: + ! This subroutine computes estimate of the surface thermodynamic and wind + ! component second order moments. -! References: -! None -!------------------------------------------------------------------------------- + ! References: + ! Andre, J. C., G. De Moor, P. Lacarrere, G. Therry, and R. Du Vachat, 1978. + ! Modeling the 24-Hour Evolution of the Mean and Turbulent Structures of + ! the Planetary Boundary Layer. J. Atmos. Sci., 35, 1861 -- 1883. + !----------------------------------------------------------------------- use parameters_model, only: & - T0 ! Variable(s) - - use constants_clubb, only: & - grav, & ! Variable(s) - eps, & - fstderr + T0 ! Variable(s) + + use constants_clubb, only: & + four, & ! Variable(s) + two, & + one, & + two_thirds, & + one_third, & + one_fourth, & + zero, & + grav, & + eps, & + fstderr use parameters_model, only: & - sclr_dim ! Variable(s) + sclr_dim ! Variable(s) use numerical_check, only: & - surface_varnce_check ! Procedure + surface_varnce_check ! Procedure use error_code, only: & - clubb_var_equals_NaN, & ! Variable(s) - clubb_at_least_debug_level, & - clubb_no_error ! Constant + clubb_var_equals_NaN, & ! Variable(s) + clubb_at_least_debug_level, & + clubb_no_error ! Constant use array_index, only: & - iisclr_rt, & ! Index for a scalar emulating rt - iisclr_thl ! Index for a scalar emulating thetal + iisclr_rt, & ! Index for a scalar emulating rt + iisclr_thl ! Index for a scalar emulating thetal - use stats_type, only: & - stat_end_update_pt, & ! Procedure(s) - stat_update_var_pt + use stats_type_utilities, only: & + stat_end_update_pt, & ! Procedure(s) + stat_update_var_pt use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) implicit none @@ -69,10 +79,10 @@ subroutine surface_varnce( upwp_sfc, vpwp_sfc, wpthlp_sfc, wprtp_sfc, & real( kind = core_rknd ), parameter :: & a_const = 1.8_core_rknd, & - z_const = 1.0_core_rknd, & + z_const = one, & ! Defined height of 1 meter [m] ! Vince Larson increased ufmin to stabilize arm_97. 24 Jul 2007 ! ufmin = 0.0001_core_rknd, & - ufmin = 0.01_core_rknd, & + ufmin = 0.01_core_rknd, & ! Minimum allowable value of u* [m/s] ! End Vince Larson's change. ! Vince Larson changed in order to make correlations between [-1,1]. 31 Jan 2008. ! sclr_var_coef = 0.25_core_rknd, & ! This value is made up! - Vince Larson 12 Jul 2005 @@ -84,36 +94,39 @@ subroutine surface_varnce( upwp_sfc, vpwp_sfc, wpthlp_sfc, wprtp_sfc, & ! Input Variables real( kind = core_rknd ), intent(in) :: & - upwp_sfc, & ! Surface u momentum flux [m^2/s^2] - vpwp_sfc, & ! Surface v momentum flux [m^2/s^2] - wpthlp_sfc, & ! Surface thetal flux [K m/s] - wprtp_sfc, & ! Surface moisture flux [kg/kg m/s] - um_sfc, & ! Surface u wind component [m/s] - vm_sfc ! Surface v wind component [m/s] + upwp_sfc, & ! Surface u momentum flux, |_sfc [m^2/s^2] + vpwp_sfc, & ! Surface v momentum flux, |_sfc [m^2/s^2] + wpthlp_sfc, & ! Surface thetal flux, |_sfc [K m/s] + wprtp_sfc, & ! Surface moisture flux, |_sfc [kg/kg m/s] + um_sfc, & ! Surface u wind component, [m/s] + vm_sfc, & ! Surface v wind component, [m/s] + Lscale_up_sfc ! Upward component of Lscale at surface [m] real( kind = core_rknd ), intent(in), dimension(sclr_dim) :: & - wpsclrp_sfc ! Passive scalar flux [units m/s] + wpsclrp_sfc ! Passive scalar flux, |_sfc [units m/s] ! Output Variables real( kind = core_rknd ), intent(out) :: & - wp2_sfc, & ! Vertical velocity variance [m^2/s^2] - up2_sfc, & ! u'^2 [m^2/s^2] - vp2_sfc, & ! v'^2 [m^2/s^2] - thlp2_sfc, & ! thetal variance [K^2] - rtp2_sfc, & ! rt variance [(kg/kg)^2] - rtpthlp_sfc ! thetal rt covariance [kg K/kg] + wp2_sfc, & ! Surface variance of w, |_sfc [m^2/s^2] + up2_sfc, & ! Surface variance of u, |_sfc [m^2/s^2] + vp2_sfc, & ! Surface variance of v, |_sfc [m^2/s^2] + thlp2_sfc, & ! Surface variance of theta-l, |_sfc [K^2] + rtp2_sfc, & ! Surface variance of rt, |_sfc [(kg/kg)^2] + rtpthlp_sfc ! Surface covariance of rt and theta-l [kg K/kg] integer, intent(out) :: & - err_code + err_code ! Error code real( kind = core_rknd ), intent(out), dimension(sclr_dim) :: & - sclrp2_sfc, & ! Passive scalar variance [units^2] - sclrprtp_sfc, & ! Passive scalar r_t covariance [units kg/kg] - sclrpthlp_sfc ! Passive scalar theta_l covariance [units K] + sclrp2_sfc, & ! Surface variance of passive scalar [units^2] + sclrprtp_sfc, & ! Surface covariance of pssv scalar and rt [units kg/kg] + sclrpthlp_sfc ! Surface covariance of pssv scalar and theta-l [units K] ! Local Variables - real( kind = core_rknd ) :: ustar2, wstar - real( kind = core_rknd ) :: uf + real( kind = core_rknd ) :: & + ustar2, & ! Square of surface friction velocity, u* [m^2/s^2] + wstar, & ! Convective velocity, w* [m/s] + uf ! Surface friction vel., u*, in older version [m/s] ! Variables for Andre et al., 1978 parameterization. real( kind = core_rknd ) :: & @@ -122,283 +135,322 @@ subroutine surface_varnce( upwp_sfc, vpwp_sfc, wpthlp_sfc, wprtp_sfc, & usp2_sfc, & ! u_s (vector oriented w/ mean sfc. wind) variance [m^2/s^2] vsp2_sfc ! v_s (vector perpen. to mean sfc. wind) variance [m^2/s^2] - real( kind = core_rknd ) :: ustar - real( kind = core_rknd ) :: Lngth - real( kind = core_rknd ) :: zeta + real( kind = core_rknd ) :: & + ustar, & ! Surface friction velocity, u* [m/s] + Lngth, & ! Monin-Obukhov length [m] + zeta ! Dimensionless height z_const/Lngth, where z_const = 1 m. [-] integer :: i ! Loop index - ! ---- Begin Code ---- err_code = clubb_no_error if ( l_andre_1978 ) then - ! Calculate ^2 and ^2. - um_sfc_sqd = um_sfc**2 - vm_sfc_sqd = vm_sfc**2 - - ! Calculate surface friction velocity, u*. - ustar = MAX( ( upwp_sfc**2 + vpwp_sfc**2 )**(1.0_core_rknd/4.0_core_rknd), ufmin ) - - ! Find Monin-Obukhov Length (Andre et al., 1978, p. 1866). - Lngth = - ( ustar**3 ) / & - ( 0.35_core_rknd * (1.0_core_rknd/T0) * grav * wpthlp_sfc ) ! Known magic number - - ! Find the value of dimensionless height zeta - ! (Andre et al., 1978, p. 1866). - zeta = z_const / Lngth - - ! Andre et al, 1978, Eq. 29. - ! Notes: 1) "reduce_coef" is a reduction coefficient intended to make - ! the values of rtp2, thlp2, and rtpthlp smaller at the - ! surface. - ! 2) With the reduction coefficient having a value of 0.2, the - ! surface correlations of both w & rt and w & thl have a value - ! of about 0.845. These correlations are greater if zeta < 0. - ! The correlations have a value greater than 1 if - ! zeta <= -0.212. - ! 3) The surface correlation of rt & thl is 1. - ! Brian Griffin; February 2, 2008. - if ( zeta < 0.0_core_rknd ) then - thlp2_sfc = reduce_coef & - * ( wpthlp_sfc**2 / ustar**2 ) & - * 4.0_core_rknd * ( 1.0_core_rknd - 8.3_core_rknd*zeta )**& - (-2.0_core_rknd/3.0_core_rknd) ! Known magic number - rtp2_sfc = reduce_coef & - * ( wprtp_sfc**2 / ustar**2 ) & - * 4.0_core_rknd * ( 1.0_core_rknd - 8.3_core_rknd*zeta )**& - (-2.0_core_rknd/3.0_core_rknd) ! Known magic number - rtpthlp_sfc = reduce_coef & - * ( wprtp_sfc*wpthlp_sfc / ustar**2 ) & - * 4.0_core_rknd * ( 1.0_core_rknd - 8.3_core_rknd*zeta )**& - (-2.0_core_rknd/3.0_core_rknd) ! Known magic number - wp2_sfc = ( ustar**2 ) & - * ( 1.75_core_rknd + 2.0_core_rknd*(-zeta)**& - (2.0_core_rknd/3.0_core_rknd) ) ! Known magic number - else - thlp2_sfc = reduce_coef & - * 4.0_core_rknd * ( wpthlp_sfc**2 / ustar**2 ) ! Known magic number - rtp2_sfc = reduce_coef & - * 4.0_core_rknd * ( wprtp_sfc**2 / ustar**2 ) ! Known magic number - rtpthlp_sfc = reduce_coef & - * 4.0_core_rknd * ( wprtp_sfc*wpthlp_sfc / ustar**2 ) ! Known magic number - wp2_sfc = 1.75_core_rknd * ustar**2 ! Known magic number - end if - - ! Calculate wstar following Andre et al., 1978, p. 1866. - wstar = ( (1.0_core_rknd/T0) * grav * wpthlp_sfc * z_const )**(1.0_core_rknd/3.0_core_rknd) - - ! Andre et al., 1978, Eq. 29. - ! Andre et al. (1978) defines horizontal wind surface variances in terms - ! of orientation with the mean surface wind. The vector u_s is the wind - ! vector oriented with the mean surface wind. The vector v_s is the wind - ! vector oriented perpendicular to the mean surface wind. Thus, is - ! equal to the mean surface wind (both in speed and direction), and - ! is 0. Equation 29 gives the formula for the variance of u_s, which is - ! (usp2_sfc in the code), and the formula for the variance of - ! v_s, which is (vsp2_sfc in the code). - if ( wpthlp_sfc > 0.0_core_rknd ) then - usp2_sfc = 4.0_core_rknd * ustar**2 + 0.3_core_rknd * wstar**2 ! Known magic number - vsp2_sfc = 1.75_core_rknd * ustar**2 + 0.3_core_rknd * wstar**2 ! Known magic number - else - usp2_sfc = 4.0_core_rknd * ustar**2 ! Known magic number - vsp2_sfc = 1.75_core_rknd * ustar**2 ! Known magic number - end if - - ! Variance of u, , at the surface can be found from , - ! , and mean winds (at the surface) and , such that: - ! |_sfc = * [ ^2 / ( ^2 + ^2 ) ] - ! + * [ ^2 / ( ^2 + ^2 ) ]; - ! where ^2 + ^2 /= 0. - up2_sfc & - = usp2_sfc * ( um_sfc_sqd / max( um_sfc_sqd + vm_sfc_sqd , eps ) ) & - + vsp2_sfc * ( vm_sfc_sqd / max( um_sfc_sqd + vm_sfc_sqd , eps ) ) - - ! Variance of v, , at the surface can be found from , - ! , and mean winds (at the surface) and , such that: - ! |_sfc = * [ ^2 / ( ^2 + ^2 ) ] - ! + * [ ^2 / ( ^2 + ^2 ) ]; - ! where ^2 + ^2 /= 0. - vp2_sfc & - = vsp2_sfc * ( um_sfc_sqd / max( um_sfc_sqd + vm_sfc_sqd , eps ) ) & - + usp2_sfc * ( vm_sfc_sqd / max( um_sfc_sqd + vm_sfc_sqd , eps ) ) - - ! Passive scalars - if ( sclr_dim > 0 ) then - do i = 1, sclr_dim - ! Notes: 1) "reduce_coef" is a reduction coefficient intended to - ! make the values of sclrprtp, sclrpthlp, and sclrp2 - ! smaller at the surface. - ! 2) With the reduction coefficient having a value of 0.2, - ! the surface correlation of w & sclr has a value of - ! about 0.845. The correlation is greater if zeta < 0. - ! The correlation has a value greater than 1 if - ! zeta <= -0.212. - ! 3) The surface correlations of both rt & sclr and - ! thl & sclr are 1. - ! Brian Griffin; February 2, 2008. - if ( zeta < 0.0_core_rknd ) then - sclrprtp_sfc(i) & - = reduce_coef & - * ( wpsclrp_sfc(i)*wprtp_sfc / ustar**2 ) & - * 4.0_core_rknd * ( 1.0_core_rknd - 8.3_core_rknd*zeta )**& - (-2.0_core_rknd/3.0_core_rknd) ! Known magic number - sclrpthlp_sfc(i) & - = reduce_coef & - * ( wpsclrp_sfc(i)*wpthlp_sfc / ustar**2 ) & - * 4.0_core_rknd * ( 1.0_core_rknd - 8.3_core_rknd*zeta )**& - (-2.0_core_rknd/3.0_core_rknd) ! Known magic number - sclrp2_sfc(i) & - = reduce_coef & - * ( wpsclrp_sfc(i)**2 / ustar**2 ) & - * 4.0_core_rknd * ( 1.0_core_rknd - 8.3_core_rknd*zeta )**& - (-2.0_core_rknd/3.0_core_rknd) ! Known magic number - else - sclrprtp_sfc(i) & - = reduce_coef & - * 4.0_core_rknd * ( wpsclrp_sfc(i)*wprtp_sfc / ustar**2 ) ! Known magic number - sclrpthlp_sfc(i) & - = reduce_coef & - * 4.0_core_rknd * ( wpsclrp_sfc(i)*wpthlp_sfc / ustar**2 ) ! Known magic number - sclrp2_sfc(i) & - = reduce_coef & - * 4.0_core_rknd * ( wpsclrp_sfc(i)**2 / ustar**2 ) ! Known magic number - end if - end do ! 1,...sclr_dim - end if + ! Calculate ^2 and ^2. + um_sfc_sqd = um_sfc**2 + vm_sfc_sqd = vm_sfc**2 - else ! Previous code. + ! Calculate surface friction velocity, u*. + ustar = max( ( upwp_sfc**2 + vpwp_sfc**2 )**(one_fourth), ufmin ) - ! Compute ustar^2 + if ( wpthlp_sfc /= zero ) then - ustar2 = sqrt( upwp_sfc * upwp_sfc + vpwp_sfc * vpwp_sfc ) + ! Find Monin-Obukhov Length (Andre et al., 1978, p. 1866). + Lngth = - ( ustar**3 ) & + / ( 0.35_core_rknd * (one/T0) * grav * wpthlp_sfc ) - ! Compute wstar following Andre et al., 1976 + ! Find the value of dimensionless height zeta + ! (Andre et al., 1978, p. 1866). + zeta = z_const / Lngth - if ( wpthlp_sfc > 0._core_rknd ) then - wstar = ( 1.0_core_rknd/T0 * grav * wpthlp_sfc * z_const ) ** (1._core_rknd/3._core_rknd) - else - wstar = 0._core_rknd - end if + else ! wpthlp_sfc = 0 - ! Surface friction velocity following Andre et al. 1978 + ! The value of Monin-Obukhov length is +inf when ustar < 0 and -inf + ! when ustar > 0. Either way, zeta = 0. + zeta = zero + + endif ! wpthlp_sfc /= 0 + + ! Andre et al, 1978, Eq. 29. + ! Notes: 1) "reduce_coef" is a reduction coefficient intended to make + ! the values of rtp2, thlp2, and rtpthlp smaller at the + ! surface. + ! 2) With the reduction coefficient having a value of 0.2, the + ! surface correlations of both w & rt and w & thl have a value + ! of about 0.845. These correlations are greater if zeta < 0. + ! The correlations have a value greater than 1 if + ! zeta <= -0.212. + ! 3) The surface correlation of rt & thl is 1. + ! Brian Griffin; February 2, 2008. + if ( zeta < zero ) then + + thlp2_sfc = reduce_coef & + * ( wpthlp_sfc**2 / ustar**2 ) & + * four * ( one - 8.3_core_rknd * zeta )**(-two_thirds) + + rtp2_sfc = reduce_coef & + * ( wprtp_sfc**2 / ustar**2 ) & + * four * ( one - 8.3_core_rknd * zeta )**(-two_thirds) + + rtpthlp_sfc = reduce_coef & + * ( wprtp_sfc * wpthlp_sfc / ustar**2 ) & + * four * ( one - 8.3_core_rknd * zeta )**(-two_thirds) + + wp2_sfc = ( ustar**2 ) & + * ( 1.75_core_rknd + two * (-zeta)**(two_thirds) ) + + else + + thlp2_sfc = reduce_coef & + * four * ( wpthlp_sfc**2 / ustar**2 ) + + rtp2_sfc = reduce_coef & + * four * ( wprtp_sfc**2 / ustar**2 ) + + rtpthlp_sfc = reduce_coef & + * four * ( wprtp_sfc * wpthlp_sfc / ustar**2 ) + + wp2_sfc = 1.75_core_rknd * ustar**2 + + endif - uf = sqrt( ustar2 + 0.3_core_rknd * wstar * wstar ) ! Known magic number - uf = max( ufmin, uf ) + ! Calculate wstar following Andre et al., 1978, p. 1866. + ! w* = ( ( 1 / T0 ) * g * |_sfc * z_i )^(1/3); + ! where z_i is the height of the mixed layer. The value of CLUBB's + ! upward component of mixing length, Lscale_up, at the surface will be + ! used as z_i. + wstar = ( (one/T0) * grav * wpthlp_sfc * Lscale_up_sfc )**(one_third) - ! Compute estimate for surface second order moments + ! Andre et al., 1978, Eq. 29. + ! Andre et al. (1978) defines horizontal wind surface variances in terms + ! of orientation with the mean surface wind. The vector u_s is the wind + ! vector oriented with the mean surface wind. The vector v_s is the wind + ! vector oriented perpendicular to the mean surface wind. Thus, is + ! equal to the mean surface wind (both in speed and direction), and + ! is 0. Equation 29 gives the formula for the variance of u_s, which is + ! (usp2_sfc in the code), and the formula for the variance of + ! v_s, which is (vsp2_sfc in the code). + if ( wpthlp_sfc > zero ) then - wp2_sfc = a_const * uf**2 - up2_sfc = 2.0_core_rknd * a_const * uf**2 ! From Andre, et al. 1978 - vp2_sfc = 2.0_core_rknd * a_const * uf**2 ! " " - ! Vince Larson changed to make correlations between [-1,1] 31 Jan 2008 -! thlp2_sfc = 0.1 * a * ( wpthlp_sfc / uf )**2 -! rtp2_sfc = 0.4 * a * ( wprtp_sfc / uf )**2 -! rtpthlp_sfc = a * ( wpthlp_sfc / uf ) * ( wprtp_sfc / uf ) - ! Notes: 1) With "a" having a value of 1.8, the surface correlations of - ! both w & rt and w & thl have a value of about 0.878. - ! 2) The surface correlation of rt & thl is 0.5. - ! Brian Griffin; February 2, 2008. + usp2_sfc = four * ustar**2 + 0.3_core_rknd * wstar**2 - thlp2_sfc = 0.4_core_rknd * a_const * ( wpthlp_sfc / uf )**2 ! Known magic number + vsp2_sfc = 1.75_core_rknd * ustar**2 + 0.3_core_rknd * wstar**2 - rtp2_sfc = 0.4_core_rknd * a_const * ( wprtp_sfc / uf )**2 ! Known magic number + else - rtpthlp_sfc = 0.2_core_rknd * a_const * ( wpthlp_sfc / uf ) & - * ( wprtp_sfc / uf )! Known magic number + usp2_sfc = four * ustar**2 + + vsp2_sfc = 1.75_core_rknd * ustar**2 + + endif + + ! Variance of u, , at the surface can be found from , + ! , and mean winds (at the surface) and , such that: + ! |_sfc = * [ ^2 / ( ^2 + ^2 ) ] + ! + * [ ^2 / ( ^2 + ^2 ) ]; + ! where ^2 + ^2 /= 0. + up2_sfc & + = usp2_sfc * ( um_sfc_sqd / max( um_sfc_sqd + vm_sfc_sqd , eps ) ) & + + vsp2_sfc * ( vm_sfc_sqd / max( um_sfc_sqd + vm_sfc_sqd , eps ) ) + + ! Variance of v, , at the surface can be found from , + ! , and mean winds (at the surface) and , such that: + ! |_sfc = * [ ^2 / ( ^2 + ^2 ) ] + ! + * [ ^2 / ( ^2 + ^2 ) ]; + ! where ^2 + ^2 /= 0. + vp2_sfc & + = vsp2_sfc * ( um_sfc_sqd / max( um_sfc_sqd + vm_sfc_sqd , eps ) ) & + + usp2_sfc * ( vm_sfc_sqd / max( um_sfc_sqd + vm_sfc_sqd , eps ) ) + + ! Passive scalars + if ( sclr_dim > 0 ) then + do i = 1, sclr_dim + ! Notes: 1) "reduce_coef" is a reduction coefficient intended to + ! make the values of sclrprtp, sclrpthlp, and sclrp2 + ! smaller at the surface. + ! 2) With the reduction coefficient having a value of 0.2, + ! the surface correlation of w & sclr has a value of + ! about 0.845. The correlation is greater if zeta < 0. + ! The correlation has a value greater than 1 if + ! zeta <= -0.212. + ! 3) The surface correlations of both rt & sclr and + ! thl & sclr are 1. + ! Brian Griffin; February 2, 2008. + if ( zeta < zero ) then + + sclrprtp_sfc(i) & + = reduce_coef & + * ( wpsclrp_sfc(i) * wprtp_sfc / ustar**2 ) & + * four * ( one - 8.3_core_rknd * zeta )**(-two_thirds) + + sclrpthlp_sfc(i) & + = reduce_coef & + * ( wpsclrp_sfc(i) * wpthlp_sfc / ustar**2 ) & + * four * ( one - 8.3_core_rknd * zeta )**(-two_thirds) + + sclrp2_sfc(i) & + = reduce_coef & + * ( wpsclrp_sfc(i)**2 / ustar**2 ) & + * four * ( one - 8.3_core_rknd * zeta )**(-two_thirds) + + else + + sclrprtp_sfc(i) & + = reduce_coef & + * four * ( wpsclrp_sfc(i) * wprtp_sfc / ustar**2 ) + + sclrpthlp_sfc(i) & + = reduce_coef & + * four * ( wpsclrp_sfc(i) * wpthlp_sfc / ustar**2 ) + + sclrp2_sfc(i) & + = reduce_coef & + * four * ( wpsclrp_sfc(i)**2 / ustar**2 ) + + endif + + enddo ! i = 1, sclr_dim + + endif - ! End Vince Larson's change. - ! Passive scalars - if ( sclr_dim > 0 ) then - do i=1, sclr_dim - ! Vince Larson changed coeffs to make correlations between [-1,1]. 31 Jan 2008 + else ! Previous code. + + ! Compute ustar^2 + ustar2 = sqrt( upwp_sfc * upwp_sfc + vpwp_sfc * vpwp_sfc ) + + ! Compute wstar following Andre et al., 1976 + if ( wpthlp_sfc > zero ) then + wstar = ( one/T0 * grav * wpthlp_sfc * z_const )**(one_third) + else + wstar = zero + endif + + ! Surface friction velocity following Andre et al. 1978 + uf = sqrt( ustar2 + 0.3_core_rknd * wstar * wstar ) + uf = max( ufmin, uf ) + + ! Compute estimate for surface second order moments + wp2_sfc = a_const * uf**2 + up2_sfc = 2.0_core_rknd * a_const * uf**2 ! From Andre, et al. 1978 + vp2_sfc = 2.0_core_rknd * a_const * uf**2 ! " " + + ! Vince Larson changed to make correlations between [-1,1] 31 Jan 2008 +! thlp2_sfc = 0.1 * a * ( wpthlp_sfc / uf )**2 +! rtp2_sfc = 0.4 * a * ( wprtp_sfc / uf )**2 +! rtpthlp_sfc = a * ( wpthlp_sfc / uf ) * ( wprtp_sfc / uf ) + ! Notes: 1) With "a" having a value of 1.8, the surface correlations of + ! both w & rt and w & thl have a value of about 0.878. + ! 2) The surface correlation of rt & thl is 0.5. + ! Brian Griffin; February 2, 2008. + + thlp2_sfc = 0.4_core_rknd * a_const * ( wpthlp_sfc / uf )**2 + + rtp2_sfc = 0.4_core_rknd * a_const * ( wprtp_sfc / uf )**2 + + rtpthlp_sfc = 0.2_core_rknd * a_const & + * ( wpthlp_sfc / uf ) * ( wprtp_sfc / uf ) + + ! End Vince Larson's change. + + ! Passive scalars + if ( sclr_dim > 0 ) then + do i = 1, sclr_dim + ! Vince Larson changed coeffs to make correlations between [-1,1]. + ! 31 Jan 2008 ! sclrprtp_sfc(i) & ! = a * (wprtp_sfc / uf) * (wpsclrp_sfc(i) / uf) ! sclrpthlp_sfc(i) & ! = a * (wpthlp_sfc / uf) * (wpsclrp_sfc(i) / uf) ! sclrp2_sfc(i) & ! = sclr_var_coef * a * ( wpsclrp_sfc(i) / uf )**2 - ! Notes: 1) With "a" having a value of 1.8 and "sclr_var_coef" - ! having a value of 0.4, the surface correlation of - ! w & sclr has a value of about 0.878. - ! 2) With "sclr_var_coef" having a value of 0.4, the - ! surface correlations of both rt & sclr and - ! thl & sclr are 0.5. - ! Brian Griffin; February 2, 2008. - - ! We use the following if..then's to make sclr_rt and sclr_thl close to - ! the actual thlp2/rtp2 at the surface. -dschanen 25 Sep 08 - if ( i == iisclr_rt ) then - ! If we are trying to emulate rt with the scalar, then we - ! use the variance coefficient from above - sclrprtp_sfc(i) = 0.4_core_rknd * a_const * (wprtp_sfc / uf) * & - (wpsclrp_sfc(i) / uf)!Known magic number - else - sclrprtp_sfc(i) = 0.2_core_rknd * a_const * (wprtp_sfc / uf) * & - (wpsclrp_sfc(i) / uf)!Known magic number - end if - - if ( i == iisclr_thl ) then - ! As above, but for thetal - sclrpthlp_sfc(i) = 0.4_core_rknd * a_const * (wpthlp_sfc / uf) & - * (wpsclrp_sfc(i) / uf) ! Known magic number - else - sclrpthlp_sfc(i) = 0.2_core_rknd * a_const * (wpthlp_sfc / uf) & - * (wpsclrp_sfc(i) / uf) ! Known magic number - end if - - sclrp2_sfc(i) = sclr_var_coef * a_const * ( wpsclrp_sfc(i) / uf )**2 - - ! End Vince Larson's change. - - end do ! 1,...sclr_dim - end if ! sclr_dim > 0 - - end if + ! Notes: 1) With "a" having a value of 1.8 and "sclr_var_coef" + ! having a value of 0.4, the surface correlation of + ! w & sclr has a value of about 0.878. + ! 2) With "sclr_var_coef" having a value of 0.4, the + ! surface correlations of both rt & sclr and + ! thl & sclr are 0.5. + ! Brian Griffin; February 2, 2008. + + ! We use the following if..then's to make sclr_rt and sclr_thl + ! close to the actual thlp2/rtp2 at the surface. + ! -dschanen 25 Sep 08 + if ( i == iisclr_rt ) then + ! If we are trying to emulate rt with the scalar, then we + ! use the variance coefficient from above + sclrprtp_sfc(i) = 0.4_core_rknd * a_const & + * ( wprtp_sfc / uf ) * ( wpsclrp_sfc(i) / uf ) + else + sclrprtp_sfc(i) = 0.2_core_rknd * a_const & + * ( wprtp_sfc / uf ) * ( wpsclrp_sfc(i) / uf ) + endif + + if ( i == iisclr_thl ) then + ! As above, but for thetal + sclrpthlp_sfc(i) = 0.4_core_rknd * a_const & + * ( wpthlp_sfc / uf ) & + * ( wpsclrp_sfc(i) / uf ) + else + sclrpthlp_sfc(i) = 0.2_core_rknd * a_const & + * ( wpthlp_sfc / uf ) & + * ( wpsclrp_sfc(i) / uf ) + endif + + sclrp2_sfc(i) = sclr_var_coef * a_const & + * ( wpsclrp_sfc(i) / uf )**2 + + ! End Vince Larson's change. + + enddo ! 1,...sclr_dim + endif ! sclr_dim > 0 + + + endif ! l_andre_1978 + if ( clubb_at_least_debug_level( 2 ) ) then - call surface_varnce_check( wp2_sfc, up2_sfc, vp2_sfc, & - thlp2_sfc, rtp2_sfc, rtpthlp_sfc, & - err_code, & - sclrp2_sfc, sclrprtp_sfc, sclrpthlp_sfc ) + call surface_varnce_check( wp2_sfc, up2_sfc, vp2_sfc, & + thlp2_sfc, rtp2_sfc, rtpthlp_sfc, & + sclrp2_sfc, sclrprtp_sfc, sclrpthlp_sfc, & + err_code ) ! Error reporting ! Joshua Fasching February 2008 - if ( err_code == clubb_var_equals_NaN ) then + if ( err_code == clubb_var_equals_NaN ) then + + write(fstderr,*) "Error in surface_varnce" + write(fstderr,*) "Intent(in)" - write(fstderr,*) "Error in surface_varnce" - write(fstderr,*) "Intent(in)" + write(fstderr,*) "upwp_sfc = ", upwp_sfc + write(fstderr,*) "vpwp_sfc = ", vpwp_sfc + write(fstderr,*) "wpthlp_sfc = ", wpthlp_sfc + write(fstderr,*) "wprtp_sfc = ", wprtp_sfc - write(fstderr,*) "upwp_sfc = ", upwp_sfc - write(fstderr,*) "vpwp_sfc = ", vpwp_sfc - write(fstderr,*) "wpthlp_sfc = ", wpthlp_sfc - write(fstderr,*) "wprtp_sfc = ", wprtp_sfc + if ( sclr_dim > 0 ) then + write(fstderr,*) "wpsclrp_sfc = ", wpsclrp_sfc + endif - if ( sclr_dim > 0 ) then - write(fstderr,*) "wpsclrp_sfc = ", wpsclrp_sfc - end if + write(fstderr,*) "Intent(out)" - write(fstderr,*) "Intent(out)" + write(fstderr,*) "wp2_sfc = ", wp2_sfc + write(fstderr,*) "up2_sfc = ", up2_sfc + write(fstderr,*) "vp2_sfc = ", vp2_sfc + write(fstderr,*) "thlp2_sfc = ", thlp2_sfc + write(fstderr,*) "rtp2_sfc = ", rtp2_sfc + write(fstderr,*) "rtpthlp_sfc = ", rtpthlp_sfc - write(fstderr,*) "wp2_sfc = ", wp2_sfc - write(fstderr,*) "up2_sfc = ", up2_sfc - write(fstderr,*) "vp2_sfc = ", vp2_sfc - write(fstderr,*) "thlp2_sfc = ", thlp2_sfc - write(fstderr,*) "rtp2_sfc = ", rtp2_sfc - write(fstderr,*) "rtpthlp_sfc = ", rtpthlp_sfc + if ( sclr_dim > 0 ) then + write(fstderr,*) "sclrp2_sfc = ", sclrp2_sfc + write(fstderr,*) "sclrprtp_sfc = ", sclrprtp_sfc + write(fstderr,*) "sclrpthlp_sfc = ", sclrpthlp_sfc + endif - if ( sclr_dim > 0 ) then - write(fstderr,*) "sclrp2_sfc = ", sclrp2_sfc - write(fstderr,*) "sclrprtp_sfc = ", sclrprtp_sfc - write(fstderr,*) "sclrpthlp_sfc = ", sclrpthlp_sfc - end if + endif ! err_code == clubb_var_equals_NaN - end if ! err_code == clubb_var_equals_NaN + endif ! clubb_at_least_debug_level ( 2 ) - end if ! clubb_at_least_debug_level ( 2 ) return diff --git a/models/atm/cam/src/physics/clubb/variables_diagnostic_module.F90 b/models/atm/cam/src/physics/clubb/variables_diagnostic_module.F90 index 5e1c48456390..714c30225c89 100644 --- a/models/atm/cam/src/physics/clubb/variables_diagnostic_module.F90 +++ b/models/atm/cam/src/physics/clubb/variables_diagnostic_module.F90 @@ -1,4 +1,6 @@ -! $Id: variables_diagnostic_module.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +!------------------------------------------------------------------------- +! $Id: variables_diagnostic_module.F90 7376 2014-11-09 02:55:23Z bmg2@uwm.edu $ +!=============================================================================== module variables_diagnostic_module ! Description: @@ -50,9 +52,10 @@ module variables_diagnostic_module !$omp threadprivate(rsat) type(pdf_parameter), allocatable, dimension(:), target, public :: & - pdf_params_zm ! pdf_params on momentum levels [units vary] + pdf_params_zm, & ! pdf_params on momentum levels [units vary] + pdf_params_zm_frz !used when l_use_ice_latent = .true. -!$omp threadprivate(pdf_params_zm) +!$omp threadprivate(pdf_params_zm, pdf_params_zm_frz) real( kind = core_rknd ), target, allocatable, dimension(:), public :: & Frad, & ! Radiative flux (momentum point) [W/m^2] @@ -106,6 +109,11 @@ module variables_diagnostic_module !$omp threadprivate(Kh_zt, Kh_zm) + real( kind = core_rknd ), allocatable, dimension(:,:), public :: & + K_hm ! Eddy diffusivity coefficient for hydrometeors on momentum levels [m^2 s^-1] + +!$omp threadprivate(K_hm) + ! Mixing lengths real( kind = core_rknd ), target, allocatable, dimension(:), public :: & Lscale, Lscale_up, Lscale_down ! [m] @@ -119,13 +127,22 @@ module variables_diagnostic_module !$omp threadprivate(em, tau_zm, tau_zt) -! hydrometeors variable array - real( kind = core_rknd ), allocatable, dimension(:,:), public :: hydromet -!$omp threadprivate(hydromet) +! hydrometeors variable arrays + real( kind = core_rknd ), allocatable, dimension(:,:), public :: & + hydromet, & ! Mean hydrometeor (thermodynamic levels) [units] + hydrometp2, & ! Variance of a hydrometeor (overall) (m-levs.) [units^2] + wphydrometp ! Covariance of w and hydrometeor (momentum levels) [(m/s)un] +!$omp threadprivate( hydromet, hydrometp2, wphydrometp ) + +! Cloud droplet concentration arrays + real( kind = core_rknd ), allocatable, dimension(:), public :: & + Ncm, & ! Mean cloud droplet concentration, (thermo. levels) [num/kg] + wpNcp ! Covariance of w and N_c, (momentum levels) [(m/s)(#/kg)] +!$omp threadprivate(Ncm,wpNcp) real( kind = core_rknd ), target, allocatable, dimension(:), public :: & - Ncnm ! Cloud nuclei number concentration [num/m^3] -!$omp threadprivate(Ncnm) + Nccnm ! Cloud condensation nuclei concentration (COAMPS/MG) [num/kg] +!$omp threadprivate(Nccnm) ! Surface data @@ -183,14 +200,6 @@ module variables_diagnostic_module !$omp threadprivate(lh_AKm, AKm, AKstd, AKstd_cld, lh_rcm_avg, AKm_rcm, & !$omp AKm_rcc) - ! Diagnostics from the pdf_closure subroutine - real( kind = core_rknd ), target, allocatable, dimension(:), public :: & - sptp_mellor_1, sptp_mellor_2, & ! Covariance of s and t[(kg/kg)^2] - tp2_mellor_1, tp2_mellor_2, & ! Variance of t [(kg/kg)^2] - corr_st_mellor1, corr_st_mellor2 ! Correlation between s and t [-] -!$omp threadprivate(sptp_mellor_1, sptp_mellor_2, tp2_mellor_1, tp2_mellor_2, & -!$omp corr_st_mellor1, corr_st_mellor2 ) - real( kind = core_rknd ), target, allocatable, dimension(:), public :: & Skw_velocity, & ! Skewness velocity [m/s] a3_coef, & ! The a3 coefficient from CLUBB eqns [-] @@ -207,27 +216,28 @@ module variables_diagnostic_module contains !----------------------------------------------------------------------- - subroutine setup_diagnostic_variables( nzmax ) + subroutine setup_diagnostic_variables( nz ) ! Description: ! Allocates and initializes prognostic scalar and array variables ! for the CLUBB model code !----------------------------------------------------------------------- use constants_clubb, only: & - em_min ! Variables + em_min, & ! Constant(s) + zero use parameters_model, only: & - hydromet_dim, & ! Variables - sclr_dim, & - edsclr_dim + hydromet_dim, & ! Variables + sclr_dim, & + edsclr_dim use clubb_precision, only: & - core_rknd ! Variable(s) + core_rknd ! Variable(s) implicit none ! Input Variables - integer, intent(in) :: nzmax ! Nunber of grid levels [-] + integer, intent(in) :: nz ! Nunber of grid levels [-] ! Local Variables integer :: i @@ -236,124 +246,122 @@ subroutine setup_diagnostic_variables( nzmax ) ! Diagnostic variables - allocate( sigma_sqd_w_zt(1:nzmax) ) ! PDF width parameter interp. to t-levs. - allocate( Skw_zm(1:nzmax) ) ! Skewness of w on momentum levels - allocate( Skw_zt(1:nzmax) ) ! Skewness of w on thermodynamic levels - allocate( ug(1:nzmax) ) ! u geostrophic wind - allocate( vg(1:nzmax) ) ! v geostrophic wind - allocate( um_ref(1:nzmax) ) ! Reference u wind for nudging; Michael Falk, 17 Oct 2007 - allocate( vm_ref(1:nzmax) ) ! Reference v wind for nudging; Michael Falk, 17 Oct 2007 - allocate( thlm_ref(1:nzmax) ) ! Reference liquid water potential for nudging - allocate( rtm_ref(1:nzmax) ) ! Reference total water mixing ratio for nudging - allocate( thvm(1:nzmax) ) ! Virtual potential temperature + allocate( sigma_sqd_w_zt(1:nz) ) ! PDF width parameter interp. to t-levs. + allocate( Skw_zm(1:nz) ) ! Skewness of w on momentum levels + allocate( Skw_zt(1:nz) ) ! Skewness of w on thermodynamic levels + allocate( ug(1:nz) ) ! u geostrophic wind + allocate( vg(1:nz) ) ! v geostrophic wind + allocate( um_ref(1:nz) ) ! Reference u wind for nudging; Michael Falk, 17 Oct 2007 + allocate( vm_ref(1:nz) ) ! Reference v wind for nudging; Michael Falk, 17 Oct 2007 + allocate( thlm_ref(1:nz) ) ! Reference liquid water potential for nudging + allocate( rtm_ref(1:nz) ) ! Reference total water mixing ratio for nudging + allocate( thvm(1:nz) ) ! Virtual potential temperature - allocate( rsat(1:nzmax) ) ! Saturation mixing ratio ! Brian + allocate( rsat(1:nz) ) ! Saturation mixing ratio ! Brian - allocate( Frad(1:nzmax) ) ! radiative flux (momentum point) - allocate( Frad_SW_up(1:nzmax) ) - allocate( Frad_LW_up(1:nzmax) ) - allocate( Frad_SW_down(1:nzmax) ) - allocate( Frad_LW_down(1:nzmax) ) + allocate( Frad(1:nz) ) ! radiative flux (momentum point) + allocate( Frad_SW_up(1:nz) ) + allocate( Frad_LW_up(1:nz) ) + allocate( Frad_SW_down(1:nz) ) + allocate( Frad_LW_down(1:nz) ) - allocate( radht(1:nzmax) ) ! SW + LW heating rate + allocate( radht(1:nz) ) ! SW + LW heating rate ! pdf_params on momentum levels - allocate( pdf_params_zm(1:nzmax) ) + allocate( pdf_params_zm(1:nz) ) + allocate( pdf_params_zm_frz(1:nz) ) ! Second order moments - allocate( thlprcp(1:nzmax) ) ! thl'rc' - allocate( rtprcp(1:nzmax) ) ! rt'rc' - allocate( rcp2(1:nzmax) ) ! rc'^2 + allocate( thlprcp(1:nz) ) ! thl'rc' + allocate( rtprcp(1:nz) ) ! rt'rc' + allocate( rcp2(1:nz) ) ! rc'^2 ! Third order moments - allocate( wpthlp2(1:nzmax) ) ! w'thl'^2 - allocate( wp2thlp(1:nzmax) ) ! w'^2thl' - allocate( wprtp2(1:nzmax) ) ! w'rt'^2 - allocate( wp2rtp(1:nzmax) ) ! w'^2rt' - allocate( wprtpthlp(1:nzmax) ) ! w'rt'thl' - allocate( wp2rcp(1:nzmax) ) ! w'^2rc' + allocate( wpthlp2(1:nz) ) ! w'thl'^2 + allocate( wp2thlp(1:nz) ) ! w'^2thl' + allocate( wprtp2(1:nz) ) ! w'rt'^2 + allocate( wp2rtp(1:nz) ) ! w'^2rt' + allocate( wprtpthlp(1:nz) ) ! w'rt'thl' + allocate( wp2rcp(1:nz) ) ! w'^2rc' - allocate( wp3_zm(1:nzmax) ) ! w'^3 + allocate( wp3_zm(1:nz) ) ! w'^3 ! Fourth order moments - allocate( wp4(1:nzmax) ) + allocate( wp4(1:nz) ) ! Buoyancy related moments - allocate( rtpthvp(1:nzmax) ) ! rt'thv' - allocate( thlpthvp(1:nzmax) ) ! thl'thv' - allocate( wpthvp(1:nzmax) ) ! w'thv' - allocate( wp2thvp(1:nzmax) ) ! w'^2thv' + allocate( rtpthvp(1:nz) ) ! rt'thv' + allocate( thlpthvp(1:nz) ) ! thl'thv' + allocate( wpthvp(1:nz) ) ! w'thv' + allocate( wp2thvp(1:nz) ) ! w'^2thv' - allocate( Kh_zt(1:nzmax) ) ! Eddy diffusivity coefficient: thermo. levels - allocate( Kh_zm(1:nzmax) ) ! Eddy diffusivity coefficient: momentum levels + allocate( Kh_zt(1:nz) ) ! Eddy diffusivity coefficient: thermo. levels + allocate( Kh_zm(1:nz) ) ! Eddy diffusivity coefficient: momentum levels + allocate( K_hm(1:nz,1:hydromet_dim) ) ! Eddy diff. coef. for hydromets.: mom. levs. - allocate( em(1:nzmax) ) - allocate( Lscale(1:nzmax) ) - allocate( Lscale_up(1:nzmax) ) - allocate( Lscale_down(1:nzmax) ) + allocate( em(1:nz) ) + allocate( Lscale(1:nz) ) + allocate( Lscale_up(1:nz) ) + allocate( Lscale_down(1:nz) ) - allocate( tau_zm(1:nzmax) ) ! Eddy dissipation time scale: momentum levels - allocate( tau_zt(1:nzmax) ) ! Eddy dissipation time scale: thermo. levels + allocate( tau_zm(1:nz) ) ! Eddy dissipation time scale: momentum levels + allocate( tau_zt(1:nz) ) ! Eddy dissipation time scale: thermo. levels ! Interpolated Variables - allocate( wp2_zt(1:nzmax) ) ! w'^2 on thermo. grid - allocate( thlp2_zt(1:nzmax) ) ! thl'^2 on thermo. grid - allocate( wpthlp_zt(1:nzmax) ) ! w'thl' on thermo. grid - allocate( wprtp_zt(1:nzmax) ) ! w'rt' on thermo. grid - allocate( rtp2_zt(1:nzmax) ) ! rt'^2 on thermo. grid - allocate( rtpthlp_zt(1:nzmax) ) ! rt'thl' on thermo. grid - allocate( up2_zt(1:nzmax) ) ! u'^2 on thermo. grid - allocate( vp2_zt(1:nzmax) ) ! v'^2 on thermo. grid - allocate( upwp_zt(1:nzmax) ) ! u'w' on thermo. grid - allocate( vpwp_zt(1:nzmax) ) ! v'w' on thermo. grid + allocate( wp2_zt(1:nz) ) ! w'^2 on thermo. grid + allocate( thlp2_zt(1:nz) ) ! thl'^2 on thermo. grid + allocate( wpthlp_zt(1:nz) ) ! w'thl' on thermo. grid + allocate( wprtp_zt(1:nz) ) ! w'rt' on thermo. grid + allocate( rtp2_zt(1:nz) ) ! rt'^2 on thermo. grid + allocate( rtpthlp_zt(1:nz) ) ! rt'thl' on thermo. grid + allocate( up2_zt(1:nz) ) ! u'^2 on thermo. grid + allocate( vp2_zt(1:nz) ) ! v'^2 on thermo. grid + allocate( upwp_zt(1:nz) ) ! u'w' on thermo. grid + allocate( vpwp_zt(1:nz) ) ! v'w' on thermo. grid ! Microphysics Variables - allocate( Ncnm(1:nzmax) ) - allocate( hydromet(1:nzmax,1:hydromet_dim) ) ! All hydrometeor fields + allocate( Nccnm(1:nz) ) + allocate( hydromet(1:nz,1:hydromet_dim) ) ! All hydrometeor mean fields + allocate( hydrometp2(1:nz,1:hydromet_dim) ) ! All < h_m'^2 > fields + allocate( wphydrometp(1:nz,1:hydromet_dim) ) ! All < w'h_m' > fields + allocate( Ncm(1:nz) ) ! Mean cloud droplet concentration, < N_c > + allocate( wpNcp(1:nz) ) ! < w'N_c' > ! Variables for Latin hypercube microphysics. Vince Larson 22 May 2005 - allocate( lh_AKm(1:nzmax) ) ! Kessler ac estimate - allocate( AKm(1:nzmax) ) ! Exact Kessler ac - allocate( AKstd(1:nzmax) ) ! St dev of exact Kessler ac - allocate( AKstd_cld(1:nzmax) ) ! St dev of exact w/in cloud Kessler ac - allocate( lh_rcm_avg(1:nzmax) ) ! Monte Carlo rcm estimate - allocate( AKm_rcm(1:nzmax) ) ! Kessler ac based on rcm - allocate( AKm_rcc(1:nzmax) ) ! Kessler ac based on rcm/cloud_frac + allocate( lh_AKm(1:nz) ) ! Kessler ac estimate + allocate( AKm(1:nz) ) ! Exact Kessler ac + allocate( AKstd(1:nz) ) ! St dev of exact Kessler ac + allocate( AKstd_cld(1:nz) ) ! St dev of exact w/in cloud Kessler ac + allocate( lh_rcm_avg(1:nz) ) ! Monte Carlo rcm estimate + allocate( AKm_rcm(1:nz) ) ! Kessler ac based on rcm + allocate( AKm_rcc(1:nz) ) ! Kessler ac based on rcm/cloud_frac ! End of variables for Latin hypercube. ! High-order passive scalars - allocate( sclrpthvp(1:nzmax, 1:sclr_dim) ) - allocate( sclrprcp(1:nzmax, 1:sclr_dim) ) + allocate( sclrpthvp(1:nz, 1:sclr_dim) ) + allocate( sclrprcp(1:nz, 1:sclr_dim) ) - allocate( wp2sclrp(1:nzmax, 1:sclr_dim) ) - allocate( wpsclrp2(1:nzmax, 1:sclr_dim) ) - allocate( wpsclrprtp(1:nzmax, 1:sclr_dim) ) - allocate( wpsclrpthlp(1:nzmax, 1:sclr_dim) ) + allocate( wp2sclrp(1:nz, 1:sclr_dim) ) + allocate( wpsclrp2(1:nz, 1:sclr_dim) ) + allocate( wpsclrprtp(1:nz, 1:sclr_dim) ) + allocate( wpsclrpthlp(1:nz, 1:sclr_dim) ) ! Eddy Diff. Scalars - allocate( wpedsclrp(1:nzmax, 1:edsclr_dim) ) - - ! Diagnostics for s and t Mellor - allocate( sptp_mellor_1(1:nzmax) ) - allocate( sptp_mellor_2(1:nzmax) ) - allocate( tp2_mellor_1(1:nzmax) ) - allocate( tp2_mellor_2(1:nzmax) ) - allocate( corr_st_mellor1(1:nzmax) ) - allocate( corr_st_mellor2(1:nzmax) ) + allocate( wpedsclrp(1:nz, 1:edsclr_dim) ) - allocate( Skw_velocity(1:nzmax) ) + allocate( Skw_velocity(1:nz) ) - allocate( a3_coef(1:nzmax) ) - allocate( a3_coef_zt(1:nzmax) ) + allocate( a3_coef(1:nz) ) + allocate( a3_coef_zt(1:nz) ) - allocate( wp3_on_wp2(1:nzmax) ) - allocate( wp3_on_wp2_zt(1:nzmax) ) + allocate( wp3_on_wp2(1:nz) ) + allocate( wp3_on_wp2_zt(1:nz) ) ! --- Initializaton --- @@ -381,37 +389,79 @@ subroutine setup_diagnostic_variables( nzmax ) ! pdf_params on momentum levels - pdf_params_zm%w1 = 0.0_core_rknd - pdf_params_zm%w2 = 0.0_core_rknd - pdf_params_zm%varnce_w1 = 0.0_core_rknd - pdf_params_zm%varnce_w2 = 0.0_core_rknd - pdf_params_zm%rt1 = 0.0_core_rknd - pdf_params_zm%rt2 = 0.0_core_rknd - pdf_params_zm%varnce_rt1 = 0.0_core_rknd - pdf_params_zm%varnce_rt2 = 0.0_core_rknd - pdf_params_zm%thl1 = 0.0_core_rknd - pdf_params_zm%thl2 = 0.0_core_rknd - pdf_params_zm%varnce_thl1 = 0.0_core_rknd - pdf_params_zm%varnce_thl2 = 0.0_core_rknd - pdf_params_zm%mixt_frac = 0.0_core_rknd - pdf_params_zm%rc1 = 0.0_core_rknd - pdf_params_zm%rc2 = 0.0_core_rknd - pdf_params_zm%rsl1 = 0.0_core_rknd - pdf_params_zm%rsl2 = 0.0_core_rknd - pdf_params_zm%cloud_frac1 = 0.0_core_rknd - pdf_params_zm%cloud_frac2 = 0.0_core_rknd - pdf_params_zm%s1 = 0.0_core_rknd - pdf_params_zm%s2 = 0.0_core_rknd - pdf_params_zm%stdev_s1 = 0.0_core_rknd - pdf_params_zm%stdev_s2 = 0.0_core_rknd - pdf_params_zm%rrtthl = 0.0_core_rknd - pdf_params_zm%alpha_thl = 0.0_core_rknd - pdf_params_zm%alpha_rt = 0.0_core_rknd - pdf_params_zm%crt1 = 0.0_core_rknd - pdf_params_zm%crt2 = 0.0_core_rknd - pdf_params_zm%cthl1 = 0.0_core_rknd - pdf_params_zm%cthl2 = 0.0_core_rknd - + pdf_params_zm(:)%w_1 = zero + pdf_params_zm(:)%w_2 = zero + pdf_params_zm(:)%varnce_w_1 = zero + pdf_params_zm(:)%varnce_w_2 = zero + pdf_params_zm(:)%rt_1 = zero + pdf_params_zm(:)%rt_2 = zero + pdf_params_zm(:)%varnce_rt_1 = zero + pdf_params_zm(:)%varnce_rt_2 = zero + pdf_params_zm(:)%thl_1 = zero + pdf_params_zm(:)%thl_2 = zero + pdf_params_zm(:)%varnce_thl_1 = zero + pdf_params_zm(:)%varnce_thl_2 = zero + pdf_params_zm(:)%rrtthl = zero + pdf_params_zm(:)%alpha_thl = zero + pdf_params_zm(:)%alpha_rt = zero + pdf_params_zm(:)%crt_1 = zero + pdf_params_zm(:)%crt_2 = zero + pdf_params_zm(:)%cthl_1 = zero + pdf_params_zm(:)%cthl_2 = zero + pdf_params_zm(:)%chi_1 = zero + pdf_params_zm(:)%chi_2 = zero + pdf_params_zm(:)%stdev_chi_1 = zero + pdf_params_zm(:)%stdev_chi_2 = zero + pdf_params_zm(:)%stdev_eta_1 = zero + pdf_params_zm(:)%stdev_eta_2 = zero + pdf_params_zm(:)%covar_chi_eta_1 = zero + pdf_params_zm(:)%covar_chi_eta_2 = zero + pdf_params_zm(:)%corr_chi_eta_1 = zero + pdf_params_zm(:)%corr_chi_eta_2 = zero + pdf_params_zm(:)%rsatl_1 = zero + pdf_params_zm(:)%rsatl_2 = zero + pdf_params_zm(:)%rc_1 = zero + pdf_params_zm(:)%rc_2 = zero + pdf_params_zm(:)%cloud_frac_1 = zero + pdf_params_zm(:)%cloud_frac_2 = zero + pdf_params_zm(:)%mixt_frac = zero + + pdf_params_zm_frz(:)%w_1 = zero + pdf_params_zm_frz(:)%w_2 = zero + pdf_params_zm_frz(:)%varnce_w_1 = zero + pdf_params_zm_frz(:)%varnce_w_2 = zero + pdf_params_zm_frz(:)%rt_1 = zero + pdf_params_zm_frz(:)%rt_2 = zero + pdf_params_zm_frz(:)%varnce_rt_1 = zero + pdf_params_zm_frz(:)%varnce_rt_2 = zero + pdf_params_zm_frz(:)%thl_1 = zero + pdf_params_zm_frz(:)%thl_2 = zero + pdf_params_zm_frz(:)%varnce_thl_1 = zero + pdf_params_zm_frz(:)%varnce_thl_2 = zero + pdf_params_zm_frz(:)%rrtthl = zero + pdf_params_zm_frz(:)%alpha_thl = zero + pdf_params_zm_frz(:)%alpha_rt = zero + pdf_params_zm_frz(:)%crt_1 = zero + pdf_params_zm_frz(:)%crt_2 = zero + pdf_params_zm_frz(:)%cthl_1 = zero + pdf_params_zm_frz(:)%cthl_2 = zero + pdf_params_zm_frz(:)%chi_1 = zero + pdf_params_zm_frz(:)%chi_2 = zero + pdf_params_zm_frz(:)%stdev_chi_1 = zero + pdf_params_zm_frz(:)%stdev_chi_2 = zero + pdf_params_zm_frz(:)%stdev_eta_1 = zero + pdf_params_zm_frz(:)%stdev_eta_2 = zero + pdf_params_zm_frz(:)%covar_chi_eta_1 = zero + pdf_params_zm_frz(:)%covar_chi_eta_2 = zero + pdf_params_zm_frz(:)%corr_chi_eta_1 = zero + pdf_params_zm_frz(:)%corr_chi_eta_2 = zero + pdf_params_zm_frz(:)%rsatl_1 = zero + pdf_params_zm_frz(:)%rsatl_2 = zero + pdf_params_zm_frz(:)%rc_1 = zero + pdf_params_zm_frz(:)%rc_2 = zero + pdf_params_zm_frz(:)%cloud_frac_1 = zero + pdf_params_zm_frz(:)%cloud_frac_2 = zero + pdf_params_zm_frz(:)%mixt_frac = zero ! Second order moments thlprcp = 0.0_core_rknd @@ -441,6 +491,10 @@ subroutine setup_diagnostic_variables( nzmax ) Kh_zt = 0.0_core_rknd ! Eddy diffusivity coefficient: thermo. levels Kh_zm = 0.0_core_rknd ! Eddy diffusivity coefficient: momentum levels + do i = 1, hydromet_dim, 1 + K_hm(1:nz,i) = 0.0_core_rknd ! Eddy diff. coef. for hydromets.: mom. levs. + end do + ! TKE em = em_min @@ -454,11 +508,17 @@ subroutine setup_diagnostic_variables( nzmax ) tau_zt = 0.0_core_rknd ! Eddy dissipation time scale: thermo. levels ! Hydrometer types - Ncnm(1:nzmax) = 0.0_core_rknd ! Cloud nuclei number concentration (COAMPS) + Nccnm(1:nz) = 0.0_core_rknd ! CCN concentration (COAMPS/MG) do i = 1, hydromet_dim, 1 - hydromet(1:nzmax,i) = 0.0_core_rknd - end do + hydromet(1:nz,i) = 0.0_core_rknd + hydrometp2(1:nz,i) = 0.0_core_rknd + wphydrometp(1:nz,i) = 0.0_core_rknd + enddo + + ! Cloud droplet concentration + Ncm(1:nz) = 0.0_core_rknd + wpNcp(1:nz) = 0.0_core_rknd ! Variables for Latin hypercube microphysics. Vince Larson 22 May 2005 @@ -486,14 +546,6 @@ subroutine setup_diagnostic_variables( nzmax ) wpedsclrp(:,:) = 0.0_core_rknd end if - sptp_mellor_1 = 0.0_core_rknd - sptp_mellor_2 = 0.0_core_rknd - tp2_mellor_1 = 0.0_core_rknd - tp2_mellor_2 = 0.0_core_rknd - - corr_st_mellor1 = 0.0_core_rknd - corr_st_mellor2 = 0.0_core_rknd - Skw_velocity = 0.0_core_rknd a3_coef = 0.0_core_rknd @@ -540,6 +592,7 @@ subroutine cleanup_diagnostic_variables( ) deallocate( radht ) ! SW + LW heating rate deallocate( pdf_params_zm ) + deallocate( pdf_params_zm_frz ) ! Second order moments @@ -571,6 +624,7 @@ subroutine cleanup_diagnostic_variables( ) deallocate( Kh_zt ) ! Eddy diffusivity coefficient: thermo. levels deallocate( Kh_zm ) ! Eddy diffusivity coefficient: momentum levels + deallocate( K_hm ) ! Eddy diff. coef. for hydromets.: mom. levs. deallocate( em ) deallocate( Lscale ) @@ -581,10 +635,13 @@ subroutine cleanup_diagnostic_variables( ) ! Cloud water variables - deallocate( Ncnm ) - - deallocate( hydromet ) ! Hydrometeor fields + deallocate( Nccnm ) + deallocate( hydromet ) ! Hydrometeor mean fields + deallocate( hydrometp2 ) ! < h_m'^2 > fields + deallocate( wphydrometp ) ! < w'h_m' > fields + deallocate( Ncm ) ! Mean cloud droplet concentration, < N_c > + deallocate( wpNcp ) ! < w'N_c' > ! Interpolated variables for tuning deallocate( wp2_zt ) ! w'^2 on thermo. grid @@ -618,14 +675,6 @@ subroutine cleanup_diagnostic_variables( ) deallocate( wpedsclrp ) - ! Diagnostics for s and t Mellor - deallocate( sptp_mellor_1 ) - deallocate( sptp_mellor_2 ) - deallocate( tp2_mellor_1 ) - deallocate( tp2_mellor_2 ) - deallocate( corr_st_mellor1 ) - deallocate( corr_st_mellor2 ) - deallocate( Skw_velocity ) deallocate( a3_coef ) diff --git a/models/atm/cam/src/physics/clubb/variables_prognostic_module.F90 b/models/atm/cam/src/physics/clubb/variables_prognostic_module.F90 index f47d83b31c2d..f472c6975850 100644 --- a/models/atm/cam/src/physics/clubb/variables_prognostic_module.F90 +++ b/models/atm/cam/src/physics/clubb/variables_prognostic_module.F90 @@ -1,5 +1,6 @@ !----------------------------------------------------------------------- -! $Id: variables_prognostic_module.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +! $Id: variables_prognostic_module.F90 7309 2014-09-20 17:06:28Z betlej@uwm.edu $ +!=============================================================================== module variables_prognostic_module ! This module contains definitions of all prognostic @@ -47,7 +48,8 @@ module variables_prognostic_module rtp2, & ! rt'^2 [(kg/kg)^2] thlp2, & ! thl'^2 [K^2] rtpthlp ! rt'thl' [kg/kg K] -!$omp threadprivate(temp_clubb) +!$omp threadprivate( temp_clubb) + #else real( kind = core_rknd ), target, allocatable, dimension(:), public :: & um, & ! u wind [m/s] @@ -87,11 +89,17 @@ module variables_prognostic_module thlm_forcing, & ! thlm large-scale forcing [K/s] rtm_forcing, & ! rtm large-scale forcing [kg/kg/s] um_forcing, & ! u wind forcing [m/s/s] - vm_forcing ! v wind forcing [m/s/s] - -!$omp threadprivate(p_in_Pa, exner, rho, rho_zm, rho_ds_zm, & -!$omp rho_ds_zt, invrs_rho_ds_zm, invrs_rho_ds_zt, thv_ds_zm, & -!$omp thv_ds_zt, thlm_forcing, rtm_forcing, um_forcing, vm_forcing) + vm_forcing, & ! v wind forcing [m/s/s] + wprtp_forcing, & ! forcing (momentum levels) [m*K/s^2] + wpthlp_forcing, & ! forcing (momentum levels) [m*(kg/kg)/s^2] + rtp2_forcing, & ! forcing (momentum levels) [(kg/kg)^2/s] + thlp2_forcing, & ! forcing (momentum levels) [K^2/s] + rtpthlp_forcing ! forcing (momentum levels) [K*(kg/kg)/s] + +!$omp threadprivate( p_in_Pa, exner, rho, rho_zm, rho_ds_zm, rho_ds_zt, & +!$omp invrs_rho_ds_zm, invrs_rho_ds_zt, thv_ds_zm, thv_ds_zt, & +!$omp thlm_forcing, rtm_forcing, um_forcing, vm_forcing, wprtp_forcing, & +!$omp wpthlp_forcing, rtp2_forcing, thlp2_forcing, rtpthlp_forcing ) ! Imposed large scale w real( kind = core_rknd ), target, allocatable, dimension(:), public :: & @@ -102,12 +110,13 @@ module variables_prognostic_module ! Cloud water variables real( kind = core_rknd ), target, allocatable, dimension(:), public :: & - rcm, & ! Cloud water mixing ratio [kg/kg] - cloud_frac, & ! Cloud fraction [-] - rcm_in_layer, & ! Cloud water mixing ratio in cloud layer [kg/kg] - cloud_cover ! Cloud cover [-] + rcm, & ! Cloud water mixing ratio [kg/kg] + cloud_frac, & ! Cloud fraction [-] + ice_supersat_frac, & ! Ice cloud fraction [-] + rcm_in_layer, & ! Cloud water mixing ratio in cloud layer [kg/kg] + cloud_cover ! Cloud cover [-] -!$omp threadprivate(rcm, cloud_frac, rcm_in_layer, cloud_cover) +!$omp threadprivate(rcm, cloud_frac, ice_supersat_frac, rcm_in_layer, cloud_cover) ! Surface fluxes real( kind = core_rknd ), public :: & @@ -148,7 +157,7 @@ module variables_prognostic_module #ifdef GFDL real( kind = core_rknd ), target, allocatable, dimension( : , : , : ), public :: & RH_crit ! critical relative humidity for droplet and ice nucleation -!$omp threadprivate(RH_crit) +!$omp threadprivate(RH_crit) #endif !<--- h1g, 2010-06-16 @@ -162,13 +171,14 @@ module variables_prognostic_module !$omp threadprivate(sigma_sqd_w) type(pdf_parameter), target, allocatable, dimension(:), public :: & - pdf_params + pdf_params, & + pdf_params_frz !for use when l_use_ice_latent = .true. -!$omp threadprivate(pdf_params) +!$omp threadprivate(pdf_params, pdf_params_frz) contains !----------------------------------------------------------------------- - subroutine setup_prognostic_variables( nzmax ) + subroutine setup_prognostic_variables( nz ) ! Description: ! Allocates and Initializes prognostic scalar and array variables @@ -180,9 +190,10 @@ subroutine setup_prognostic_variables( nzmax ) ! None !----------------------------------------------------------------------- use constants_clubb, only: & - rt_tol, & - thl_tol, & - w_tol_sqd + rt_tol, & ! Constant(s) + thl_tol, & + w_tol_sqd, & + zero use parameters_model, only: & sclr_dim, & ! Variable(s) @@ -193,7 +204,7 @@ subroutine setup_prognostic_variables( nzmax ) implicit none - integer, intent(in) :: nzmax ! Number of grid levels [-] + integer, intent(in) :: nz ! Number of grid levels [-] integer :: i @@ -201,171 +212,227 @@ subroutine setup_prognostic_variables( nzmax ) ! Prognostic variables - allocate( um(1:nzmax) ) ! u wind - allocate( vm(1:nzmax) ) ! v wind + allocate( um(1:nz) ) ! u wind + allocate( vm(1:nz) ) ! v wind - allocate( upwp(1:nzmax) ) ! vertical u momentum flux - allocate( vpwp(1:nzmax) ) ! vertical v momentum flux + allocate( upwp(1:nz) ) ! vertical u momentum flux + allocate( vpwp(1:nz) ) ! vertical v momentum flux - allocate( up2(1:nzmax) ) - allocate( vp2(1:nzmax) ) + allocate( up2(1:nz) ) + allocate( vp2(1:nz) ) - allocate( thlm(1:nzmax) ) ! liquid potential temperature + allocate( thlm(1:nz) ) ! liquid potential temperature !---> h1g, 2010-06-16 #ifdef GFDL - allocate( temp_clubb(1:nzmax) ) ! air temperature + allocate( temp_clubb(1:nz) ) ! air temperature #endif !<--- h1g, 2010-06-16 - allocate( rtm(1:nzmax) ) ! total water mixing ratio - allocate( wprtp(1:nzmax) ) ! w'rt' - allocate( wpthlp(1:nzmax) ) ! w'thl' - allocate( wprcp(1:nzmax) ) ! w'rc' - allocate( wp2(1:nzmax) ) ! w'^2 - allocate( wp3(1:nzmax) ) ! w'^3 - allocate( rtp2(1:nzmax) ) ! rt'^2 - allocate( thlp2(1:nzmax) ) ! thl'^2 - allocate( rtpthlp(1:nzmax) ) ! rt'thlp' - - allocate( p_in_Pa(1:nzmax) ) ! pressure (pascals) - allocate( exner(1:nzmax) ) ! exner function - allocate( rho(1:nzmax) ) ! density: t points - allocate( rho_zm(1:nzmax) ) ! density: m points - allocate( rho_ds_zm(1:nzmax) ) ! dry, static density: m-levs - allocate( rho_ds_zt(1:nzmax) ) ! dry, static density: t-levs - allocate( invrs_rho_ds_zm(1:nzmax) ) ! inv. dry, static density: m-levs - allocate( invrs_rho_ds_zt(1:nzmax) ) ! inv. dry, static density: t-levs - allocate( thv_ds_zm(1:nzmax) ) ! dry, base-state theta_v: m-levs - allocate( thv_ds_zt(1:nzmax) ) ! dry, base-state theta_v: t-levs - - allocate( thlm_forcing(1:nzmax) ) ! thlm ls forcing - allocate( rtm_forcing(1:nzmax) ) ! rtm ls forcing - allocate( um_forcing(1:nzmax) ) ! u forcing - allocate( vm_forcing(1:nzmax) ) ! v forcing + allocate( rtm(1:nz) ) ! total water mixing ratio + allocate( wprtp(1:nz) ) ! w'rt' + allocate( wpthlp(1:nz) ) ! w'thl' + allocate( wprcp(1:nz) ) ! w'rc' + allocate( wp2(1:nz) ) ! w'^2 + allocate( wp3(1:nz) ) ! w'^3 + allocate( rtp2(1:nz) ) ! rt'^2 + allocate( thlp2(1:nz) ) ! thl'^2 + allocate( rtpthlp(1:nz) ) ! rt'thlp' + + allocate( p_in_Pa(1:nz) ) ! pressure (pascals) + allocate( exner(1:nz) ) ! exner function + allocate( rho(1:nz) ) ! density: t points + allocate( rho_zm(1:nz) ) ! density: m points + allocate( rho_ds_zm(1:nz) ) ! dry, static density: m-levs + allocate( rho_ds_zt(1:nz) ) ! dry, static density: t-levs + allocate( invrs_rho_ds_zm(1:nz) ) ! inv. dry, static density: m-levs + allocate( invrs_rho_ds_zt(1:nz) ) ! inv. dry, static density: t-levs + allocate( thv_ds_zm(1:nz) ) ! dry, base-state theta_v: m-levs + allocate( thv_ds_zt(1:nz) ) ! dry, base-state theta_v: t-levs + + allocate( thlm_forcing(1:nz) ) ! thlm ls forcing + allocate( rtm_forcing(1:nz) ) ! rtm ls forcing + allocate( um_forcing(1:nz) ) ! u forcing + allocate( vm_forcing(1:nz) ) ! v forcing + allocate( wprtp_forcing(1:nz) ) ! forcing (microphysics) + allocate( wpthlp_forcing(1:nz) ) ! forcing (microphysics) + allocate( rtp2_forcing(1:nz) ) ! forcing (microphysics) + allocate( thlp2_forcing(1:nz) ) ! forcing (microphysics) + allocate( rtpthlp_forcing(1:nz) ) ! forcing (microphysics) ! Imposed large scale w - allocate( wm_zm(1:nzmax) ) ! momentum levels - allocate( wm_zt(1:nzmax) ) ! thermodynamic levels + allocate( wm_zm(1:nz) ) ! momentum levels + allocate( wm_zt(1:nz) ) ! thermodynamic levels ! Cloud water variables - allocate( rcm(1:nzmax) ) - allocate( cloud_frac(1:nzmax) ) - allocate( rcm_in_layer(1:nzmax) ) - allocate( cloud_cover(1:nzmax) ) + allocate( rcm(1:nz) ) + allocate( cloud_frac(1:nz) ) + allocate( ice_supersat_frac(1:nz) ) + allocate( rcm_in_layer(1:nz) ) + allocate( cloud_cover(1:nz) ) ! Passive scalar variables ! Note that sclr_dim can be 0 allocate( wpsclrp_sfc(1:sclr_dim) ) - allocate( sclrm(1:nzmax, 1:sclr_dim) ) - allocate( sclrp2(1:nzmax, 1:sclr_dim) ) - allocate( sclrm_forcing(1:nzmax, 1:sclr_dim) ) - allocate( sclrprtp(1:nzmax, 1:sclr_dim) ) - allocate( sclrpthlp(1:nzmax, 1:sclr_dim) ) + allocate( sclrm(1:nz, 1:sclr_dim) ) + allocate( sclrp2(1:nz, 1:sclr_dim) ) + allocate( sclrm_forcing(1:nz, 1:sclr_dim) ) + allocate( sclrprtp(1:nz, 1:sclr_dim) ) + allocate( sclrpthlp(1:nz, 1:sclr_dim) ) allocate( wpedsclrp_sfc(1:edsclr_dim) ) - allocate( edsclrm_forcing(1:nzmax, 1:edsclr_dim) ) + allocate( edsclrm_forcing(1:nz, 1:edsclr_dim) ) - allocate( edsclrm(1:nzmax, 1:edsclr_dim) ) - allocate( wpsclrp(1:nzmax, 1:sclr_dim) ) + allocate( edsclrm(1:nz, 1:edsclr_dim) ) + allocate( wpsclrp(1:nz, 1:sclr_dim) ) !---> h1g, 2010-06-16 #ifdef GFDL - allocate( RH_crit(1:nzmax, 1:min(1,sclr_dim), 2) ) + allocate( RH_crit(1:nz, 1:min(1,sclr_dim), 2) ) #endif !<--- h1g, 2010-06-16 - allocate( sigma_sqd_w(1:nzmax) ) ! PDF width parameter (momentum levels) + allocate( sigma_sqd_w(1:nz) ) ! PDF width parameter (momentum levels) ! Variables for pdf closure scheme - allocate( pdf_params(1:nzmax) ) + allocate( pdf_params(1:nz) ) + allocate( pdf_params_frz(1:nz) ) !--------- Set initial values for array variables --------- ! Prognostic variables - um(1:nzmax) = 0.0_core_rknd ! u wind - vm (1:nzmax) = 0.0_core_rknd ! v wind - - upwp(1:nzmax) = 0.0_core_rknd ! vertical u momentum flux - vpwp(1:nzmax) = 0.0_core_rknd ! vertical v momentum flux - - up2(1:nzmax) = w_tol_sqd ! u'^2 - vp2(1:nzmax) = w_tol_sqd ! v'^2 - wp2(1:nzmax) = w_tol_sqd ! w'^2 - - thlm(1:nzmax) = 0.0_core_rknd ! liquid potential temperature - rtm(1:nzmax) = 0.0_core_rknd ! total water mixing ratio - wprtp(1:nzmax) = 0.0_core_rknd ! w'rt' - wpthlp(1:nzmax) = 0.0_core_rknd ! w'thl' - wprcp(1:nzmax) = 0.0_core_rknd ! w'rc' - wp3(1:nzmax) = 0.0_core_rknd ! w'^3 - rtp2(1:nzmax) = rt_tol**2 ! rt'^2 - thlp2(1:nzmax) = thl_tol**2 ! thl'^2 - rtpthlp(1:nzmax) = 0.0_core_rknd ! rt'thl' - - p_in_Pa(1:nzmax)= 0.0_core_rknd ! pressure (Pa) - exner(1:nzmax) = 0.0_core_rknd ! exner - rho(1:nzmax) = 0.0_core_rknd ! density on thermo. levels - rho_zm(1:nzmax) = 0.0_core_rknd ! density on moment. levels - rho_ds_zm(1:nzmax) = 0.0_core_rknd ! dry, static density: m-levs - rho_ds_zt(1:nzmax) = 0.0_core_rknd ! dry, static density: t-levs - invrs_rho_ds_zm(1:nzmax) = 0.0_core_rknd ! inv. dry, static density: m-levs - invrs_rho_ds_zt(1:nzmax) = 0.0_core_rknd ! inv. dry, static density: t-levs - thv_ds_zm(1:nzmax) = 0.0_core_rknd ! dry, base-state theta_v: m-levs - thv_ds_zt(1:nzmax) = 0.0_core_rknd ! dry, base-state theta_v: t-levs - - thlm_forcing(1:nzmax) = 0.0_core_rknd ! thlm large-scale forcing - rtm_forcing(1:nzmax) = 0.0_core_rknd ! rtm large-scale forcing - um_forcing(1:nzmax) = 0.0_core_rknd ! u forcing - vm_forcing(1:nzmax) = 0.0_core_rknd ! v forcing + um(1:nz) = 0.0_core_rknd ! u wind + vm (1:nz) = 0.0_core_rknd ! v wind + + upwp(1:nz) = 0.0_core_rknd ! vertical u momentum flux + vpwp(1:nz) = 0.0_core_rknd ! vertical v momentum flux + + up2(1:nz) = w_tol_sqd ! u'^2 + vp2(1:nz) = w_tol_sqd ! v'^2 + wp2(1:nz) = w_tol_sqd ! w'^2 + + thlm(1:nz) = 0.0_core_rknd ! liquid potential temperature + rtm(1:nz) = 0.0_core_rknd ! total water mixing ratio + wprtp(1:nz) = 0.0_core_rknd ! w'rt' + wpthlp(1:nz) = 0.0_core_rknd ! w'thl' + wprcp(1:nz) = 0.0_core_rknd ! w'rc' + wp3(1:nz) = 0.0_core_rknd ! w'^3 + rtp2(1:nz) = rt_tol**2 ! rt'^2 + thlp2(1:nz) = thl_tol**2 ! thl'^2 + rtpthlp(1:nz) = 0.0_core_rknd ! rt'thl' + + p_in_Pa(1:nz)= 0.0_core_rknd ! pressure (Pa) + exner(1:nz) = 0.0_core_rknd ! exner + rho(1:nz) = 0.0_core_rknd ! density on thermo. levels + rho_zm(1:nz) = 0.0_core_rknd ! density on moment. levels + rho_ds_zm(1:nz) = 0.0_core_rknd ! dry, static density: m-levs + rho_ds_zt(1:nz) = 0.0_core_rknd ! dry, static density: t-levs + invrs_rho_ds_zm(1:nz) = 0.0_core_rknd ! inv. dry, static density: m-levs + invrs_rho_ds_zt(1:nz) = 0.0_core_rknd ! inv. dry, static density: t-levs + thv_ds_zm(1:nz) = 0.0_core_rknd ! dry, base-state theta_v: m-levs + thv_ds_zt(1:nz) = 0.0_core_rknd ! dry, base-state theta_v: t-levs + + thlm_forcing(1:nz) = zero ! thlm large-scale forcing + rtm_forcing(1:nz) = zero ! rtm large-scale forcing + um_forcing(1:nz) = zero ! u forcing + vm_forcing(1:nz) = zero ! v forcing + wprtp_forcing(1:nz) = zero ! forcing (microphysics) + wpthlp_forcing(1:nz) = zero ! forcing (microphysics) + rtp2_forcing(1:nz) = zero ! forcing (microphysics) + thlp2_forcing(1:nz) = zero ! forcing (microphysics) + rtpthlp_forcing(1:nz) = zero ! forcing (microphysics) ! Imposed large scale w - wm_zm(1:nzmax) = 0.0_core_rknd ! Momentum levels - wm_zt(1:nzmax) = 0.0_core_rknd ! Thermodynamic levels + wm_zm(1:nz) = 0.0_core_rknd ! Momentum levels + wm_zt(1:nz) = 0.0_core_rknd ! Thermodynamic levels ! Cloud water variables - rcm(1:nzmax) = 0.0_core_rknd - cloud_frac(1:nzmax) = 0.0_core_rknd - rcm_in_layer(1:nzmax) = 0.0_core_rknd - cloud_cover(1:nzmax) = 0.0_core_rknd + rcm(1:nz) = 0.0_core_rknd + cloud_frac(1:nz) = 0.0_core_rknd + ice_supersat_frac(1:nz) = 0.0_core_rknd + rcm_in_layer(1:nz) = 0.0_core_rknd + cloud_cover(1:nz) = 0.0_core_rknd sigma_sqd_w = 0.0_core_rknd ! PDF width parameter (momentum levels) ! Variables for PDF closure scheme - pdf_params(:)%w1 = 0.0_core_rknd - pdf_params(:)%w2 = 0.0_core_rknd - pdf_params(:)%varnce_w1 = 0.0_core_rknd - pdf_params(:)%varnce_w2 = 0.0_core_rknd - pdf_params(:)%rt1 = 0.0_core_rknd - pdf_params(:)%rt2 = 0.0_core_rknd - pdf_params(:)%varnce_rt1 = 0.0_core_rknd - pdf_params(:)%varnce_rt2 = 0.0_core_rknd - pdf_params(:)%thl1 = 0.0_core_rknd - pdf_params(:)%thl2 = 0.0_core_rknd - pdf_params(:)%varnce_thl1 = 0.0_core_rknd - pdf_params(:)%varnce_thl2 = 0.0_core_rknd - pdf_params(:)%mixt_frac = 0.0_core_rknd - pdf_params(:)%rc1 = 0.0_core_rknd - pdf_params(:)%rc2 = 0.0_core_rknd - pdf_params(:)%rsl1 = 0.0_core_rknd - pdf_params(:)%rsl2 = 0.0_core_rknd - pdf_params(:)%cloud_frac1 = 0.0_core_rknd - pdf_params(:)%cloud_frac2 = 0.0_core_rknd - pdf_params(:)%s1 = 0.0_core_rknd - pdf_params(:)%s2 = 0.0_core_rknd - pdf_params(:)%stdev_s1 = 0.0_core_rknd - pdf_params(:)%stdev_s2 = 0.0_core_rknd - pdf_params(:)%rrtthl = 0.0_core_rknd - pdf_params(:)%alpha_thl = 0.0_core_rknd - pdf_params(:)%alpha_rt = 0.0_core_rknd - pdf_params(:)%crt1 = 0.0_core_rknd - pdf_params(:)%crt2 = 0.0_core_rknd - pdf_params(:)%cthl1 = 0.0_core_rknd - pdf_params(:)%cthl2 = 0.0_core_rknd + pdf_params(:)%w_1 = zero + pdf_params(:)%w_2 = zero + pdf_params(:)%varnce_w_1 = zero + pdf_params(:)%varnce_w_2 = zero + pdf_params(:)%rt_1 = zero + pdf_params(:)%rt_2 = zero + pdf_params(:)%varnce_rt_1 = zero + pdf_params(:)%varnce_rt_2 = zero + pdf_params(:)%thl_1 = zero + pdf_params(:)%thl_2 = zero + pdf_params(:)%varnce_thl_1 = zero + pdf_params(:)%varnce_thl_2 = zero + pdf_params(:)%rrtthl = zero + pdf_params(:)%alpha_thl = zero + pdf_params(:)%alpha_rt = zero + pdf_params(:)%crt_1 = zero + pdf_params(:)%crt_2 = zero + pdf_params(:)%cthl_1 = zero + pdf_params(:)%cthl_2 = zero + pdf_params(:)%chi_1 = zero + pdf_params(:)%chi_2 = zero + pdf_params(:)%stdev_chi_1 = zero + pdf_params(:)%stdev_chi_2 = zero + pdf_params(:)%stdev_eta_1 = zero + pdf_params(:)%stdev_eta_2 = zero + pdf_params(:)%covar_chi_eta_1 = zero + pdf_params(:)%covar_chi_eta_2 = zero + pdf_params(:)%corr_chi_eta_1 = zero + pdf_params(:)%corr_chi_eta_2 = zero + pdf_params(:)%rsatl_1 = zero + pdf_params(:)%rsatl_2 = zero + pdf_params(:)%rc_1 = zero + pdf_params(:)%rc_2 = zero + pdf_params(:)%cloud_frac_1 = zero + pdf_params(:)%cloud_frac_2 = zero + pdf_params(:)%mixt_frac = zero + + pdf_params_frz(:)%w_1 = zero + pdf_params_frz(:)%w_2 = zero + pdf_params_frz(:)%varnce_w_1 = zero + pdf_params_frz(:)%varnce_w_2 = zero + pdf_params_frz(:)%rt_1 = zero + pdf_params_frz(:)%rt_2 = zero + pdf_params_frz(:)%varnce_rt_1 = zero + pdf_params_frz(:)%varnce_rt_2 = zero + pdf_params_frz(:)%thl_1 = zero + pdf_params_frz(:)%thl_2 = zero + pdf_params_frz(:)%varnce_thl_1 = zero + pdf_params_frz(:)%varnce_thl_2 = zero + pdf_params_frz(:)%rrtthl = zero + pdf_params_frz(:)%alpha_thl = zero + pdf_params_frz(:)%alpha_rt = zero + pdf_params_frz(:)%crt_1 = zero + pdf_params_frz(:)%crt_2 = zero + pdf_params_frz(:)%cthl_1 = zero + pdf_params_frz(:)%cthl_2 = zero + pdf_params_frz(:)%chi_1 = zero + pdf_params_frz(:)%chi_2 = zero + pdf_params_frz(:)%stdev_chi_1 = zero + pdf_params_frz(:)%stdev_chi_2 = zero + pdf_params_frz(:)%stdev_eta_1 = zero + pdf_params_frz(:)%stdev_eta_2 = zero + pdf_params_frz(:)%covar_chi_eta_1 = zero + pdf_params_frz(:)%covar_chi_eta_2 = zero + pdf_params_frz(:)%corr_chi_eta_1 = zero + pdf_params_frz(:)%corr_chi_eta_2 = zero + pdf_params_frz(:)%rsatl_1 = zero + pdf_params_frz(:)%rsatl_2 = zero + pdf_params_frz(:)%rc_1 = zero + pdf_params_frz(:)%rc_2 = zero + pdf_params_frz(:)%cloud_frac_1 = zero + pdf_params_frz(:)%cloud_frac_2 = zero + pdf_params_frz(:)%mixt_frac = zero ! Surface fluxes wpthlp_sfc = 0.0_core_rknd @@ -384,19 +451,19 @@ subroutine setup_prognostic_variables( nzmax ) do i = 1, sclr_dim, 1 wpsclrp_sfc(i) = 0.0_core_rknd - sclrm(1:nzmax,i) = 0.0_core_rknd - sclrp2(1:nzmax,i) = 0.0_core_rknd - sclrprtp(1:nzmax,i) = 0.0_core_rknd - sclrpthlp(1:nzmax,i) = 0.0_core_rknd - sclrm_forcing(1:nzmax,i) = 0.0_core_rknd - wpsclrp(1:nzmax,i) = 0.0_core_rknd + sclrm(1:nz,i) = 0.0_core_rknd + sclrp2(1:nz,i) = 0.0_core_rknd + sclrprtp(1:nz,i) = 0.0_core_rknd + sclrpthlp(1:nz,i) = 0.0_core_rknd + sclrm_forcing(1:nz,i) = 0.0_core_rknd + wpsclrp(1:nz,i) = 0.0_core_rknd end do do i = 1, edsclr_dim, 1 wpedsclrp_sfc(i) = 0.0_core_rknd - edsclrm(1:nzmax,i) = 0.0_core_rknd - edsclrm_forcing(1:nzmax,i) = 0.0_core_rknd + edsclrm(1:nz,i) = 0.0_core_rknd + edsclrm_forcing(1:nz,i) = 0.0_core_rknd end do return @@ -444,10 +511,15 @@ subroutine cleanup_prognostic_variables deallocate( thv_ds_zm ) ! dry, base-state theta_v: m-levs deallocate( thv_ds_zt ) ! dry, base-state theta_v: t-levs - deallocate( thlm_forcing ) - deallocate( rtm_forcing ) - deallocate( um_forcing ) - deallocate( vm_forcing ) + deallocate( thlm_forcing ) ! thlm large-scale forcing + deallocate( rtm_forcing ) ! rtm large-scale forcing + deallocate( um_forcing ) ! u forcing + deallocate( vm_forcing ) ! v forcing + deallocate( wprtp_forcing ) ! forcing (microphysics) + deallocate( wpthlp_forcing ) ! forcing (microphysics) + deallocate( rtp2_forcing ) ! forcing (microphysics) + deallocate( thlp2_forcing ) ! forcing (microphysics) + deallocate( rtpthlp_forcing ) ! forcing (microphysics) ! Imposed large scale w @@ -458,6 +530,7 @@ subroutine cleanup_prognostic_variables deallocate( rcm ) deallocate( cloud_frac ) + deallocate( ice_supersat_frac ) deallocate( rcm_in_layer ) deallocate( cloud_cover ) @@ -465,6 +538,7 @@ subroutine cleanup_prognostic_variables ! Variable for pdf closure scheme deallocate( pdf_params ) + deallocate( pdf_params_frz ) ! Passive scalars deallocate( wpsclrp_sfc, wpedsclrp_sfc ) diff --git a/models/atm/cam/src/physics/clubb/variables_radiation_module.F90 b/models/atm/cam/src/physics/clubb/variables_radiation_module.F90 deleted file mode 100644 index fac03ec4fcd7..000000000000 --- a/models/atm/cam/src/physics/clubb/variables_radiation_module.F90 +++ /dev/null @@ -1,199 +0,0 @@ -!--------------------------------------------------------------- -! $Id: variables_radiation_module.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -module variables_radiation_module - -! This module contains definitions of all radiation arrays -! used in the single column model, as well as subroutines to -! allocate, deallocate, and initialize them. -!--------------------------------------------------------------- - - use clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - - public :: & - setup_radiation_variables, & - cleanup_radiation_variables - - private ! Set Default Scoping - - integer, private, parameter :: dp = selected_real_kind( p=12 ) - - real( kind = core_rknd ), public, dimension(:), allocatable :: & - radht_LW, & ! LW heating rate [K/s] - radht_SW, & ! SW heating rate [K/s] - Frad_SW, & ! SW radiative flux [W/m^2] - Frad_LW ! LW radiative flux [W/m^2] - -!$omp threadprivate(radht_LW, radht_SW, Frad_SW, Frad_LW) - - real(kind = dp), public, dimension(:,:), allocatable :: & - T_in_K, & ! Temperature [K] - rcil, & ! Ice mixing ratio [kg/kg] - o3l ! Ozone mixing ratio [kg/kg] - -!$omp threadprivate(T_in_K, rcil, o3l) - - real(kind = dp), public, dimension(:,:), allocatable :: & - rsnowm_2d,& ! Two-dimensional copies of the input parameters - rcm_in_cloud_2d, & - cloud_frac_2d - -!$omp threadprivate(rsnowm_2d, rcm_in_cloud_2d, cloud_frac_2d) - - real(kind = dp), public, dimension(:,:), allocatable :: & - radht_SW_2d, & ! SW Radiative heating rate [W/m^2] - radht_LW_2d ! LW Radiative heating rate [W/m^2] - -!$omp threadprivate(radht_SW_2d, radht_LW_2d) - - real(kind = dp), public, dimension(:,:), allocatable :: & - Frad_uLW, & ! LW upwelling flux [W/m^2] - Frad_dLW, & ! LW downwelling flux [W/m^2] - Frad_uSW, & ! SW upwelling flux [W/m^2] - Frad_dSW ! SW downwelling flux [W/m^2] - -!$omp threadprivate(Frad_uLW, Frad_dLW, Frad_uSW, Frad_dSW) - - real(kind = dp), public, dimension(:,:), allocatable :: & - fdswcl, & !Downward clear-sky SW flux (W/m^-2). - fuswcl, & !Upward clear-sky SW flux (W/m^-2). - fdlwcl, & !Downward clear-sky LW flux (W/m^-2). - fulwcl !Upward clear-sky LW flux (W/m^-2). - -!$omp threadprivate(fdswcl, fuswcl, fdlwcl, fulwcl) - - ! Constant parameters - integer, private, parameter :: & - nlen = 1, & ! Length of the total domain - slen = 1 ! Length of the sub domain - - contains - - !--------------------------------------------------------------------- - subroutine setup_radiation_variables( nzmax, lin_int_buffer, & - extend_atmos_range_size ) - ! Description: - ! Allocates and initializes prognostic scalar and array variables - ! for the CLUBB model code. - !--------------------------------------------------------------------- - - use clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! Input Variables - integer, intent(in) :: & - nzmax, & ! Number of grid levels [-] - lin_int_buffer,& ! Number of interpolated levels between the computational - ! grid and the extended atmosphere [-] - extend_atmos_range_size ! The number of levels in the extended atmosphere [-] - - ! Local Variables - - integer :: rad_zt_dim, rad_zm_dim ! Dimensions of the radiation grid - - !----------------------------BEGIN CODE------------------------------- - - rad_zt_dim = (nzmax-1)+lin_int_buffer+extend_atmos_range_size - rad_zm_dim = (nzmax-1)+lin_int_buffer+extend_atmos_range_size+1 - - - ! --- Allocation --- - - allocate( radht_SW(1:nzmax) ) - allocate( radht_LW(1:nzmax) ) - allocate( Frad_SW(1:nzmax) ) - allocate( Frad_LW(1:nzmax) ) - - allocate( T_in_K(nlen, rad_zt_dim ) ) - allocate( rcil(nlen, rad_zt_dim ) ) - allocate( o3l(nlen, rad_zt_dim ) ) - - allocate( rsnowm_2d(nlen, rad_zt_dim ) ) - allocate( rcm_in_cloud_2d(nlen, rad_zt_dim ) ) - allocate( cloud_frac_2d(nlen, rad_zt_dim ) ) - - allocate( radht_SW_2d(nlen, rad_zt_dim ) ) - allocate( radht_LW_2d(nlen, rad_zt_dim ) ) - - allocate( Frad_uLW(nlen, rad_zm_dim ) ) - allocate( Frad_dLW(nlen, rad_zm_dim ) ) - allocate( Frad_uSW(nlen, rad_zm_dim ) ) - allocate( Frad_dSW(nlen, rad_zm_dim ) ) - - allocate( fdswcl(slen, rad_zm_dim ) ) - allocate( fuswcl(slen, rad_zm_dim ) ) - allocate( fdlwcl(slen, rad_zm_dim ) ) - allocate( fulwcl(slen, rad_zm_dim ) ) - - - ! --- Initialization --- - - radht_SW = 0.0_core_rknd - radht_LW = 0.0_core_rknd - Frad_SW = 0.0_core_rknd - Frad_LW = 0.0_core_rknd - T_in_K = 0.0_dp - rcil = 0.0_dp - o3l = 0.0_dp - rsnowm_2d = 0.0_dp - rcm_in_cloud_2d = 0.0_dp - cloud_frac_2d = 0.0_dp - radht_SW_2d = 0.0_dp - radht_LW_2d = 0.0_dp - Frad_uLW = 0.0_dp - Frad_dLW = 0.0_dp - Frad_uSW = 0.0_dp - Frad_dSW = 0.0_dp - fdswcl = 0.0_dp - fuswcl = 0.0_dp - fdlwcl = 0.0_dp - fulwcl = 0.0_dp - - end subroutine setup_radiation_variables - - !--------------------------------------------------------------------- - subroutine cleanup_radiation_variables( ) - - ! Description: - ! Subroutine to deallocate variables defined in module global - !--------------------------------------------------------------------- - - implicit none - - ! --- Deallocate --- - - deallocate( radht_SW ) - deallocate( radht_LW ) - deallocate( Frad_SW ) - deallocate( Frad_LW ) - - deallocate( T_in_K ) - deallocate( rcil ) - deallocate( o3l ) - - deallocate( rsnowm_2d ) - deallocate( rcm_in_cloud_2d ) - deallocate( cloud_frac_2d ) - - deallocate( radht_SW_2d ) - deallocate( radht_LW_2d ) - - deallocate( Frad_uLW ) - deallocate( Frad_dLW ) - deallocate( Frad_uSW ) - deallocate( Frad_dSW ) - - deallocate( fdswcl ) - deallocate( fuswcl ) - deallocate( fdlwcl ) - deallocate( fulwcl ) - - end subroutine cleanup_radiation_variables - - -end module variables_radiation_module diff --git a/models/csm_share/shr/shr_log_mod.F90 b/models/csm_share/shr/shr_log_mod.F90 index 4610eb98afd0..a8802cb7cd0a 100644 --- a/models/csm_share/shr/shr_log_mod.F90 +++ b/models/csm_share/shr/shr_log_mod.F90 @@ -14,6 +14,7 @@ module shr_log_mod ! !USES: use shr_kind_mod + use shr_strconvert_mod, only: toString use, intrinsic :: iso_fortran_env, only: output_unit @@ -27,6 +28,7 @@ module shr_log_mod ! !PUBLIC MEMBER FUNCTIONS: public :: shr_log_errMsg + public :: shr_log_OOBMsg ! !PUBLIC DATA MEMBERS: @@ -72,4 +74,26 @@ function shr_log_errMsg(file, line) end function shr_log_errMsg +! Create a message for an out of bounds error. +pure function shr_log_OOBMsg(operation, bounds, idx) result(OOBMsg) + + ! A name for the operation being attempted when the bounds error + ! occurred. A string containing the subroutine name is ideal, but more + ! generic descriptions such as "read", "modify", or "insert" could be used. + character(len=*), intent(in) :: operation + + ! Upper and lower bounds allowed for the operation. + integer, intent(in) :: bounds(2) + + ! Index at which access was attempted. + integer, intent(in) :: idx + + ! Output message + character(len=:), allocatable :: OOBMsg + + allocate(OOBMsg, source=(operation//": "//toString(idx)//" not in range ["//& + toString(bounds(1))//", "//toString(bounds(2))//"].")) + +end function shr_log_OOBMsg + end module shr_log_mod diff --git a/models/csm_share/shr/shr_strconvert_mod.F90 b/models/csm_share/shr/shr_strconvert_mod.F90 new file mode 100644 index 000000000000..da8aca24436b --- /dev/null +++ b/models/csm_share/shr/shr_strconvert_mod.F90 @@ -0,0 +1,166 @@ +module shr_strconvert_mod + +! This module defines toString, a generic function for creating character type +! representations of data, as implemented for the most commonly used intrinsic +! types: +! +! - 4 and 8 byte integer +! - 4 and 8 byte real +! - logical +! +! No toString implementation is provided for character input, but this may be +! added if some use case arises. +! +! Currently, only scalar inputs are supported. The return type of this function +! is character with deferred (allocatable) length. +! +! The functions for integers and reals allow an optional format_string argument, +! which can be used to control the padding and precision of output as with any +! write statement. However, the implementations internally must use a +! preallocated buffer, so a format_string that significantly increases the size +! of the output may cause a run-time error or undefined behavior in the program. +! +! Other modules may want to provide extensions of toString for their own derived +! types. In this case there are two guidelines to observe: +! +! - It is preferable to have only one mandatory argument, which is the object to +! produce a string from. There may be other formatting options, but the +! implementation should do something sensible without these. +! +! - Since the main purpose of toString is to provide a human-readable +! representation of a type, especially for documentation or debugging +! purposes, refrain from printing large array components in their entirety +! (instead consider printing only the shape, or statistics such as +! min/mean/max for arrays of numbers). + +use shr_kind_mod, only: & + i4 => shr_kind_i4, & + i8 => shr_kind_i8, & + r4 => shr_kind_r4, & + r8 => shr_kind_r8, & + cs => shr_kind_cs + +use shr_infnan_mod, only: & + isnan => shr_infnan_isnan + +implicit none +private + +! Human-readable representation of data. +public :: toString + +interface toString + module procedure i4ToString + module procedure i8ToString + module procedure r4ToString + module procedure r8ToString + module procedure logicalToString +end interface toString + +contains + +pure function i4ToString(input, format_string) result(string) + integer(i4), intent(in) :: input + character(len=*), intent(in), optional :: format_string + character(len=:), allocatable :: string + + character(len=cs) :: buffer + + if (present(format_string)) then + write(buffer, format_string) input + else + ! For most compilers, these two statements are equivalent to a format of + ! '(I0)', but that's not technically in the standard. + write(buffer, '(I11)') input + buffer = adjustl(buffer) + end if + + allocate(string, source=trim(buffer)) + +end function i4ToString + +pure function i8ToString(input, format_string) result(string) + integer(i8), intent(in) :: input + character(len=*), intent(in), optional :: format_string + character(len=:), allocatable :: string + + character(len=cs) :: buffer + + if (present(format_string)) then + write(buffer, format_string) input + else + ! For most compilers, these two statements are equivalent to a format of + ! '(I0)', but that's not technically in the standard. + write(buffer, '(I20)') input + buffer = adjustl(buffer) + end if + + allocate(string, source=trim(buffer)) + +end function i8ToString + +pure function r4ToString(input, format_string) result(string) + real(r4), intent(in) :: input + character(len=*), intent(in), optional :: format_string + character(len=:), allocatable :: string + + character(len=cs) :: buffer + + if (present(format_string)) then + write(buffer, format_string) input + else + write(buffer, '(ES15.8 E2)') input + buffer = adjustl(buffer) + ! Deal with the fact that the "+" sign is optional by simply adding it if + ! it is not present, so that the default format is standardized across + ! compilers. + ! Assumes that compilers do not treat the sign bit on NaN values specially. + if (.not. isnan(input) .and. all(buffer(1:1) /= ["-", "+"])) then + buffer = "+" // trim(buffer) + end if + end if + + allocate(string, source=trim(buffer)) + +end function r4ToString + +pure function r8ToString(input, format_string) result(string) + real(r8), intent(in) :: input + character(len=*), intent(in), optional :: format_string + character(len=:), allocatable :: string + + character(len=cs) :: buffer + + if (present(format_string)) then + write(buffer, format_string) input + else + write(buffer, '(ES24.16 E3)') input + buffer = adjustl(buffer) + ! Deal with the fact that the "+" sign is optional by simply adding it if + ! it is not present, so that the default format is standardized across + ! compilers. + ! Assumes that compilers do not treat the sign bit on NaN values specially. + if (.not. isnan(input) .and. all(buffer(1:1) /= ["-", "+"])) then + buffer = "+" // trim(buffer) + end if + end if + + allocate(string, source=trim(buffer)) + +end function r8ToString + +pure function logicalToString(input) result(string) + logical, intent(in) :: input + character(len=:), allocatable :: string + + ! We could use a write statement, but this is easier. + allocate(character(len=1) :: string) + if (input) then + string = "T" + else + string = "F" + end if + +end function logicalToString + +end module shr_strconvert_mod diff --git a/models/drv/driver/seq_domain_mct.F90 b/models/drv/driver/seq_domain_mct.F90 index f99fb85c9c05..7305b7bf85a7 100644 --- a/models/drv/driver/seq_domain_mct.F90 +++ b/models/drv/driver/seq_domain_mct.F90 @@ -32,7 +32,7 @@ module seq_domain_mct real(R8), parameter :: eps_tiny = 1.0e-16_R8 ! roundoff eps real(R8), parameter :: eps_big = 1.0e+02_R8 ! big eps - real(R8), parameter :: eps_frac_samegrid = 1.0e-14_R8 ! epsilon for fractions for samegrid + real(R8), parameter :: eps_frac_samegrid = 1.0e-9_R8 ! epsilon for fractions for samegrid !-------------------------------------------------------------------------- ! Private interfaces diff --git a/models/lnd/clm/bld/namelist_files/namelist_defaults_clm4_0.xml b/models/lnd/clm/bld/namelist_files/namelist_defaults_clm4_0.xml index 3ec02e0170d7..d0e75a5edc1d 100644 --- a/models/lnd/clm/bld/namelist_files/namelist_defaults_clm4_0.xml +++ b/models/lnd/clm/bld/namelist_files/namelist_defaults_clm4_0.xml @@ -220,6 +220,12 @@ ic_tod="0" sim_year="2000" glc_nec="0" irrig=".false.">lnd/clm2/initdata/clmi.BC ic_tod="0" sim_year="2000" glc_nec="0" irrig=".false.">lnd/clm2/initdata/clmi.BCN.2000-01-01_ne30np4_gx1v6_simyr2000_c110328.nc + +lnd/clm2/initdata/clmi.armx8v3.1850-01-01.nc +lnd/clm2/initdata/clmi.conusx4v1.2000-01-01_c141106.nc +lnd/clm2/initdata/clmi.svalbardx8v1.1850-01-01.nc +lnd/clm2/initdata/clmi.sooberingoax4x8v1.1850-01-01_c141110.nc + lnd/clm2/surfdata/surfdata_10x15_USGS_070307.nc @@ -290,6 +296,17 @@ lnd/clm2/surfdata_map/surfdata_ne120np4_simyr2000_c130313.nc lnd/clm2/surfdata_map/surfdata_ne240np4_simyr2000_c130313.nc + +lnd/clm2/surfdata_map/surfdata_armx8v3_simyr2000_c140518.nc + + +lnd/clm2/surfdata_map/surfdata_conusx4v1_simyr2000_c141024.nc + + +lnd/clm2/surfdata_map/surfdata_svalbardx8v1_simyr2000_c141024.nc + + +lnd/clm2/surfdata_map/surfdata_sooberingoax4x8v1_simyr2000_c141024.nc @@ -380,6 +397,18 @@ lnd/clm2/surfdata_map/surfdata_ne120np4_simyr1850_c130311.nc lnd/clm2/surfdata_map/surfdata_ne240np4_simyr1850_c130313.nc + +lnd/clm2/surfdata_map/surfdata_armx8v3_simyr1850_c140518.nc + + +lnd/clm2/surfdata_map/surfdata_conusx4v1_simyr1850_c141024.nc + + +lnd/clm2/surfdata_map/surfdata_svalbardx8v1_simyr1850_c141024.nc + + +lnd/clm2/surfdata_map/surfdata_sooberingoax4x8v1_simyr1850_c141024.nc + lnd/clm2/surfdata/surfdata_1x1_tropicAtl_simyr1850_c090923.nc diff --git a/models/lnd/clm/bld/namelist_files/namelist_definition_clm4_0.xml b/models/lnd/clm/bld/namelist_files/namelist_definition_clm4_0.xml index 8d3f52f46b90..5e51b23c43f7 100644 --- a/models/lnd/clm/bld/namelist_files/namelist_definition_clm4_0.xml +++ b/models/lnd/clm/bld/namelist_files/namelist_definition_clm4_0.xml @@ -685,7 +685,7 @@ CLM run type. +"512x1024,360x720cru,128x256,64x128,48x96,32x64,8x16,94x192,0.23x0.31,0.47x0.63,0.9x1.25,1.9x2.5,2.5x3.33,4x5,10x15,5x5_amazon,1x1_tropicAtl,1x1_camdenNJ,1x1_vancouverCAN,1x1_mexicocityMEX,1x1_asphaltjungleNJ,1x1_brazil,1x1_urbanc_alpha,1x1_numaIA,1x1_smallvilleIA,0.1x0.1,0.5x0.5,3x3min,5x5min,10x10min,0.33x0.33,ne4np4,ne16np4,ne30np4,ne60np4,ne120np4,ne240np4,ne0np4_arm_x8v3_lowcon,ne0np4_conus_x4v1_lowcon,ne0np4_svalbard_x8v1_lowcon,ne0np4_sooberingoa_x4x8v1_lowcon"> Horizontal resolutions Note: 0.1x0.1, 0.5x0.5, 5x5min, 10x10min, 3x3min and 0.33x0.33 are only used for CLM tools diff --git a/scripts/ccsm_utils/Case.template/config_compsets.xml b/scripts/ccsm_utils/Case.template/config_compsets.xml index edc1341ccb6a..46740f621f5d 100644 --- a/scripts/ccsm_utils/Case.template/config_compsets.xml +++ b/scripts/ccsm_utils/Case.template/config_compsets.xml @@ -536,7 +536,7 @@ GEOS => GEOS5 meteorology for "stand-alone" CAM fv eul -se +se -phys cam4 -phys cam5 @@ -1501,7 +1501,11 @@ DOCN%COPY => docn copy mode 96 96 96 -96 +144 +144 +96 +144 +144 144 288 48 diff --git a/scripts/ccsm_utils/Case.template/config_grid.xml b/scripts/ccsm_utils/Case.template/config_grid.xml index cdd5d73b3f8a..86a7319fb8e2 100644 --- a/scripts/ccsm_utils/Case.template/config_grid.xml +++ b/scripts/ccsm_utils/Case.template/config_grid.xml @@ -89,6 +89,10 @@ Each grid is associated with five names a%ne60np4_l%ne60np4_oi%ne60np4_r%r05_m%gx1v6_g%null_w%null a%ne120np4_l%ne120np4_oi%ne120np4_r%r05_m%gx1v6_g%null_w%null a%ne240np4_l%ne240np4_oi%ne240np4_r%null_m%gx1v6_g%null_w%null + a%ne0np4_arm_x8v3_lowcon_l%ne0np4_arm_x8v3_lowcon_oi%ne0np4_arm_x8v3_lowcon_r%r01_m%gx1v6_g%null_w%null + a%ne0np4_conus_x4v1_lowcon_l%ne0np4_conus_x4v1_lowcon_oi%ne0np4_conus_x4v1_lowcon_r%r01_m%tx0.1v2_g%null_w%null + a%ne0np4_svalbard_x8v1_lowcon_l%ne0np4_svalbard_x8v1_lowcon_oi%ne0np4_svalbard_x8v1_lowcon_r%r01_m%tx0.1v2_g%null_w%null + a%ne0np4_sooberingoa_x4x8v1_lowcon_l%ne0np4_sooberingoa_x4x8v1_lowcon_oi%ne0np4_sooberingoa_x4x8v1_lowcon_r%r01_m%tx0.1v2_g%null_w%null @@ -299,6 +303,26 @@ Each grid is associated with five names ne240np4 is Spectral Elem 1/8-deg grid: + + 92558 1 + 1-deg with 1/8-deg over U.S. (version 3): + + + + 89147 1 + 1-deg with 1/4-deg over Cont. U.S. (version 1): + + + + 71912 1 + 1-deg with 1/8-deg over the island if Svalbard (version 1): + + + + 105707 1 + 1-deg with 1/4-deg to 1/8-deg over Sea of Okhotsk, Bering Sea, Gulf of Alaska to ARM-NSA site (version 1): + + @@ -502,6 +526,10 @@ do not use scientific experiments; use the T62_g16 resolution instead: 1.0e-12 9.0e-07 +9.0e-06 +9.0e-06 +9.0e-06 +9.0e-06 1.0e-06 1.0e-02 @@ -905,6 +933,13 @@ do not use scientific experiments; use the T62_g16 resolution instead: domain.ocn.ne240np4_gx1v6.111226.nc + + domain.lnd.ne240np4_tx0.1v2_111209.nc + domain.lnd.ne240np4_tx0.1v2_111209.nc + domain.ocn.ne240np4_tx0.1v2.121113.nc + domain.ocn.ne240np4_tx0.1v2.121113.nc + + cpl/gridmaps/ne240np4/map_ne240np4_to_gx1v6_aave_110428.nc cpl/gridmaps/ne240np4/map_ne240np4_to_gx1v6_aave_110428.nc @@ -915,8 +950,8 @@ do not use scientific experiments; use the T62_g16 resolution instead: cpl/gridmaps/ne240np4/map_ne240np4_to_tx0.1v2_aave_110419.nc - cpl/gridmaps/ne240np4/map_ne240np4_to_tx0.1v2_aave_110419.nc - cpl/gridmaps/ne240np4/map_ne240np4_to_tx0.1v2_aave_110419.nc + cpl/gridmaps/ne240np4/map_ne240np4_to_tx0.1v2_native_120327.nc + cpl/gridmaps/ne240np4/map_ne240np4_to_tx0.1v2_native_120327.nc cpl/gridmaps/tx0.1v2/map_tx0.1v2_to_ne240np4_aave_110419.nc cpl/gridmaps/tx0.1v2/map_tx0.1v2_to_ne240np4_aave_110419.nc @@ -928,6 +963,34 @@ do not use scientific experiments; use the T62_g16 resolution instead: cpl/gridmaps/fv0.23x0.31/map_fv0.23x0.31_to_ne240np4_aave_110428.nc + + domain.lnd.armx8v3_gx1v6.140517.nc + domain.lnd.armx8v3_gx1v6.140517.nc + domain.ocn.armx8v3_gx1v6.140517.nc + domain.ocn.armx8v3_gx1v6.140517.nc + + + + domain.lnd.conusx4v1_tx0.1v2.141022.nc + domain.lnd.conusx4v1_tx0.1v2.141022.nc + domain.ocn.conusx4v1_tx0.1v2.141022.nc + domain.ocn.conusx4v1_tx0.1v2.141022.nc + + + + domain.lnd.svalbardx8v1_tx0.1v2.141022.nc + domain.lnd.svalbardx8v1_tx0.1v2.141022.nc + domain.ocn.svalbardx8v1_tx0.1v2.141022.nc + domain.ocn.svalbardx8v1_tx0.1v2.141022.nc + + + + domain.lnd.sooberingoax4x8v1_tx0.1v2.141022.nc + domain.lnd.sooberingoax4x8v1_tx0.1v2.141022.nc + domain.ocn.sooberingoax4x8v1_tx0.1v2.141022.nc + domain.ocn.sooberingoax4x8v1_tx0.1v2.141022.nc + + diff --git a/scripts/ccsm_utils/Machines/Depends.cetus b/scripts/ccsm_utils/Machines/Depends.cetus index e49e043c0e3b..85b484ce9203 100644 --- a/scripts/ccsm_utils/Machines/Depends.cetus +++ b/scripts/ccsm_utils/Machines/Depends.cetus @@ -11,4 +11,5 @@ mo_drydep.o: mo_drydep.F90 $(FC) -c $(INCLDIR) $(INCS) $(FFLAGS) $(FREEFLAGS) -qsmp=noauto:noomp $< time_management.o: time_management.F90 $(FC) -c $(INCLDIR) $(INCS) $(FFLAGS) $(FREEFLAGS) -qsmp=noauto:noomp $< - +advance_clubb_core_module.o: advance_clubb_core_module.F90 + $(FC) -c $(INCLDIR) $(INCS) $(FFLAGS) $(FREEFLAGS) -qsmp=omp:noopt -qinitauto=7FF7FFFF $< diff --git a/scripts/ccsm_utils/Machines/Depends.mira b/scripts/ccsm_utils/Machines/Depends.mira index cb20eb4e40b3..a82023aeef3a 100644 --- a/scripts/ccsm_utils/Machines/Depends.mira +++ b/scripts/ccsm_utils/Machines/Depends.mira @@ -49,4 +49,8 @@ clmtypeInitMod.o: clmtypeInitMod.F90 # this takes 2 mins to compile with -qsmp=omp clmtype.o: clmtype.F90 $(FC) -c $(INCLDIR) $(INCS) $(FFLAGS) $(FREEFLAGS) -qsmp=noopt $< + +# this allows CLUBBe, an updated CLUBB, to run on mira +advance_clubb_core_module.o: advance_clubb_core_module.F90 + $(FC) -c $(INCLDIR) $(INCS) $(FFLAGS) $(FREEFLAGS) -qsmp=omp:noopt -qinitauto=7FF7FFFF $< ### end